Commit | Line | Data |
---|---|---|
580c4eef C |
1 | require str.fs |
2 | ||
b745d191 C |
3 | \ === sorted-array === / |
4 | \ Here are a few utility functions useful for creating and maintaining | |
5 | \ the deftype* method tables. The keys array is kept in sorted order, | |
6 | \ and the methods array is maintained in parallel so that an index into | |
7 | \ one corresponds to an index in the other. | |
8 | ||
9 | \ Search a sorted array for key, returning the index of where it was | |
10 | \ found. If key is not in the array, return the index where it would | |
11 | \ be if added. | |
12 | : array-find { a-length a-addr key -- index found? } | |
13 | 0 a-length ( start end ) | |
14 | begin | |
15 | \ cr 2dup . . | |
16 | 2dup + 2 / dup ( start end middle middle ) | |
17 | cells a-addr + @ ( start end middle mid-val ) | |
18 | dup key < if | |
19 | drop rot ( end middle start ) | |
20 | 2dup = if | |
21 | 2drop dup ( end end ) | |
22 | else | |
23 | drop swap ( middle end ) | |
24 | endif | |
25 | else | |
26 | key > if ( start end middle ) | |
50e417ff | 27 | nip ( start middle ) |
b745d191 C |
28 | else |
29 | -rot 2drop dup ( middle middle ) | |
30 | endif | |
31 | endif | |
32 | 2dup = until | |
b254151c C |
33 | dup a-length = if |
34 | drop false | |
35 | else | |
36 | cells a-addr + @ key = | |
37 | endif ; | |
b745d191 C |
38 | |
39 | \ Create a new array, one cell in length, initialized the provided value | |
40 | : new-array { value -- array } | |
41 | cell allocate throw value over ! ; | |
42 | ||
43 | \ Resize a heap-allocated array to be one cell longer, inserting value | |
44 | \ at idx, and shifting the tail of the array as necessary. Returns the | |
45 | \ (possibly new) array address | |
46 | : array-insert { old-array-length old-array idx value -- array } | |
47 | old-array old-array-length 1+ cells resize throw | |
48 | { a } | |
49 | a idx cells + dup cell+ old-array-length idx - cells cmove> | |
50 | value a idx cells + ! | |
51 | a | |
52 | ; | |
53 | ||
b745d191 | 54 | |
59038a10 C |
55 | \ === deftype* -- protocol-enabled structs === / |
56 | \ Each type has MalTypeType% struct allocated on the stack, with | |
57 | \ mutable fields pointing to all class-shared resources, specifically | |
58 | \ the data needed to allocate new instances, and the table of protocol | |
59 | \ methods that have been extended to the type. | |
60 | \ Use 'deftype*' to define a new type, and 'new' to create new | |
61 | \ instances of that type. | |
62 | ||
63 | struct | |
64 | cell% field mal-type | |
224e09ed | 65 | cell% field mal-meta |
59038a10 C |
66 | \ cell% field ref-count \ Ha, right. |
67 | end-struct MalType% | |
68 | ||
69 | struct | |
70 | cell% 2 * field MalTypeType-struct | |
71 | cell% field MalTypeType-methods | |
72 | cell% field MalTypeType-method-keys | |
73 | cell% field MalTypeType-method-vals | |
9da223a3 C |
74 | cell% field MalTypeType-name-addr |
75 | cell% field MalTypeType-name-len | |
59038a10 C |
76 | end-struct MalTypeType% |
77 | ||
78 | : new ( MalTypeType -- obj ) | |
79 | dup MalTypeType-struct 2@ %allocate throw ( MalTypeType obj ) \ create struct | |
80 | dup -rot mal-type ! ( obj ) \ set struct's type pointer to this type | |
224e09ed | 81 | nil over mal-meta ! |
59038a10 C |
82 | ; |
83 | ||
84 | : deftype* ( struct-align struct-len -- MalTypeType ) | |
85 | MalTypeType% %allot ( s-a s-l MalTypeType ) | |
86 | dup 2swap rot ( MalTypeType s-a s-l MalTypeType ) | |
87 | MalTypeType-struct 2! ( MalTypeType ) \ store struct info | |
88 | dup MalTypeType-methods 0 swap ! ( MalTypeType ) | |
89 | dup MalTypeType-method-keys nil swap ! ( MalTypeType ) | |
90 | dup MalTypeType-method-vals nil swap ! ( MalTypeType ) | |
9da223a3 | 91 | dup MalTypeType-name-len 0 swap ! ( MalTypeType ) |
59038a10 C |
92 | ; |
93 | ||
79feb89f C |
94 | \ parse-name uses temporary space, so copy into dictionary stack: |
95 | : parse-allot-name { -- new-str-addr str-len } | |
96 | parse-name { str-addr str-len } | |
97 | here { new-str-addr } str-len allot | |
98 | str-addr new-str-addr str-len cmove | |
99 | new-str-addr str-len ; | |
100 | ||
9da223a3 | 101 | : deftype ( struct-align struct-len R:type-name -- ) |
79feb89f | 102 | parse-allot-name { name-addr name-len } |
9da223a3 C |
103 | |
104 | \ allot and initialize type structure | |
105 | deftype* { mt } | |
106 | name-addr mt MalTypeType-name-addr ! | |
107 | name-len mt MalTypeType-name-len ! | |
108 | \ ." Defining " mt MalTypeType-name-addr @ mt MalTypeType-name-len @ type cr | |
109 | mt name-addr name-len nextname 1 0 const-does> ; | |
110 | ||
111 | : type-name ( mal-type ) | |
112 | dup MalTypeType-name-addr @ ( mal-type name-addr ) | |
113 | swap MalTypeType-name-len @ ( name-addr name-len ) | |
114 | ; | |
115 | ||
116 | MalType% deftype MalDefault | |
59038a10 C |
117 | |
118 | \ nil type and instance to support extending protocols to it | |
60801ed6 C |
119 | MalType% deftype MalNil MalNil new constant mal-nil |
120 | MalType% deftype MalTrue MalTrue new constant mal-true | |
121 | MalType% deftype MalFalse MalFalse new constant mal-false | |
122 | ||
123 | : mal-bool | |
124 | 0= if mal-false else mal-true endif ; | |
b745d191 | 125 | |
c05d35e8 C |
126 | : not-object? ( obj -- bool ) |
127 | dup 7 and 0 <> if | |
785786c6 | 128 | drop true |
c05d35e8 C |
129 | else |
130 | 1000000 < | |
131 | endif ; | |
132 | ||
b745d191 C |
133 | \ === protocol methods === / |
134 | ||
975126be C |
135 | struct |
136 | cell% field call-site/type | |
137 | cell% field call-site/xt | |
138 | end-struct call-site% | |
c4403c17 | 139 | |
b745d191 C |
140 | \ Used by protocol methods to find the appropriate implementation of |
141 | \ themselves for the given object, and then execute that implementation. | |
975126be | 142 | : execute-method { obj pxt call-site -- } |
c05d35e8 | 143 | obj not-object? if |
580c4eef C |
144 | 0 0 obj int>str s" ' on non-object: " pxt >name name>string |
145 | s" Refusing to invoke protocol fn '" ...throw-str | |
c05d35e8 | 146 | endif |
975126be | 147 | \ ." Calling '" pxt >name name>string type ." ' on " obj mal-type @ type-name type ." , cs " call-site . |
b745d191 | 148 | |
975126be C |
149 | obj mal-type @ ( type ) |
150 | dup call-site call-site/type @ = if | |
151 | \ ." hit!" cr | |
152 | drop | |
153 | call-site call-site/xt @ | |
154 | else | |
155 | \ ." miss!" cr | |
156 | dup MalTypeType-methods 2@ swap ( type methods method-keys ) | |
157 | dup 0= if \ No protocols extended to this type; check for a default | |
158 | 2drop drop MalDefault MalTypeType-methods 2@ swap | |
159 | endif | |
b745d191 | 160 | |
975126be C |
161 | pxt array-find ( type idx found? ) |
162 | dup 0= if \ No implementation found for this method; check for a default | |
163 | 2drop drop MalDefault dup MalTypeType-methods 2@ swap | |
164 | pxt array-find ( type idx found? ) | |
165 | endif | |
166 | 0= if ( type idx ) | |
167 | 2drop | |
168 | 0 0 s" '" obj mal-type @ type-name s" ' extended to type '" | |
169 | pxt >name name>string s" No protocol fn '" ...throw-str | |
170 | endif | |
171 | ||
172 | cells over MalTypeType-method-vals @ + @ ( type xt ) | |
173 | swap call-site call-site/type ! ( xt ) | |
174 | dup call-site call-site/xt ! ( xt ) | |
175 | endif | |
c4403c17 | 176 | obj swap execute ; |
b745d191 C |
177 | |
178 | \ Extend a type with a protocol method. This mutates the MalTypeType | |
179 | \ object that represents the MalType being extended. | |
180 | : extend-method* { type pxt ixt -- type } | |
975126be C |
181 | \ ." Extend '" pxt dup . >name name>string safe-type ." ' to " type type-name safe-type ." , " |
182 | \ type MalTypeType-methods 2@ ( method-keys methods ) | |
183 | \ 0 ?do | |
184 | \ dup i cells + @ >name name>string safe-type ." , " | |
185 | \ \ dup i cells + @ . | |
186 | \ loop | |
187 | \ drop cr | |
188 | ||
b745d191 C |
189 | type MalTypeType-methods 2@ swap ( methods method-keys ) |
190 | dup 0= if \ no protocols extended to this type | |
191 | 2drop | |
192 | 1 type MalTypeType-methods ! | |
193 | pxt new-array type MalTypeType-method-keys ! | |
194 | ixt new-array type MalTypeType-method-vals ! | |
195 | else | |
196 | pxt array-find { idx found? } | |
197 | found? if \ overwrite | |
b254151c C |
198 | ." Warning: overwriting protocol method implementation '" |
199 | pxt >name name>string safe-type ." ' on " type type-name safe-type ." , " idx . found? . cr | |
200 | ||
b745d191 C |
201 | type MalTypeType-method-vals @ idx cells + ixt ! |
202 | else \ resize | |
203 | type MalTypeType-methods dup @ 1+ dup rot ! ( new-count ) | |
204 | 1- dup type MalTypeType-method-keys @ idx pxt array-insert ( old-count new-array ) | |
205 | type MalTypeType-method-keys ! ( old-count ) | |
b745d191 C |
206 | type MalTypeType-method-vals @ idx ixt array-insert ( new-array ) |
207 | type MalTypeType-method-vals ! | |
b745d191 C |
208 | endif |
209 | endif | |
210 | type | |
211 | ; | |
212 | ||
b745d191 | 213 | |
975126be C |
214 | \ Define a new protocol function. For example: |
215 | \ def-protocol-method pr-str | |
216 | \ When called as above, defines a new word 'pr-str' and stores there its | |
217 | \ own xt (known as pxt). When a usage of pr-str is compiled, it | |
218 | \ allocates a call-site object on the heap and injects a reference to | |
219 | \ both that and the pxt into the compilation, along with a call to | |
220 | \ execute-method. Thus when pr-str runs, execute-method can check the | |
221 | \ call-site object to see if the type of the target object is the same | |
222 | \ as the last call for this site. If so, it executes the implementation | |
223 | \ immediately. Otherwise, it searches the target type's method list and | |
224 | \ if necessary MalDefault's method list. If an implementation of pxt is | |
225 | \ found, it is cached in the call-site, and then executed. | |
226 | : make-call-site { pxt -- } | |
227 | pxt postpone literal \ transfer pxt into call site | |
228 | call-site% %allocate throw dup postpone literal \ allocate call-site, push reference | |
229 | \ dup ." Make cs '" pxt >name name>string type ." ' " . cr | |
230 | 0 swap call-site/type ! | |
231 | postpone execute-method ; | |
232 | ||
233 | : def-protocol-method ( parse: name -- ) | |
234 | : latestxt postpone literal postpone make-call-site postpone ; immediate | |
235 | ; | |
b745d191 | 236 | |
79feb89f | 237 | : extend ( type -- type pxt install-xt <noname...>) |
14b846ff | 238 | parse-name find-name name>int ( type pxt ) |
79feb89f | 239 | ['] extend-method* |
14b846ff C |
240 | :noname |
241 | ; | |
b745d191 | 242 | |
14b846ff | 243 | : ;; ( type pxt <noname...> -- type ) |
79feb89f C |
244 | [compile] ; ( type pxt install-xt ixt ) |
245 | swap execute | |
14b846ff | 246 | ; immediate |
b745d191 | 247 | |
14b846ff C |
248 | ( |
249 | \ These whole-protocol names are only needed for 'satisfies?': | |
b745d191 | 250 | protocol IPrintable |
14b846ff | 251 | def-protocol-method pr-str |
b745d191 | 252 | end-protocol |
b745d191 | 253 | |
14b846ff | 254 | MalList IPrintable extend |
b745d191 C |
255 | ' pr-str :noname drop s" <unprintable>" ; extend-method* |
256 | ||
257 | extend-method pr-str | |
14b846ff | 258 | drop s" <unprintable>" ;; |
b745d191 C |
259 | end-extend |
260 | ) | |
261 | ||
59038a10 | 262 | \ === Mal types and protocols === / |
b745d191 | 263 | |
69972a83 | 264 | def-protocol-method conj ( obj this -- this ) |
82e2b26b | 265 | def-protocol-method seq ( obj -- mal-list|nil ) |
69972a83 | 266 | def-protocol-method assoc ( k v this -- this ) |
224e09ed | 267 | def-protocol-method dissoc ( k this -- this ) |
69972a83 C |
268 | def-protocol-method get ( not-found k this -- value ) |
269 | def-protocol-method mal= ( a b -- bool ) | |
270 | def-protocol-method as-native ( obj -- ) | |
60801ed6 | 271 | |
c05d35e8 | 272 | def-protocol-method to-list ( obj -- mal-list ) |
60801ed6 C |
273 | def-protocol-method empty? ( obj -- mal-bool ) |
274 | def-protocol-method mal-count ( obj -- mal-int ) | |
224e09ed | 275 | def-protocol-method sequential? ( obj -- mal-bool ) |
a631063f C |
276 | def-protocol-method get-map-hint ( obj -- hint ) |
277 | def-protocol-method set-map-hint! ( hint obj -- ) | |
224e09ed C |
278 | |
279 | ||
280 | \ Fully evalutate any Mal object: | |
281 | def-protocol-method mal-eval ( env ast -- val ) | |
282 | ||
283 | \ Invoke an object, given whole env and unevaluated argument forms: | |
284 | def-protocol-method eval-invoke ( env list obj -- ... ) | |
285 | ||
286 | \ Invoke a function, given parameter values | |
287 | def-protocol-method invoke ( argv argc mal-fn -- ... ) | |
288 | ||
289 | ||
69972a83 C |
290 | : m= ( a b -- bool ) |
291 | 2dup = if | |
785786c6 | 292 | 2drop true |
69972a83 C |
293 | else |
294 | mal= | |
295 | endif ; | |
296 | ||
60801ed6 C |
297 | |
298 | MalType% | |
299 | cell% field MalInt/int | |
300 | deftype MalInt | |
301 | ||
302 | : MalInt. { int -- mal-int } | |
303 | MalInt new dup MalInt/int int swap ! ; | |
304 | ||
305 | MalInt | |
306 | extend mal= ( other this -- bool ) | |
307 | over mal-type @ MalInt = if | |
308 | MalInt/int @ swap MalInt/int @ = | |
309 | else | |
310 | 2drop 0 | |
311 | endif ;; | |
312 | ||
313 | extend as-native ( mal-int -- int ) | |
314 | MalInt/int @ ;; | |
315 | drop | |
316 | ||
317 | ||
59038a10 | 318 | MalType% |
c05d35e8 C |
319 | cell% field MalList/count |
320 | cell% field MalList/start | |
9da223a3 | 321 | deftype MalList |
59038a10 | 322 | |
224e09ed C |
323 | : MalList. ( start count -- mal-list ) |
324 | MalList new | |
325 | swap over MalList/count ! ( start list ) | |
326 | swap over MalList/start ! ( list ) ; | |
327 | ||
c05d35e8 | 328 | : here>MalList ( old-here -- mal-list ) |
9da223a3 | 329 | here over - { bytes } ( old-here ) |
c05d35e8 C |
330 | MalList new bytes ( old-here mal-list bytes ) |
331 | allocate throw dup { target } over MalList/start ! ( old-here mal-list ) | |
332 | bytes cell / over MalList/count ! ( old-here mal-list ) | |
333 | swap target bytes cmove ( mal-list ) | |
334 | 0 bytes - allot \ pop list contents from dictionary stack | |
9da223a3 C |
335 | ; |
336 | ||
224e09ed C |
337 | : MalList/concat ( list-of-lists ) |
338 | dup MalList/start @ swap MalList/count @ { lists argc } | |
339 | 0 lists argc cells + lists +do ( count ) | |
340 | i @ to-list MalList/count @ + | |
341 | cell +loop { count } | |
342 | count cells allocate throw { start } | |
343 | start lists argc cells + lists +do ( target ) | |
344 | i @ to-list MalList/count @ cells 2dup i @ to-list MalList/start @ -rot ( target bytes src target bytes ) | |
345 | cmove ( target bytes ) | |
346 | + ( new-target ) | |
347 | cell +loop | |
348 | drop start count MalList. ; | |
349 | ||
c05d35e8 C |
350 | MalList |
351 | extend to-list ;; | |
224e09ed | 352 | extend sequential? drop mal-true ;; |
c05d35e8 C |
353 | extend conj { elem old-list -- list } |
354 | old-list MalList/count @ 1+ { new-count } | |
69972a83 C |
355 | new-count cells allocate throw { new-start } |
356 | elem new-start ! | |
357 | new-count 1 > if | |
c05d35e8 | 358 | old-list MalList/start @ new-start cell+ new-count 1- cells cmove |
69972a83 | 359 | endif |
224e09ed | 360 | new-start new-count MalList. ;; |
82e2b26b JM |
361 | extend seq |
362 | dup MalList/count @ 0= if | |
363 | drop mal-nil | |
364 | endif ;; | |
60801ed6 C |
365 | extend empty? MalList/count @ 0= mal-bool ;; |
366 | extend mal-count MalList/count @ MalInt. ;; | |
367 | extend mal= | |
6512bd80 C |
368 | over mal-nil = if |
369 | 2drop false | |
60801ed6 | 370 | else |
6512bd80 C |
371 | swap to-list dup 0= if |
372 | nip | |
60801ed6 | 373 | else |
6512bd80 C |
374 | 2dup MalList/count @ swap MalList/count @ over = if ( list-a list-b count ) |
375 | -rot MalList/start @ swap MalList/start @ { start-b start-a } | |
376 | true swap ( return-val count ) | |
377 | 0 ?do | |
378 | start-a i cells + @ | |
379 | start-b i cells + @ | |
380 | m= if else | |
381 | drop false leave | |
382 | endif | |
383 | loop | |
384 | else | |
385 | drop 2drop false | |
386 | endif | |
60801ed6 C |
387 | endif |
388 | endif ;; | |
69972a83 C |
389 | drop |
390 | ||
c05d35e8 | 391 | MalList new 0 over MalList/count ! constant MalList/Empty |
b745d191 | 392 | |
bf6a574e | 393 | : MalList/rest { list -- list } |
224e09ed C |
394 | list MalList/start @ cell+ |
395 | list MalList/count @ 1- | |
396 | MalList. ; | |
bf6a574e C |
397 | |
398 | ||
168fb5dc C |
399 | MalType% |
400 | cell% field MalVector/list | |
9da223a3 | 401 | deftype MalVector |
168fb5dc | 402 | |
69972a83 | 403 | MalVector |
224e09ed | 404 | extend sequential? drop mal-true ;; |
c05d35e8 | 405 | extend to-list |
c4403c17 | 406 | MalVector/list @ ;; |
60801ed6 C |
407 | extend empty? |
408 | MalVector/list @ | |
409 | MalList/count @ 0= mal-bool ;; | |
410 | extend mal-count | |
411 | MalVector/list @ | |
412 | MalList/count @ MalInt. ;; | |
c4403c17 C |
413 | extend mal= |
414 | MalVector/list @ swap m= ;; | |
224e09ed C |
415 | extend conj |
416 | MalVector/list @ { elem old-list } | |
417 | old-list MalList/count @ { old-count } | |
418 | old-count 1+ cells allocate throw { new-start } | |
419 | elem new-start old-count cells + ! | |
420 | old-list MalList/start @ new-start old-count cells cmove | |
421 | new-start old-count 1+ MalList. | |
422 | MalVector new swap | |
423 | over MalVector/list ! ;; | |
82e2b26b JM |
424 | extend seq |
425 | MalVector/list @ seq ;; | |
69972a83 C |
426 | drop |
427 | ||
2e78e94e C |
428 | MalType% |
429 | cell% field MalMap/list | |
9da223a3 C |
430 | deftype MalMap |
431 | ||
c05d35e8 | 432 | MalMap new MalList/Empty over MalMap/list ! constant MalMap/Empty |
9da223a3 | 433 | |
3a17cb96 C |
434 | : MalMap/get-addr ( k map -- addr-or-nil ) |
435 | MalMap/list @ | |
436 | dup MalList/start @ | |
437 | swap MalList/count @ { k start count } | |
a631063f C |
438 | true \ need to search? |
439 | k get-map-hint { hint-idx } | |
440 | hint-idx -1 <> if | |
441 | hint-idx count < if | |
442 | hint-idx cells start + { key-addr } | |
443 | key-addr @ k m= if | |
444 | key-addr cell+ | |
445 | nip false | |
446 | endif | |
3a17cb96 | 447 | endif |
a631063f C |
448 | endif |
449 | if \ search | |
450 | nil ( addr ) | |
451 | count cells start + start +do | |
452 | i @ k m= if | |
453 | drop i | |
454 | dup start - cell / k set-map-hint! | |
455 | cell+ leave | |
456 | endif | |
457 | [ 2 cells ] literal +loop | |
458 | endif ; | |
3a17cb96 | 459 | |
9da223a3 C |
460 | MalMap |
461 | extend conj ( kv map -- map ) | |
462 | MalMap/list @ \ get list | |
c05d35e8 C |
463 | over MalList/start @ cell+ @ swap conj \ add value |
464 | swap MalList/start @ @ swap conj \ add key | |
69972a83 | 465 | MalMap new dup -rot MalMap/list ! \ put back in map |
9da223a3 C |
466 | ;; |
467 | extend assoc ( k v map -- map ) | |
468 | MalMap/list @ \ get list | |
c05d35e8 | 469 | conj conj |
a631063f | 470 | MalMap new tuck MalMap/list ! \ put back in map |
9da223a3 | 471 | ;; |
224e09ed C |
472 | extend dissoc { k map -- map } |
473 | map MalMap/list @ | |
474 | dup MalList/start @ swap MalList/count @ { start count } | |
475 | map \ return original if key not found | |
476 | count 0 +do | |
477 | start i cells + @ k mal= if | |
478 | drop here | |
479 | start i MalList. , | |
480 | start i 2 + cells + count i - 2 - MalList. , | |
481 | here>MalList MalList/concat | |
482 | MalMap new dup -rot MalMap/list ! \ put back in map | |
483 | endif | |
484 | 2 +loop ;; | |
3a17cb96 C |
485 | extend get ( not-found k map -- value ) |
486 | MalMap/get-addr ( not-found addr-or-nil ) | |
487 | dup 0= if drop else nip @ endif ;; | |
60801ed6 C |
488 | extend empty? |
489 | MalMap/list @ | |
490 | MalList/count @ 0= mal-bool ;; | |
491 | extend mal-count | |
492 | MalMap/list @ | |
493 | MalList/count @ 2 / MalInt. ;; | |
2aff8547 DM |
494 | extend mal= { b a -- bool } |
495 | b mal-type @ MalMap = if | |
496 | a MalMap/list @ MalList/count @ { a-count } | |
497 | b MalMap/list @ MalList/count @ { b-count } | |
498 | a-count b-count = if | |
499 | a MalMap/list @ MalList/start @ { a-start } | |
500 | true ( return-val ) | |
501 | a-count 0 +do | |
502 | a-start i cells + @ ( return-val key ) | |
503 | dup a MalMap/get-addr swap b MalMap/get-addr ( return-val a-val-addr b-val-addr ) | |
504 | dup 0= if | |
505 | drop 2drop false leave | |
506 | else | |
507 | @ swap @ ( return-val b-val a-val ) | |
508 | m= if else | |
509 | drop false leave | |
510 | endif | |
511 | endif | |
512 | 2 +loop | |
513 | else | |
514 | false | |
515 | endif | |
516 | else | |
517 | false | |
518 | endif ;; | |
9da223a3 | 519 | drop |
2e78e94e | 520 | |
14b846ff C |
521 | \ Examples of extending existing protocol methods to existing type |
522 | MalDefault | |
14b846ff | 523 | extend conj ( obj this -- this ) |
50e417ff | 524 | nip ;; |
60801ed6 | 525 | extend to-list drop 0 ;; |
794bfca1 | 526 | extend empty? drop mal-true ;; |
224e09ed | 527 | extend sequential? drop mal-false ;; |
6512bd80 | 528 | extend mal= = ;; |
a631063f C |
529 | extend get-map-hint drop -1 ;; |
530 | extend set-map-hint! 2drop ;; | |
14b846ff C |
531 | drop |
532 | ||
533 | MalNil | |
c05d35e8 C |
534 | extend conj ( item nil -- mal-list ) |
535 | drop MalList/Empty conj ;; | |
82e2b26b | 536 | extend seq drop mal-nil ;; |
e46223c2 | 537 | extend as-native drop nil ;; |
b6607ac7 | 538 | extend get 2drop ;; |
224e09ed | 539 | extend to-list drop MalList/Empty ;; |
60801ed6 C |
540 | extend empty? drop mal-true ;; |
541 | extend mal-count drop 0 MalInt. ;; | |
542 | extend mal= drop mal-nil = ;; | |
9da223a3 C |
543 | drop |
544 | ||
59038a10 C |
545 | MalType% |
546 | cell% field MalSymbol/sym-addr | |
547 | cell% field MalSymbol/sym-len | |
a631063f | 548 | cell% field MalSymbol/map-hint |
9da223a3 | 549 | deftype MalSymbol |
59038a10 C |
550 | |
551 | : MalSymbol. { str-addr str-len -- mal-sym } | |
552 | MalSymbol new { sym } | |
553 | str-addr sym MalSymbol/sym-addr ! | |
3a17cb96 | 554 | str-len sym MalSymbol/sym-len ! |
a631063f | 555 | -1 sym MalSymbol/map-hint ! |
59038a10 | 556 | sym ; |
50e417ff | 557 | |
9da223a3 C |
558 | : unpack-sym ( mal-string -- addr len ) |
559 | dup MalSymbol/sym-addr @ | |
560 | swap MalSymbol/sym-len @ ; | |
561 | ||
562 | MalSymbol | |
563 | extend mal= ( other this -- bool ) | |
564 | over mal-type @ MalSymbol = if | |
565 | unpack-sym rot unpack-sym str= | |
566 | else | |
567 | 2drop 0 | |
568 | endif ;; | |
a631063f C |
569 | extend get-map-hint MalSymbol/map-hint @ ;; |
570 | extend set-map-hint! MalSymbol/map-hint ! ;; | |
e46223c2 C |
571 | extend as-native ( this ) |
572 | unpack-sym evaluate ;; | |
9da223a3 C |
573 | drop |
574 | ||
575 | MalType% | |
576 | cell% field MalKeyword/str-addr | |
577 | cell% field MalKeyword/str-len | |
578 | deftype MalKeyword | |
579 | ||
580 | : unpack-keyword ( mal-keyword -- addr len ) | |
581 | dup MalKeyword/str-addr @ | |
582 | swap MalKeyword/str-len @ ; | |
583 | ||
584 | MalKeyword | |
585 | extend mal= ( other this -- bool ) | |
586 | over mal-type @ MalKeyword = if | |
587 | unpack-keyword rot unpack-keyword str= | |
588 | else | |
589 | 2drop 0 | |
590 | endif ;; | |
591 | ' as-native ' unpack-keyword extend-method* | |
9da223a3 C |
592 | drop |
593 | ||
594 | : MalKeyword. { str-addr str-len -- mal-keyword } | |
595 | MalKeyword new { kw } | |
596 | str-addr kw MalKeyword/str-addr ! | |
597 | str-len kw MalKeyword/str-len ! | |
598 | kw ; | |
599 | ||
50e417ff C |
600 | MalType% |
601 | cell% field MalString/str-addr | |
602 | cell% field MalString/str-len | |
9da223a3 | 603 | deftype MalString |
50e417ff | 604 | |
580c4eef | 605 | : MalString.0 { str-addr str-len -- mal-str } |
50e417ff C |
606 | MalString new { str } |
607 | str-addr str MalString/str-addr ! | |
608 | str-len str MalString/str-len ! | |
609 | str ; | |
580c4eef | 610 | ' MalString.0 is MalString. |
9da223a3 C |
611 | |
612 | : unpack-str ( mal-string -- addr len ) | |
613 | dup MalString/str-addr @ | |
614 | swap MalString/str-len @ ; | |
615 | ||
616 | MalString | |
617 | extend mal= ( other this -- bool ) | |
618 | over mal-type @ MalString = if | |
619 | unpack-str rot unpack-str str= | |
620 | else | |
621 | 2drop 0 | |
622 | endif ;; | |
623 | ' as-native ' unpack-str extend-method* | |
82e2b26b JM |
624 | extend seq { str } |
625 | str MalString/str-len @ { len } | |
626 | len 0= if | |
627 | mal-nil | |
628 | else | |
629 | len cells allocate throw { list-start } | |
630 | len 0 ?do | |
631 | str MalString/str-addr @ i + 1 MalString. ( new-char-string ) | |
632 | list-start i cells + ! | |
633 | loop | |
634 | list-start len MalList. | |
635 | endif ;; | |
9da223a3 C |
636 | drop |
637 | ||
638 | ||
639 | MalType% | |
136ce7c9 | 640 | cell% field MalNativeFn/xt |
136ce7c9 C |
641 | deftype MalNativeFn |
642 | ||
643 | : MalNativeFn. { xt -- mal-fn } | |
644 | MalNativeFn new { mal-fn } | |
645 | xt mal-fn MalNativeFn/xt ! | |
9da223a3 C |
646 | mal-fn ; |
647 | ||
69972a83 | 648 | |
136ce7c9 | 649 | MalType% |
e82947d0 | 650 | cell% field MalUserFn/is-macro? |
136ce7c9 C |
651 | cell% field MalUserFn/env |
652 | cell% field MalUserFn/formal-args | |
653 | cell% field MalUserFn/var-arg | |
654 | cell% field MalUserFn/body | |
655 | deftype MalUserFn | |
656 | ||
657 | ||
69972a83 C |
658 | MalType% |
659 | cell% field SpecialOp/xt | |
660 | deftype SpecialOp | |
661 | ||
662 | : SpecialOp. | |
663 | SpecialOp new swap over SpecialOp/xt ! ; | |
224e09ed C |
664 | |
665 | MalType% | |
666 | cell% field Atom/val | |
667 | deftype Atom | |
668 | ||
669 | : Atom. Atom new swap over Atom/val ! ; |