DISABLE FDs (REMOVE ME).
[jackhill/mal.git] / bbc-basic / types.bas
CommitLineData
49c172c0 1REM > types library for mal in BBC BASIC
ca23e632
BH
2
3REM This library should be the only thing that understands the
4REM implementation of mal data types in BBC BASIC. All other
5REM code should use routines in this library to access them.
6
7REM As far as other code is concerned, a mal object is just an
8REM opaque 32-bit integer, which might be a pointer, or might not.
9
94b7a079
BH
10REM All mal objects live in an array, Z%(), with string values held
11REM in a parallel array, Z$(). There's one row in Z%(), and one
12REM entry in Z$(), for each mal object.
2ec0dbee 13
ec8336b0 14REM Z%(x,0) holds the type of an object and other small amounts of
94b7a079 15REM information. The bottom bit indicates the semantics of Z%(x,1):
ec8336b0
BH
16
17REM &01 : Z%(x,1) is a pointer into Z%()
4fbd9d0f
BH
18
19REM Z%(x,2) and Z%(x,3) are always pointers into Z%(), to 'nil' if nothing
20REM else.
7f6d61fc 21
2e3de60f
BH
22REM The &40 bit is used to distinguish empty lists, vectors and hash-maps.
23REM The &80 bit distinguishes vectors from lists and macros from functions.
24
7f6d61fc
BH
25REM sS%() is a shadow stack, used to keep track of which mal values might
26REM be referenced from local variables at a given depth of the BASIC call
27REM stack. It grows upwards. sSP% points to the first unused word. sFP%
28REM points to the start of the current shadow stack frame. The first word
29REM of each shadow stack frame is the saved value of sFP%. The rest are
30REM mal values.
6d1a36e8
BH
31
32REM Types are:
ec8336b0 33REM &00 nil
4fbd9d0f
BH
34REM &04 boolean
35REM &08 integer
36REM &0C core function
ec8336b0 37REM &01 atom
4fbd9d0f
BH
38REM &05 free block
39REM &09 list/vector (each object is a cons cell)
40REM &0D environment
41REM &11 hash-map internal node
42REM &15 mal function (first part)
43REM &19 mal function (second part)
44REM &02 string/keyword
45REM &06 symbol
90f6b7a2 46REM &0A hash-map leaf node
6d1a36e8
BH
47
48REM Formats of individual objects are defined below.
ca23e632
BH
49
50DEF PROCtypes_init
b0d6aa71
BH
51 REM Mal's heap has to be statically dimensioned, but we also
52 REM need to leave enough space for BASIC's stack and heap.
53 REM The BASIC heap is where all strings live.
54 REM
55 REM Each row of Z%() consumes 16 bytes. The size of each entry
56 REM in Z$() varies by platform: 5 bytes in ARM BBC BASIC V,
57 REM 8 bytes in Brandy on a 32-bit system, 16 bytes in Brandy on
58 REM a 64-bit system.
59
022d4cb9 60 DIM Z%((HIMEM-LOMEM)/110,3), Z$((HIMEM-LOMEM)/110)
7f6d61fc 61 DIM sS%((HIMEM-LOMEM)/64)
b0d6aa71 62
4fbd9d0f
BH
63 Z%(1,0) = &04 : REM false
64 Z%(2,0) = &04 : Z%(2,1) = TRUE : REM true
2e3de60f
BH
65 Z%(3,0) = &49 : Z%(3,1) = 3 : REM empty list
66 Z%(4,0) = &C9 : Z%(4,1) = 4 : REM empty vector
67 Z%(5,0) = &51 : REM empty hashmap
4b811acc 68 next_Z% = 6
7f6d61fc
BH
69 sSP% = 1
70 sFP% = 0
7b6e74a6 71 F% = 0
ca23e632
BH
72ENDPROC
73
74DEF FNtype_of(val%)
2e3de60f 75=Z%(val%,0) AND &1F
ca23e632 76
7f6d61fc 77DEF PROCgc_enter
5411931a 78 REM PRINT ;sFP%;
7f6d61fc
BH
79 sS%(sSP%) = sFP%
80 sFP% = sSP%
81 sSP% += 1
5411931a 82 REM PRINT " >>> ";sFP%
7f6d61fc 83ENDPROC
a6b84652 84
1610afd2
BH
85REM FNgc_save is equivalent to PROCgc_enter except that it returns a
86REM value that can be passed to PROCgc_restore to pop all the stack
87REM frames back to (and including) the one pushed by FNgc_save.
7b6e74a6 88DEF FNgc_save
1610afd2 89 PROCgc_enter
7b6e74a6
BH
90=sFP%
91
7f6d61fc 92DEF PROCgc_exit
5411931a 93 REM PRINT ;sS%(sFP%);" <<< ";sFP%
7f6d61fc
BH
94 sSP% = sFP%
95 sFP% = sS%(sFP%)
a6b84652
BH
96ENDPROC
97
7b6e74a6
BH
98DEF PROCgc_restore(oldFP%)
99 sFP% = oldFP%
1610afd2
BH
100 REM PRINT "!!! FP reset"
101 PROCgc_exit
102ENDPROC
7b6e74a6 103
7f6d61fc
BH
104DEF FNref_local(val%)
105 sS%(sSP%) = val%
106 sSP% += 1
107=val%
108
109DEF FNgc_exit(val%)
110 PROCgc_exit
1610afd2
BH
111=FNref_local(val%)
112
113DEF FNgc_restore(oldFP%, val%)
114 PROCgc_restore(oldFP%)
115=FNref_local(val%)
7b6e74a6 116
d9dcadde
BH
117DEF PROCgc_keep_only2(val1%, val2%)
118 PROCgc_exit
119 PROCgc_enter
120 val1% = FNref_local(val1%)
121 val2% = FNref_local(val2%)
122ENDPROC
123
7b6e74a6 124DEF FNmalloc(type%)
15119738 125 LOCAL val%
90d169ce 126 REM If the heap is full, collect garbage first.
d510574d
BH
127 IF F% = 0 AND next_Z% > DIM(Z%(),1) THEN
128 PROCgc
129 IF F% = 0 ERROR &40E80950, "Out of mal heap memory"
130 ENDIF
7b6e74a6
BH
131 IF F% <> 0 THEN
132 val% = F%
133 F% = Z%(val%,1)
134 ELSE
135 val% = next_Z%
136 next_Z% += 1
137 ENDIF
a1767f63 138 Z%(val%,0) = type%
7f6d61fc 139=FNref_local(val%)
15119738 140
7b6e74a6 141DEF PROCfree(val%)
4fbd9d0f 142 Z%(val%,0) = &05
7b6e74a6
BH
143 Z%(val%,1) = F%
144 Z%(val%,2) = 0
145 Z%(val%,3) = 0
94b7a079 146 Z$(val%) = ""
7b6e74a6
BH
147 F% = val%
148ENDPROC
149
150DEF PROCgc
5411931a 151 REM PRINT "** START GC **"
7b6e74a6
BH
152 PROCgc_markall
153 PROCgc_sweep
5411931a 154 REM PRINT "** FINISH GC **"
7b6e74a6
BH
155ENDPROC
156
157DEF PROCgc_markall
158 LOCAL sp%, fp%
159 fp% = sFP%
5411931a 160 REM PRINT ">>marking...";
7b6e74a6
BH
161 FOR sp% = sSP% - 1 TO 0 STEP -1
162 IF sp% = fp% THEN
163 fp% = sS%(sp%)
5411931a 164 REM PRINT " / ";
7b6e74a6
BH
165 ELSE PROCgc_mark(sS%(sp%))
166 ENDIF
167 NEXT sp%
5411931a 168 REM PRINT
7b6e74a6
BH
169ENDPROC
170
171DEF PROCgc_mark(val%)
a1767f63 172 IF (Z%(val%,0) AND &100) = 0 THEN
5411931a 173 REM PRINT " ";val%;
a1767f63 174 Z%(val%,0) += &100
ec8336b0 175 IF (Z%(val%,0) AND &01) THEN PROCgc_mark(Z%(val%,1))
4fbd9d0f 176 PROCgc_mark(Z%(val%,2))
33368392 177 PROCgc_mark(Z%(val%,3))
7b6e74a6
BH
178 ENDIF
179ENDPROC
180
181DEF PROCgc_sweep
182 LOCAL val%
5411931a 183 REM PRINT ">>sweeping ...";
7b6e74a6 184 FOR val% = 6 TO next_Z% - 1
4fbd9d0f 185 IF FNtype_of(val%) <> &05 AND (Z%(val%,0) AND &100) = 0 THEN
5411931a 186 REM PRINT " ";val%;
7b6e74a6 187 PROCfree(val%)
a1767f63
BH
188 ELSE
189 Z%(val%,0) -= &100
7b6e74a6
BH
190 ENDIF
191 NEXT val%
5411931a 192 REM PRINT
7b6e74a6
BH
193ENDPROC
194
33368392
BH
195DEF FNmeta(val%)
196=Z%(val%,3)
197
198DEF FNwith_meta(val%, meta%)
199 LOCAL newval%
200 newval% = FNmalloc(Z%(val%,0))
201 Z%(newval%,1) = Z%(val%,1)
202 Z%(newval%,2) = Z%(val%,2)
203 Z%(newval%,3) = meta%
30409c3d 204 Z$(newval%) = Z$(val%)
33368392
BH
205=newval%
206
ca23e632
BH
207REM ** Nil **
208
c32c31b3
BH
209DEF FNis_nil(val%)
210=FNtype_of(val%) = 0
211
ca23e632
BH
212DEF FNnil
213=0
214
3ab6b58b
BH
215REM ** Boolean **
216
604e6260 217REM Z%(x,1) = TRUE or FALSE
6d1a36e8 218
3ab6b58b 219DEF FNis_boolean(val%)
4fbd9d0f 220=FNtype_of(val%) = &04
3ab6b58b
BH
221
222DEF FNalloc_boolean(bval%)
4b811acc
BH
223 IF bval% THEN =2
224=1
3ab6b58b
BH
225
226DEF FNunbox_boolean(val%)
9809aa65 227 IF NOT FNis_boolean(val%) THEN ERROR &40E80911, "Not a boolean"
604e6260 228=Z%(val%,1)
3ab6b58b 229
b4033eb7
BH
230DEF FNis_truish(val%)
231 IF FNis_nil(val%) THEN =FALSE
604e6260 232 IF FNis_boolean(val%) THEN =FNunbox_boolean(val%)
b4033eb7
BH
233=TRUE
234
ca23e632
BH
235REM ** Integers **
236
6d1a36e8
BH
237REM Z%(x,1) = integer value
238
ca23e632 239DEF FNis_int(val%)
4fbd9d0f 240=FNtype_of(val%) = &08
ca23e632
BH
241
242DEF FNalloc_int(ival%)
243 LOCAL val%
4fbd9d0f 244 val% = FNmalloc(&08)
4b811acc 245 Z%(val%,1) = ival%
ca23e632
BH
246=val%
247
248DEF FNunbox_int(val%)
9809aa65 249 IF NOT FNis_int(val%) THEN ERROR &40E80912, "Not an integer"
4b811acc 250=Z%(val%,1)
ca23e632 251
bc27a6ad
BH
252REM ** Strings and keywords **
253
94b7a079
BH
254REM Z$(x) is the string value
255REM Z%(x,2) points to the next part of the string
bc27a6ad 256REM A keyword is a string with first character CHR$(127).
68f0184e
BH
257
258DEF FNis_string(val%)
4fbd9d0f 259=FNtype_of(val%) = &02
68f0184e
BH
260
261DEF FNalloc_string(sval$)
262 LOCAL val%
4fbd9d0f 263 val% = FNmalloc(&02)
94b7a079 264 Z$(val%) = sval$
68f0184e
BH
265=val%
266
68f0184e
BH
267DEF FNunbox_string(val%)
268 IF NOT FNis_string(val%) THEN ERROR &40E80914, "Not a string"
94b7a079
BH
269 IF NOT FNis_nil(Z%(val%,2)) ERROR &40E80914, "Cannot unbox a long string"
270=Z$(val%)
68f0184e 271
e55d7a2d
BH
272DEF FNstring_append(val%, add$)
273 LOCAL newval%
0f97a00d 274 IF NOT FNis_string(val%) THEN ERROR &40E80914, "Not a string"
e55d7a2d
BH
275 newval% = FNalloc_string(Z$(val%))
276 IF FNis_nil(Z%(val%,2)) THEN
277 IF LEN(Z$(newval%)) + LEN(add$) <= 255 THEN
278 Z$(newval%) += add$
279 ELSE
280 Z%(newval%,2) = FNalloc_string(add$)
281 ENDIF
0f97a00d 282 ELSE
e55d7a2d 283 Z%(newval%,2) = FNstring_append(Z%(val%,2), add$)
0f97a00d 284 ENDIF
e55d7a2d 285=newval%
0f97a00d 286
e55d7a2d 287DEF FNstring_concat(val%, add%)
869a03e4 288 LOCAL newval%
0f97a00d
BH
289 IF NOT FNis_string(val%) THEN ERROR &40E80914, "Not a string"
290 IF NOT FNis_string(add%) THEN ERROR &40E80914, "Not a string"
869a03e4
BH
291 newval% = FNalloc_string(Z$(val%))
292 IF FNis_nil(Z%(val%,2)) THEN
293 IF LEN(Z$(newval%)) + LEN(Z$(add%)) <= 255 THEN
294 Z$(newval%) += Z$(add%)
295 Z%(newval%,2) = Z%(add%,2)
296 ELSE
297 Z%(newval%,2) = add%
298 ENDIF
299 ELSE
300 Z%(newval%,2) = FNstring_concat(Z%(val%,2), add%)
301 ENDIF
302=newval%
0f97a00d
BH
303
304DEF FNstring_len(val%)
94b7a079
BH
305 LOCAL len%
306 WHILE NOT FNis_nil(val%)
307 len% += LEN(Z$(val%))
308 val% = Z%(val%,2)
0f97a00d
BH
309 ENDWHILE
310=len%
311
312DEF FNstring_chr(val%, pos%)
94b7a079
BH
313 WHILE pos% > LEN(Z$(val%))
314 pos% -= LEN(Z$(val%))
315 val% = Z%(val%,2)
316 IF FNis_nil(val%) THEN =""
0f97a00d 317 ENDWHILE
94b7a079 318=MID$(Z$(val%), pos%, 1)
0f97a00d 319
ca23e632
BH
320REM ** Symbols **
321
94b7a079 322REM Z$(x) = value of the symbol
6d1a36e8 323
ca23e632 324DEF FNis_symbol(val%)
4fbd9d0f 325=FNtype_of(val%) = &06
ca23e632
BH
326
327DEF FNalloc_symbol(sval$)
f1e3f09f 328 LOCAL val%
4fbd9d0f 329 val% = FNmalloc(&06)
94b7a079 330 Z$(val%) = sval$
ca23e632
BH
331=val%
332
333DEF FNunbox_symbol(val%)
9809aa65 334 IF NOT FNis_symbol(val%) THEN ERROR &40E80915, "Not a symbol"
94b7a079 335=Z$(val%)
ca23e632 336
07f3522f 337REM ** Lists and vectors **
ca23e632 338
07f3522f
BH
339REM Lists and vectors are both represented as linked lists: the only
340REM difference is in the state of the is_vector flag in the head cell
341REM of the list. Note that this means that the tail of a list may be
342REM a vector, and vice versa. FNas_list and FNas_vector can be used
343REM to convert a sequence to a particular type as necessary.
344
345REM Z%(x,0) AND &80 = is_vector flag
6d1a36e8
BH
346REM Z%(x,1) = index in Z%() of next pair
347REM Z%(x,2) = index in Z%() of first element
348
9e1b7a8f
BH
349REM The empty list is a distinguished value, with elements that match
350REM the spec of 'first' and 'rest'.
6d1a36e8 351
ca23e632 352DEF FNempty
4b811acc 353=3
ca23e632 354
07f3522f
BH
355DEF FNempty_vector
356=4
357
ca23e632
BH
358DEF FNalloc_pair(car%, cdr%)
359 LOCAL val%
4fbd9d0f 360 val% = FNmalloc(&09)
7f6d61fc
BH
361 Z%(val%,2) = car%
362 Z%(val%,1) = cdr%
363=val%
a6b84652 364
07f3522f
BH
365DEF FNalloc_vector_pair(car%, cdr%)
366 LOCAL val%
367 val% = FNalloc_pair(car%, cdr%)
9152704f 368 Z%(val%,0) = Z%(val%,0) OR &80
07f3522f
BH
369=val%
370
ca23e632 371DEF FNis_empty(val%)
2e3de60f 372=(Z%(val%,0) AND &40) = &40
ca23e632 373
9152704f 374DEF FNis_seq(val%)
4fbd9d0f 375=FNtype_of(val%) = &09
ca23e632 376
9152704f 377DEF FNis_list(val%)
4fbd9d0f 378=FNtype_of(val%) = &09 AND (Z%(val%, 0) AND &80) = &00
9152704f 379
07f3522f 380DEF FNis_vector(val%)
4fbd9d0f 381=FNtype_of(val%) = &09 AND (Z%(val%, 0) AND &80) = &80
07f3522f
BH
382
383DEF FNas_list(val%)
9152704f 384 IF FNis_list(val%) THEN =val%
07f3522f 385 IF FNis_empty(val%) THEN =FNempty
f14770fc 386=FNalloc_pair(FNfirst(val%), FNrest(val%))
07f3522f
BH
387
388DEF FNas_vector(val%)
ec8336b0 389 IF FNis_vector(val%) THEN =val%
07f3522f 390 IF FNis_empty(val%) THEN =FNempty_vector
f14770fc 391=FNalloc_vector_pair(FNfirst(val%), FNrest(val%))
07f3522f 392
f14770fc 393DEF FNfirst(val%)
9152704f 394 IF NOT FNis_seq(val%) THEN ERROR &40E80916, "Can't get car of non-sequence"
7f6d61fc 395=FNref_local(Z%(val%,2))
ca23e632 396
f14770fc 397DEF FNrest(val%)
9152704f 398 IF NOT FNis_seq(val%) THEN ERROR &40E80916, "Can't get cdr of non-sequence"
7f6d61fc 399=FNref_local(Z%(val%,1))
c2d58701 400
86f8c24f
BH
401DEF FNalloc_list2(val0%, val1%)
402 =FNalloc_pair(val0%, FNalloc_pair(val1%, FNempty))
403
404DEF FNalloc_list3(val0%, val1%, val2%)
405 =FNalloc_pair(val0%, FNalloc_pair(val1%, FNalloc_pair(val2%, FNempty)))
406
f14770fc 407DEF FNcount(val%)
717da462
BH
408 LOCAL i%
409 WHILE NOT FNis_empty(val%)
f14770fc 410 val% = FNrest(val%)
717da462
BH
411 i% += 1
412 ENDWHILE
413= i%
414
f14770fc 415DEF FNnth(val%, n%)
1588b9d4 416 WHILE n% > 0
59c39631 417 IF FNis_empty(val%) THEN ERROR &40E80923, "Subscript out of range"
f14770fc 418 val% = FNrest(val%)
59c39631
BH
419 n% -= 1
420 ENDWHILE
82805c27 421 IF FNis_empty(val%) THEN ERROR &40E80923, "Subscript out of range"
f14770fc 422=FNfirst(val%)
59c39631 423
717da462
BH
424REM ** Core functions **
425
6d1a36e8
BH
426REM Z%(x,1) = index of function in FNcore_call
427
717da462 428DEF FNis_corefn(val%)
4fbd9d0f 429=FNtype_of(val%) = &0C
717da462
BH
430
431DEF FNalloc_corefn(fn%)
432 LOCAL val%
4fbd9d0f 433 val% = FNmalloc(&0C)
4b811acc 434 Z%(val%,1) = fn%
717da462
BH
435=val%
436
437DEF FNunbox_corefn(val%)
9809aa65 438 IF NOT FNis_corefn(val%) THEN ERROR &40E80919, "Not a core function"
4b811acc 439=Z%(val%,1)
717da462 440
6d1a36e8
BH
441REM ** Hash-maps **
442
f046cfa6
BH
443REM Hash-maps are represented as a crit-bit tree.
444
90f6b7a2
BH
445REM An internal node has:
446REM Z%(x,0) >> 16 = next bit of key to check
447REM Z%(x,1) = index in Z%() of left child (if next bit of key is 0)
448REM Z%(x,2) = index in Z%() of right child (if next bit of key is 1)
449
450REM A leaf node has
94b7a079 451REM Z$(x) = key
ec8336b0 452REM Z%(x,2) = index in Z%() of value
c2d58701 453
90f6b7a2 454REM The empty hash-map is a special value containing no data.
c2d58701
BH
455
456DEF FNempty_hashmap
4b811acc 457=5
c2d58701 458
90f6b7a2 459DEF FNhashmap_alloc_leaf(key$, val%)
c2d58701 460 LOCAL entry%
90f6b7a2 461 entry% = FNmalloc(&0A)
94b7a079 462 Z$(entry%) = key$
ec8336b0 463 Z%(entry%,2) = val%
90f6b7a2 464=entry%
c2d58701 465
c592ecd1
BH
466DEF FNhashmap_alloc_node(bit%, left%, right%)
467 LOCAL entry%
4fbd9d0f 468 entry% = FNmalloc(&11)
c592ecd1
BH
469 Z%(entry%,0) += (bit% << 16)
470 Z%(entry%,1) = left%
471 Z%(entry%,2) = right%
472=entry%
473
c2d58701 474DEF FNis_hashmap(val%)
90f6b7a2
BH
475 LOCAL t%
476 t% = FNtype_of(val%)
2e3de60f 477=t% = &11 OR t% = &0A
90f6b7a2 478
c592ecd1
BH
479DEF FNkey_bit(key$, bit%)
480 LOCAL cnum%
481 cnum% = bit% >> 3
482 IF cnum% >= LEN(key$) THEN =FALSE
c96b3a5b 483=ASC(MID$(key$, cnum% + 1, 1)) AND (&80 >> (bit% AND 7))
c592ecd1
BH
484
485DEF FNkey_bitdiff(key1$, key2$)
486 LOCAL bit%
487 WHILE FNkey_bit(key1$, bit%) = FNkey_bit(key2$, bit%)
488 bit% += 1
489 ENDWHILE
490=bit%
491
90f6b7a2 492DEF FNhashmap_set(map%, key$, val%)
c96b3a5b 493 LOCAL bit%, nearest%
2e3de60f 494 IF FNis_empty(map%) THEN =FNhashmap_alloc_leaf(key$, val%)
c96b3a5b 495 nearest% = FNhashmap_find(map%, key$)
94b7a079
BH
496 IF Z$(nearest%) = key$ THEN =FNhashmap_replace(map%, key$, val%)
497 bit% = FNkey_bitdiff(key$, Z$(nearest%))
c96b3a5b
BH
498=FNhashmap_insert(map%, bit%, key$, val%)
499
500DEF FNhashmap_insert(map%, bit%, key$, val%)
501 LOCAL left%, right%
502 IF FNtype_of(map%) = &11 AND (Z%(map%,0) >> 16) < bit% THEN
503 IF FNkey_bit(key$, Z%(map%,0) >> 16) THEN
504 left% = Z%(map%,1)
505 right% = FNhashmap_insert(Z%(map%,2), bit%, key$, val%)
c592ecd1 506 ELSE
c96b3a5b
BH
507 left% = FNhashmap_insert(Z%(map%,1), bit%, key$, val%)
508 right% = Z%(map%,2)
c592ecd1 509 ENDIF
c96b3a5b
BH
510 =FNhashmap_alloc_node(Z%(map%,0)>>16, left%, right%)
511 ENDIF
512 IF FNkey_bit(key$, bit%) THEN
513 left% = map%
514 right% = FNhashmap_alloc_leaf(key$, val%)
515 ELSE
516 left% = FNhashmap_alloc_leaf(key$, val%)
517 right% = map%
c592ecd1 518 ENDIF
c96b3a5b
BH
519=FNhashmap_alloc_node(bit%, left%, right%)
520
521
522REM Replace a known-present key in a non-empty hashmap.
523DEF FNhashmap_replace(map%, key$, val%)
524 LOCAL left%, right%
525 IF FNtype_of(map%) = &0A THEN =FNhashmap_alloc_leaf(key$, val%)
c592ecd1 526 IF FNkey_bit(key$, Z%(map%,0) >> 16) THEN
c96b3a5b
BH
527 left% = Z%(map%,1)
528 right% = FNhashmap_replace(Z%(map%,2), key$, val%)
c592ecd1 529 ELSE
c96b3a5b
BH
530 left% = FNhashmap_replace(Z%(map%,1), key$, val%)
531 right% = Z%(map%,2)
c592ecd1 532 ENDIF
c96b3a5b 533=FNhashmap_alloc_node(Z%(map%,0)>>16, left%, right%)
129c2ac6 534
11454e72
BH
535DEF FNhashmap_remove(map%, key$)
536 LOCAL child%
2e3de60f 537 IF FNis_empty(map%) THEN =map%
11454e72 538 IF FNtype_of(map%) = &0A THEN
94b7a079 539 IF Z$(map%) = key$ THEN =FNempty_hashmap
11454e72
BH
540 ENDIF
541 IF FNkey_bit(key$, Z%(map%,0) >> 16) THEN
542 child% = FNhashmap_remove(Z%(map%,2), key$)
2e3de60f 543 IF FNis_empty(child%) THEN =Z%(map%,1)
11454e72
BH
544 =FNhashmap_alloc_node(Z%(map%,0)>>16, Z%(map%,1), child%)
545 ELSE
546 child% = FNhashmap_remove(Z%(map%,1), key$)
2e3de60f 547 IF FNis_empty(child%) THEN =Z%(map%,2)
11454e72
BH
548 =FNhashmap_alloc_node(Z%(map%,0)>>16, child%, Z%(map%,2))
549 ENDIF
550
40999104
BH
551REM FNhashmap_find finds the nearest entry in a non-empty hash-map to
552REM the key requested, and returns the entire entry.
553DEF FNhashmap_find(map%, key$)
554 WHILE FNtype_of(map%) = &11
555 IF FNkey_bit(key$, Z%(map%,0) >> 16) THEN map% = Z%(map%,2) ELSE map% = Z%(map%,1)
556 ENDWHILE
557=map%
11454e72 558
c2d58701 559DEF FNhashmap_get(map%, key$)
9809aa65 560 IF NOT FNis_hashmap(map%) THEN ERROR &40E80918, "Can't get item from a non-hashmap"
2e3de60f 561 IF FNis_empty(map%) THEN =FNnil
40999104 562 map% = FNhashmap_find(map%, key$)
94b7a079 563IF Z$(map%) = key$ THEN =FNref_local(Z%(map%,2)) ELSE =FNnil
dbe45187 564
61df4dc6
BH
565DEF FNhashmap_contains(map%, key$)
566 IF NOT FNis_hashmap(map%) THEN ERROR &40E80918, "Can't get item from a non-hashmap"
2e3de60f 567 IF FNis_empty(map%) THEN =FALSE
40999104 568 map% = FNhashmap_find(map%, key$)
94b7a079 569=Z$(map%) = key$
61df4dc6 570
90f6b7a2 571DEF FNhashmap_keys(map%)
c592ecd1
BH
572=FNhashmap_keys1(map%, FNempty)
573
574DEF FNhashmap_keys1(map%, acc%)
2e3de60f 575 IF FNis_empty(map%) THEN =acc%
c592ecd1 576 IF FNtype_of(map%) = &0A THEN
94b7a079 577 =FNalloc_pair(FNalloc_string(Z$(map%)), acc%)
c592ecd1 578 ENDIF
c96b3a5b 579=FNhashmap_keys1(Z%(map%,1), FNhashmap_keys1(Z%(map%,2), acc%))
c592ecd1 580
11454e72
BH
581DEF FNhashmap_vals(map%)
582=FNhashmap_vals1(map%, FNempty)
583
584DEF FNhashmap_vals1(map%, acc%)
2e3de60f 585 IF FNis_empty(map%) THEN =acc%
11454e72
BH
586 IF FNtype_of(map%) = &0A THEN
587 =FNalloc_pair(Z%(map%,2), acc%)
588 ENDIF
c96b3a5b 589=FNhashmap_vals1(Z%(map%,1), FNhashmap_vals1(Z%(map%,2), acc%))
11454e72 590
c592ecd1 591DEF PROChashmap_dump(map%)
2e3de60f 592 IF FNis_empty(map%) THEN
c592ecd1
BH
593 PRINT "[empty]"
594 ELSE
595 PRINT "[-----]"
596 PROChashmap_dump_internal(map%, "")
597 ENDIF
598ENDPROC
599
600DEF PROChashmap_dump_internal(map%, prefix$)
94b7a079 601 IF FNtype_of(map%) = &0A PRINT prefix$;Z$(map%)
4fbd9d0f 602 IF FNtype_of(map%) = &11 THEN
c592ecd1
BH
603 PRINT prefix$;"<";Z%(map%,0) >> 16;">"
604 PROChashmap_dump_internal(Z%(map%,1), prefix$ + "L ")
605 PROChashmap_dump_internal(Z%(map%,2), prefix$ + "R ")
606 ENDIF
607ENDPROC
b6e4898c 608
1204264c
BH
609REM ** Functions **
610
8db9135b 611REM A function is represented by two cells:
24951719 612REM Z%(x,0) AND &80 = is_macro flag
6d1a36e8 613REM Z%(x,1) = index in Z%() of ast
8db9135b
BH
614REM Z%(x,2) = y
615
616REM Z%(y,1) = index in Z%() of params
617REM Z%(y,2) = index in Z%() of env
6d1a36e8 618
1204264c 619DEF FNis_fn(val%)
4fbd9d0f 620=FNtype_of(val%) = &15
1204264c 621
24951719 622DEF FNis_nonmacro_fn(val%)
4fbd9d0f 623=FNtype_of(val%) = &15 AND (Z%(val%, 0) AND &80) = &00
24951719
BH
624
625DEF FNis_macro(val%)
4fbd9d0f 626=FNtype_of(val%) = &15 AND (Z%(val%, 0) AND &80) = &80
24951719 627
9462d98d 628DEF FNalloc_fn(ast%, params%, env%)
8db9135b 629 LOCAL val1%, val2%
4fbd9d0f 630 val1% = FNmalloc(&15)
8db9135b 631 Z%(val1%,1) = ast%
4fbd9d0f 632 val2% = FNmalloc(&19)
8db9135b
BH
633 Z%(val1%,2) = val2%
634 Z%(val2%,1) = params%
635 Z%(val2%,2) = env%
636=val1%
1204264c 637
90d90dfd 638DEF FNas_macro(val%)
24951719 639 IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function"
90d90dfd
BH
640 LOCAL newval%
641 newval% = FNmalloc(Z%(val%,0) OR &80)
642 Z%(newval%,1) = Z%(val%,1)
643 Z%(newval%,2) = Z%(val%,2)
644 Z%(newval%,3) = Z%(val%,3)
645=newval%
24951719 646
9462d98d 647DEF FNfn_ast(val%)
1204264c 648 IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function"
7f6d61fc 649=FNref_local(Z%(val%,1))
1204264c 650
9462d98d 651DEF FNfn_params(val%)
1204264c 652 IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function"
8db9135b 653=FNref_local(Z%(Z%(val%,2),1))
1204264c
BH
654
655DEF FNfn_env(val%)
656 IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function"
8db9135b 657=FNref_local(Z%(Z%(val%,2),2))
1204264c 658
940092c6
BH
659REM ** Atoms **
660
661REM Z%(x,1) = index in Z% of current referent
662
663DEF FNis_atom(val%)
ec8336b0 664=FNtype_of(val%) = &01
940092c6
BH
665
666DEF FNalloc_atom(contents%)
667 LOCAL val%
ec8336b0 668 val% = FNmalloc(&01)
940092c6
BH
669 Z%(val%,1) = contents%
670=val%
671
940092c6
BH
672DEF FNatom_deref(val%)
673=FNref_local(Z%(val%,1))
674
675DEF PROCatom_reset(val%, contents%)
676 Z%(val%,1) = contents%
677ENDPROC
678
dbe45187
BH
679REM ** Environments **
680
6d1a36e8
BH
681REM Z%(x,1) = index in Z% of hash-map
682REM Z%(x,2) = index in Z% of outer environment
683
dbe45187 684DEF FNis_environment(val%)
4fbd9d0f 685=FNtype_of(val%) = &0D
dbe45187
BH
686
687DEF FNalloc_environment(outer%)
688 LOCAL val%
4fbd9d0f 689 val% = FNmalloc(&0D)
4b811acc
BH
690 Z%(val%,1) = FNempty_hashmap
691 Z%(val%,2) = outer%
dbe45187
BH
692=val%
693
694DEF FNenvironment_data(val%)
695 IF NOT FNis_environment(val%) THEN ERROR &40E8091D, "Not an environment"
7f6d61fc 696=FNref_local(Z%(val%,1))
dbe45187
BH
697
698DEF PROCenvironment_set_data(val%, data%)
699 IF NOT FNis_environment(val%) THEN ERROR &40E8091D, "Not an environment"
4b811acc 700 Z%(val%,1) = data%
dbe45187
BH
701ENDPROC
702
703DEF FNenvironment_outer(val%)
704 IF NOT FNis_environment(val%) THEN ERROR &40E8091D, "Not an environment"
7f6d61fc 705=FNref_local(Z%(val%,2))
dd3d5ad7
BH
706
707REM Local Variables:
708REM indent-tabs-mode: nil
709REM End: