1 \
=== sorted
-array
=== /
2 \
Here are a few utility functions
useful for creating
and maintaining
3 \ the
deftype* method tables
. The keys array is
kept in sorted order
,
4 \
and the
methods array is
maintained in parallel
so that
an index into
5 \ one
corresponds to an index
in the
other.
7 \
Search a sorted array
for key
, returning the
index of where
it was
8 \ found
. If key is
not in the
array, return the
index where
it would
10 : array-find
{ a
-length a
-addr key
-- index found
? }
11 0 a
-length
( start
end )
14 2dup + 2 / dup
( start
end middle
middle )
15 cells
a-addr
+ @ ( start
end middle mid-val )
17 drop rot
( end middle start )
21 drop swap
( middle end )
24 key
> if ( start end middle )
27 -rot
2drop dup
( middle middle )
31 cells
a-addr
+ @ key
=
34 \
Create a new array, one
cell in length
, initialized the
provided value
35 : new-array { value
-- array }
36 cell allocate throw value
over ! ;
38 \
Resize a heap
-allocated
array to be
one cell longer, inserting value
39 \ at
idx, and shifting the
tail of the
array as necessary. Returns the
40 \
(possibly
new) array address
41 : array-insert
{ old
-array-length old
-array idx value
-- array }
42 old
-array old
-array-length
1+ cells
resize throw
44 a idx cells
+ dup
cell+ old
-array-length
idx - cells
cmove>
50 \
=== deftype* -- protocol
-enabled structs
=== /
51 \
Each type has MalTypeType% struct allocated on
the stack, with
52 \
mutable fields pointing
to all
class-shared resources
, specifically
53 \
the data needed
to allocate new instances
, and the table of protocol
54 \
methods that have
been extended
to the type.
55 \
Use 'deftype*' to define
a new type, and 'new' to create
new
56 \ instances
of that type.
60 \
cell% field
ref-count \
Ha, right
.
64 cell% 2 * field
MalTypeType-struct
65 cell% field
MalTypeType-methods
66 cell% field
MalTypeType-method
-keys
67 cell% field
MalTypeType-method
-vals
68 cell% field
MalTypeType-name
-addr
69 cell% field
MalTypeType-name
-len
70 end-struct MalTypeType%
72 : new ( MalTypeType -- obj
)
73 dup
MalTypeType-struct 2@ %allocate
throw ( MalTypeType obj ) \ create
struct
74 dup
-rot
mal-type ! ( obj ) \ set
struct's type pointer to this type
77 : deftype* ( struct-align struct-len -- MalTypeType )
78 MalTypeType% %allot ( s-a s-l MalTypeType )
79 dup 2swap rot ( MalTypeType s-a s-l MalTypeType )
80 MalTypeType-struct 2! ( MalTypeType ) \ store struct info
81 dup MalTypeType-methods 0 swap ! ( MalTypeType )
82 dup MalTypeType-method-keys nil swap ! ( MalTypeType )
83 dup MalTypeType-method-vals nil swap ! ( MalTypeType )
84 dup MalTypeType-name-len 0 swap ! ( MalTypeType )
87 \ parse-name uses temporary space, so copy into dictionary stack:
88 : parse-allot-name { -- new-str-addr str-len }
89 parse-name { str-addr str-len }
90 here { new-str-addr } str-len allot
91 str-addr new-str-addr str-len cmove
92 new-str-addr str-len ;
94 : deftype ( struct-align struct-len R:type-name -- )
95 parse-allot-name { name-addr name-len }
97 \ allot and initialize type structure
99 name-addr mt MalTypeType-name-addr !
100 name-len mt MalTypeType-name-len !
101 \ ." Defining " mt MalTypeType-name-addr @ mt MalTypeType-name-len @ type cr
102 mt name-addr name-len nextname 1 0 const-does> ;
104 : type-name ( mal-type )
105 dup MalTypeType-name-addr @ ( mal-type name-addr )
106 swap MalTypeType-name-len @ ( name-addr name-len )
109 MalType% deftype MalDefault
111 \ nil type and instance to support extending protocols to it
112 MalType% deftype MalNil MalNil new constant mal-nil
113 MalType% deftype MalTrue MalTrue new constant mal-true
114 MalType% deftype MalFalse MalFalse new constant mal-false
117 0= if mal-false else mal-true endif ;
119 : not-object? ( obj -- bool )
126 \ === protocol methods === /
130 \ Used by protocol methods to find the appropriate implementation of
131 \ themselves for the given object, and then execute that implementation.
132 : execute-method { obj pxt -- }
134 ." Refusing to invoke protocol fn '"
135 pxt >name name>string type
136 ." ' on non-object: " obj .
139 obj mal-type @ dup MalTypeType-methods 2@ swap ( type methods method-keys )
140 dup 0= if \ No protocols extended to this type; check for a default
141 2drop drop MalDefault MalTypeType-methods 2@ swap
144 pxt array-find ( type idx found? )
145 dup 0= if \ No implementation found for this method; check for a default
146 2drop drop MalDefault dup MalTypeType-methods 2@ swap
147 pxt array-find ( type idx found? )
152 pxt >name name>string type
153 ." ' extended to type '"
154 obj mal-type @ type-name type
158 trace if ." Calling '" pxt >name name>string type ." ' on " obj mal-type @ type-name type cr endif
160 cells swap MalTypeType-method-vals @ + @ ( xt )
163 \ Extend a type with a protocol method. This mutates the MalTypeType
164 \ object that represents the MalType being extended.
165 : extend-method* { type pxt ixt -- type }
166 type MalTypeType-methods 2@ swap ( methods method-keys )
167 dup 0= if \ no protocols extended to this type
169 1 type MalTypeType-methods !
170 pxt new-array type MalTypeType-method-keys !
171 ixt new-array type MalTypeType-method-vals !
173 pxt array-find { idx found? }
174 found? if \ overwrite
175 ." Warning: overwriting protocol method implementation"
176 type MalTypeType-method-vals @ idx cells + ixt !
178 type MalTypeType-methods dup @ 1+ dup rot ! ( new-count )
179 1- dup type MalTypeType-method-keys @ idx pxt array-insert ( old-count new-array )
180 type MalTypeType-method-keys ! ( old-count )
181 type MalTypeType-method-vals @ idx ixt array-insert ( new-array )
182 type MalTypeType-method-vals !
189 \ def-protocol-method pr-str ...can be written:
190 \ : pr-str ( obj -- str ) [ latestxt ] literal execute-method ;
191 : def-protocol-method ( "name" -- )
193 does> ( ??? obj xt-ref -- ??? )
196 : extend ( type -- type pxt install-xt <noname...>)
197 parse-name find-name name>int ( type pxt )
202 : ;; ( type pxt <noname
...> -- type )
203 [compile
] ; ( type pxt install
-xt
ixt )
208 \
These whole-protocol names are only needed
for 'satisfies?':
210 def
-protocol-method pr
-str
213 MalList IPrintable extend
214 ' pr-str :noname drop s" <unprintable>" ; extend-method*
217 drop s" <unprintable>" ;;
221 \ === Mal types and protocols === /
223 def-protocol-method conj ( obj this -- this )
224 def-protocol-method assoc ( k v this -- this )
225 def-protocol-method get ( not-found k this -- value )
226 def-protocol-method mal= ( a b -- bool )
227 def-protocol-method as-native ( obj -- )
229 def-protocol-method to-list ( obj -- mal-list )
230 def-protocol-method empty? ( obj -- mal-bool )
231 def-protocol-method mal-count ( obj -- mal-int )
242 cell% field MalInt/int
245 : MalInt. { int -- mal-int }
246 MalInt new dup MalInt/int int swap ! ;
249 extend mal= ( other this -- bool )
250 over mal-type @ MalInt = if
251 MalInt/int @ swap MalInt/int @ =
256 extend as-native ( mal-int -- int )
262 cell% field MalList/count
263 cell% field MalList/start
266 : here>MalList ( old-here -- mal-list )
267 here over - { bytes } ( old-here )
268 MalList new bytes ( old-here mal-list bytes )
269 allocate throw dup { target } over MalList/start ! ( old-here mal-list )
270 bytes cell / over MalList/count ! ( old-here mal-list )
271 swap target bytes cmove ( mal-list )
272 0 bytes - allot \ pop list contents from dictionary stack
277 extend conj { elem old-list -- list }
278 old-list MalList/count @ 1+ { new-count }
279 new-count cells allocate throw { new-start }
282 old-list MalList/start @ new-start cell+ new-count 1- cells cmove
286 new-count over MalList/count !
287 new-start over MalList/start ! ;;
288 extend empty? MalList/count @ 0= mal-bool ;;
289 extend mal-count MalList/count @ MalInt. ;;
291 swap to-list dup 0= if
294 2dup MalList/count @ swap MalList/count @ over = if ( list-a list-b count )
295 -rot MalList/start @ swap MalList/start @ { start-b start-a }
296 true swap ( return-val count )
310 MalList new 0 over MalList/count ! constant MalList/Empty
312 : MalList/rest { list -- list }
314 list MalList/start @ cell+ over MalList/start !
315 list MalList/count @ 1- over MalList/count ! ;
319 cell% field MalVector/list
327 MalList/count @ 0= mal-bool ;;
330 MalList/count @ MalInt. ;;
332 MalVector/list @ swap m= ;;
336 cell% field MalMap/list
339 MalMap new MalList/Empty over MalMap/list ! constant MalMap/Empty
342 extend conj ( kv map -- map )
343 MalMap/list @ \ get list
344 over MalList/start @ cell+ @ swap conj \ add value
345 swap MalList/start @ @ swap conj \ add key
346 MalMap new dup -rot MalMap/list ! \ put back in map
348 extend assoc ( k v map -- map )
349 MalMap/list @ \ get list
351 MalMap new dup -rot MalMap/list ! \ put back in map
353 extend get { not-found k map -- value }
355 dup MalList/start @ { start }
356 MalList/count @ { count }
362 start over cells + @ k m= if
363 start swap cells + cell+ @ true \ found it ( value true )
371 MalList/count @ 0= mal-bool ;;
374 MalList/count @ 2 / MalInt. ;;
377 \ Examples of extending existing protocol methods to existing type
379 extend conj ( obj this -- this )
381 extend as-native ;; ( obj -- obj )
382 extend to-list drop 0 ;;
386 extend conj ( item nil -- mal-list )
387 drop MalList/Empty conj ;;
388 extend as-native drop 0 ;;
389 extend empty? drop mal-true ;;
390 extend mal-count drop 0 MalInt. ;;
391 extend mal= drop mal-nil = ;;
395 cell% field MalSymbol/sym-addr
396 cell% field MalSymbol/sym-len
397 cell% field MalSymbol/meta
400 : MalSymbol. { str-addr str-len -- mal-sym }
401 MalSymbol new { sym }
402 str-addr sym MalSymbol/sym-addr !
403 str-len sym MalSymbol/sym-len !
404 MalMap/Empty sym MalSymbol/meta !
407 : unpack-sym ( mal-string -- addr len )
408 dup MalSymbol/sym-addr @
409 swap MalSymbol/sym-len @ ;
412 extend mal= ( other this -- bool )
413 over mal-type @ MalSymbol = if
414 unpack-sym rot unpack-sym str=
418 ' as-native
' unpack-sym extend-method*
422 cell% field MalKeyword/str-addr
423 cell% field MalKeyword/str-len
426 : unpack-keyword ( mal-keyword -- addr len )
427 dup MalKeyword/str-addr @
428 swap MalKeyword/str-len @ ;
431 extend mal= ( other this -- bool )
432 over mal-type @ MalKeyword = if
433 unpack-keyword rot unpack-keyword str=
437 ' as-native
' unpack-keyword extend-method*
440 : MalKeyword. { str-addr str-len -- mal-keyword }
441 MalKeyword new { kw }
442 str-addr kw MalKeyword/str-addr !
443 str-len kw MalKeyword/str-len !
447 cell% field MalString/str-addr
448 cell% field MalString/str-len
451 : MalString. { str-addr str-len -- mal-str }
452 MalString new { str }
453 str-addr str MalString/str-addr !
454 str-len str MalString/str-len !
457 : unpack-str ( mal-string -- addr len )
458 dup MalString/str-addr @
459 swap MalString/str-len @ ;
462 extend mal= ( other this -- bool )
463 over mal-type @ MalString = if
464 unpack-str rot unpack-str str=
468 ' as-native
' unpack-str extend-method*
473 cell% field MalNativeFn/xt
474 cell% field MalNativeFn/meta
477 : MalNativeFn. { xt -- mal-fn }
478 MalNativeFn new { mal-fn }
479 xt mal-fn MalNativeFn/xt !
480 MalMap/Empty mal-fn MalNativeFn/meta !
490 cell% field MalUserFn/meta
491 cell% field MalUserFn/env
492 cell% field MalUserFn/formal-args
493 cell% field MalUserFn/var-arg
494 cell% field MalUserFn/body
499 cell% field SpecialOp/xt
503 SpecialOp new swap over SpecialOp/xt ! ;