HCoop Git - jackhill/mal.git/blob

1 REM > types library for mal in BBC BASIC

3 REM This library should be the only thing that understands the

4 REM implementation of mal data types in BBC BASIC. All other

5 REM code should use routines in this library to access them.

7 REM As far as other code is concerned, a mal object is just an

8 REM opaque 32-bit integer, which might be a pointer, or might not.

10 REM All mal objects live in an array, Z%(), with string values held

11 REM in a parallel array, Z$(). There's one row in Z%(), and one

12 REM entry in Z$(), for each mal object.

14 REM Z%(x,0) holds the type of an object and other small amounts of

15 REM information. The bottom bit indicates the semantics of Z%(x,1):

17 REM &01 : Z%(x,1) is a pointer into Z%()

19 REM Z%(x,2) and Z%(x,3) are always pointers into Z%(), to 'nil' if nothing

20 REM else.

22 REM The &40 bit is used to distinguish empty lists, vectors and hash-maps.

23 REM The &80 bit distinguishes vectors from lists and macros from functions.

25 REM sS%() is a shadow stack, used to keep track of which mal values might

26 REM be referenced from local variables at a given depth of the BASIC call

27 REM stack. It grows upwards. sSP% points to the first unused word. sFP%

28 REM points to the start of the current shadow stack frame. The first word

29 REM of each shadow stack frame is the saved value of sFP%. The rest are

30 REM mal values.

32 REM Types are:

33 REM &00 nil

34 REM &04 boolean

35 REM &08 integer

36 REM &0C core function

37 REM &01 atom

38 REM &05 free block

39 REM &09 list/vector (each object is a cons cell)

40 REM &0D environment

41 REM &11 hash-map internal node

42 REM &15 mal function (first part)

43 REM &19 mal function (second part)

44 REM &02 string/keyword

45 REM &06 symbol

46 REM &0A hash-map leaf node

48 REM Formats of individual objects are defined below.

50 DEF PROCtypes_init

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.

   DIM Z%((HIMEM-LOMEM)/110,3), Z$((HIMEM-LOMEM)/110)

   DIM sS%((HIMEM-LOMEM)/64)

   Z%(1,0) = &04 : REM false

   Z%(2,0) = &04 : Z%(2,1) = TRUE : REM true

   Z%(3,0) = &49 : Z%(3,1) = 3 : REM empty list

   Z%(4,0) = &C9 : Z%(4,1) = 4 : REM empty vector

   Z%(5,0) = &51 : REM empty hashmap

68 next_Z% = 6

69 sSP% = 1

70 sFP% = 0

71 F% = 0

72 ENDPROC

74 DEF FNtype_of(val%)

 =Z%(val%,0) AND &1F

77 DEF PROCgc_enter

78 REM PRINT ;sFP%;

79 sS%(sSP%) = sFP%

80 sFP% = sSP%

81 sSP% += 1

82 REM PRINT " >>> ";sFP%

83 ENDPROC

85 REM FNgc_save is equivalent to PROCgc_enter except that it returns a

86 REM value that can be passed to PROCgc_restore to pop all the stack

87 REM frames back to (and including) the one pushed by FNgc_save.

88 DEF FNgc_save

89 PROCgc_enter

90 =sFP%

92 DEF PROCgc_exit

93 REM PRINT ;sS%(sFP%);" <<< ";sFP%

94 sSP% = sFP%

95 sFP% = sS%(sFP%)

96 ENDPROC

98 DEF PROCgc_restore(oldFP%)

99 sFP% = oldFP%

100 REM PRINT "!!! FP reset"

101 PROCgc_exit

102 ENDPROC

103

104 DEF FNref_local(val%)

105 sS%(sSP%) = val%

106 sSP% += 1

107 =val%

108

109 DEF FNgc_exit(val%)

110 PROCgc_exit

111 =FNref_local(val%)

112

113 DEF FNgc_restore(oldFP%, val%)

114 PROCgc_restore(oldFP%)

115 =FNref_local(val%)

116

117 DEF PROCgc_keep_only2(val1%, val2%)

118 PROCgc_exit

119 PROCgc_enter

120 val1% = FNref_local(val1%)

121 val2% = FNref_local(val2%)

122 ENDPROC

123

124 DEF FNmalloc(type%)

125 LOCAL val%

126 REM If the heap is full, collect garbage first.

   IF F% = 0 AND next_Z% > DIM(Z%(),1) THEN

128 PROCgc

     IF F% = 0 ERROR &40E80950, "Out of mal heap memory"

130 ENDIF

131 IF F% <> 0 THEN

132 val% = F%

     F% = Z%(val%,1)

134 ELSE

135 val% = next_Z%

136 next_Z% += 1

137 ENDIF

   Z%(val%,0) = type%

139 =FNref_local(val%)

140

141 DEF PROCfree(val%)

   Z%(val%,0) = &05

   Z%(val%,1) = F%

   Z%(val%,2) = 0

   Z%(val%,3) = 0

146 Z$(val%) = ""

147 F% = val%

148 ENDPROC

149

150 DEF PROCgc

151 REM PRINT "** START GC **"

152 PROCgc_markall

153 PROCgc_sweep

154 REM PRINT "** FINISH GC **"

155 ENDPROC

156

157 DEF PROCgc_markall

158 LOCAL sp%, fp%

159 fp% = sFP%

160 REM PRINT ">>marking...";

   FOR sp% = sSP% - 1 TO 0 STEP -1

162 IF sp% = fp% THEN

163 fp% = sS%(sp%)

164 REM PRINT " / ";

     ELSE PROCgc_mark(sS%(sp%))

166 ENDIF

167 NEXT sp%

168 REM PRINT

169 ENDPROC

170

171 DEF PROCgc_mark(val%)

   IF (Z%(val%,0) AND &100) = 0 THEN

173 REM PRINT " ";val%;

     Z%(val%,0) += &100

     IF (Z%(val%,0) AND &01) THEN PROCgc_mark(Z%(val%,1))

     PROCgc_mark(Z%(val%,2))

     PROCgc_mark(Z%(val%,3))

178 ENDIF

179 ENDPROC

180

181 DEF PROCgc_sweep

182 LOCAL val%

183 REM PRINT ">>sweeping ...";

   FOR val% = 6 TO next_Z% - 1

     IF FNtype_of(val%) <> &05 AND (Z%(val%,0) AND &100) = 0 THEN

186 REM PRINT " ";val%;

187 PROCfree(val%)

188 ELSE

       Z%(val%,0) -= &100

190 ENDIF

191 NEXT val%

192 REM PRINT

193 ENDPROC

194

195 DEF FNmeta(val%)

 =Z%(val%,3)

197

198 DEF FNwith_meta(val%, meta%)

199 LOCAL newval%

   newval% = FNmalloc(Z%(val%,0))

   Z%(newval%,1) = Z%(val%,1)

   Z%(newval%,2) = Z%(val%,2)

   Z%(newval%,3) = meta%

204 Z$(newval%) = Z$(val%)

205 =newval%

206

207 REM ** Nil **

208

209 DEF FNis_nil(val%)

 =FNtype_of(val%) = 0

211

212 DEF FNnil

213 =0

214

215 REM ** Boolean **

216

217 REM Z%(x,1) = TRUE or FALSE

218

219 DEF FNis_boolean(val%)

 =FNtype_of(val%) = &04

221

222 DEF FNalloc_boolean(bval%)

   IF bval% THEN =2

224 =1

225

226 DEF FNunbox_boolean(val%)

   IF NOT FNis_boolean(val%) THEN ERROR &40E80911, "Not a boolean"

 =Z%(val%,1)

229

230 DEF FNis_truish(val%)

   IF FNis_nil(val%) THEN =FALSE

   IF FNis_boolean(val%) THEN =FNunbox_boolean(val%)

233 =TRUE

234

235 REM ** Integers **

236

237 REM Z%(x,1) = integer value

238

239 DEF FNis_int(val%)

 =FNtype_of(val%) = &08

241

242 DEF FNalloc_int(ival%)

243 LOCAL val%

   val% = FNmalloc(&08)

   Z%(val%,1) = ival%

246 =val%

247

248 DEF FNunbox_int(val%)

   IF NOT FNis_int(val%) THEN ERROR &40E80912, "Not an integer"

 =Z%(val%,1)

251

252 REM ** Strings and keywords **

253

254 REM Z$(x) is the string value

255 REM Z%(x,2) points to the next part of the string

256 REM A keyword is a string with first character CHR$(127).

257

258 DEF FNis_string(val%)

 =FNtype_of(val%) = &02

260

261 DEF FNalloc_string(sval$)

262 LOCAL val%

   val% = FNmalloc(&02)

264 Z$(val%) = sval$

265 =val%

266

267 DEF FNunbox_string(val%)

   IF NOT FNis_string(val%) THEN ERROR &40E80914, "Not a string"

   IF NOT FNis_nil(Z%(val%,2)) ERROR &40E80914, "Cannot unbox a long string"

270 =Z$(val%)

271

272 DEF FNstring_append(val%, add$)

273 LOCAL newval%

   IF NOT FNis_string(val%) THEN ERROR &40E80914, "Not a string"

275 newval% = FNalloc_string(Z$(val%))

   IF FNis_nil(Z%(val%,2)) THEN

     IF LEN(Z$(newval%)) + LEN(add$) <= 255 THEN

278 Z$(newval%) += add$

279 ELSE

       Z%(newval%,2) = FNalloc_string(add$)

281 ENDIF

282 ELSE

     Z%(newval%,2) = FNstring_append(Z%(val%,2), add$)

284 ENDIF

285 =newval%

286

287 DEF FNstring_concat(val%, add%)

288 LOCAL newval%

   IF NOT FNis_string(val%) THEN ERROR &40E80914, "Not a string"

   IF NOT FNis_string(add%) THEN ERROR &40E80914, "Not a string"

291 newval% = FNalloc_string(Z$(val%))

   IF FNis_nil(Z%(val%,2)) THEN

     IF LEN(Z$(newval%)) + LEN(Z$(add%)) <= 255 THEN

294 Z$(newval%) += Z$(add%)

       Z%(newval%,2) = Z%(add%,2)

296 ELSE

       Z%(newval%,2) = add%

298 ENDIF

299 ELSE

     Z%(newval%,2) = FNstring_concat(Z%(val%,2), add%)

301 ENDIF

302 =newval%

303

304 DEF FNstring_len(val%)

305 LOCAL len%

306 WHILE NOT FNis_nil(val%)

307 len% += LEN(Z$(val%))

     val% = Z%(val%,2)

309 ENDWHILE

310 =len%

311

312 DEF FNstring_chr(val%, pos%)

   WHILE pos% > LEN(Z$(val%))

314 pos% -= LEN(Z$(val%))

     val% = Z%(val%,2)

     IF FNis_nil(val%) THEN =""

317 ENDWHILE

 =MID$(Z$(val%), pos%, 1)

319

320 REM ** Symbols **

321

322 REM Z$(x) = value of the symbol

323

324 DEF FNis_symbol(val%)

 =FNtype_of(val%) = &06

326

327 DEF FNalloc_symbol(sval$)

328 LOCAL val%

   val% = FNmalloc(&06)

330 Z$(val%) = sval$

331 =val%

332

333 DEF FNunbox_symbol(val%)

   IF NOT FNis_symbol(val%) THEN ERROR &40E80915, "Not a symbol"

335 =Z$(val%)

336

337 REM ** Lists and vectors **

338

339 REM Lists and vectors are both represented as linked lists: the only

340 REM difference is in the state of the is_vector flag in the head cell

341 REM of the list. Note that this means that the tail of a list may be

342 REM a vector, and vice versa. FNas_list and FNas_vector can be used

343 REM to convert a sequence to a particular type as necessary.

344

345 REM Z%(x,0) AND &80 = is_vector flag

346 REM Z%(x,1) = index in Z%() of next pair

347 REM Z%(x,2) = index in Z%() of first element

348

349 REM The empty list is a distinguished value, with elements that match

350 REM the spec of 'first' and 'rest'.

351

352 DEF FNempty

353 =3

354

355 DEF FNempty_vector

356 =4

357

358 DEF FNalloc_pair(car%, cdr%)

359 LOCAL val%

   val% = FNmalloc(&09)

   Z%(val%,2) = car%

   Z%(val%,1) = cdr%

363 =val%

364

365 DEF FNalloc_vector_pair(car%, cdr%)

366 LOCAL val%

   val% = FNalloc_pair(car%, cdr%)

   Z%(val%,0) = Z%(val%,0) OR &80

369 =val%

370

371 DEF FNis_empty(val%)

 =(Z%(val%,0) AND &40) = &40

373

374 DEF FNis_seq(val%)

 =FNtype_of(val%) = &09

376

377 DEF FNis_list(val%)

 =FNtype_of(val%) = &09 AND (Z%(val%, 0) AND &80) = &00

379

380 DEF FNis_vector(val%)

 =FNtype_of(val%) = &09 AND (Z%(val%, 0) AND &80) = &80

382

383 DEF FNas_list(val%)

   IF FNis_list(val%) THEN =val%

   IF FNis_empty(val%) THEN =FNempty

 =FNalloc_pair(FNfirst(val%), FNrest(val%))

387

388 DEF FNas_vector(val%)

   IF FNis_vector(val%) THEN =val%

   IF FNis_empty(val%) THEN =FNempty_vector

 =FNalloc_vector_pair(FNfirst(val%), FNrest(val%))

392

393 DEF FNfirst(val%)

   IF NOT FNis_seq(val%) THEN ERROR &40E80916, "Can't get car of non-sequence"

 =FNref_local(Z%(val%,2))

396

397 DEF FNrest(val%)

   IF NOT FNis_seq(val%) THEN ERROR &40E80916, "Can't get cdr of non-sequence"

 =FNref_local(Z%(val%,1))

400

401 DEF FNalloc_list2(val0%, val1%)

   =FNalloc_pair(val0%, FNalloc_pair(val1%, FNempty))

403

 DEF FNalloc_list3(val0%, val1%, val2%)

   =FNalloc_pair(val0%, FNalloc_pair(val1%, FNalloc_pair(val2%, FNempty)))

406

407 DEF FNcount(val%)

408 LOCAL i%

409 WHILE NOT FNis_empty(val%)

410 val% = FNrest(val%)

411 i% += 1

412 ENDWHILE

413 = i%

414

415 DEF FNnth(val%, n%)

416 WHILE n% > 0

     IF FNis_empty(val%) THEN ERROR &40E80923, "Subscript out of range"

418 val% = FNrest(val%)

419 n% -= 1

420 ENDWHILE

   IF FNis_empty(val%) THEN ERROR &40E80923, "Subscript out of range"

422 =FNfirst(val%)

423

424 REM ** Core functions **

425

426 REM Z%(x,1) = index of function in FNcore_call

427

428 DEF FNis_corefn(val%)

 =FNtype_of(val%) = &0C

430

431 DEF FNalloc_corefn(fn%)

432 LOCAL val%

   val% = FNmalloc(&0C)

   Z%(val%,1) = fn%

435 =val%

436

437 DEF FNunbox_corefn(val%)

   IF NOT FNis_corefn(val%) THEN ERROR &40E80919, "Not a core function"

 =Z%(val%,1)

440

441 REM ** Hash-maps **

442

443 REM Hash-maps are represented as a crit-bit tree.

444

445 REM An internal node has:

446 REM Z%(x,0) >> 16 = next bit of key to check

447 REM Z%(x,1) = index in Z%() of left child (if next bit of key is 0)

448 REM Z%(x,2) = index in Z%() of right child (if next bit of key is 1)

449

450 REM A leaf node has

451 REM Z$(x) = key

452 REM Z%(x,2) = index in Z%() of value

453

454 REM The empty hash-map is a special value containing no data.

455

456 DEF FNempty_hashmap

457 =5

458

459 DEF FNhashmap_alloc_leaf(key$, val%)

460 LOCAL entry%

   entry% = FNmalloc(&0A)

462 Z$(entry%) = key$

   Z%(entry%,2) = val%

464 =entry%

465

 DEF FNhashmap_alloc_node(bit%, left%, right%)

467 LOCAL entry%

   entry% = FNmalloc(&11)

   Z%(entry%,0) += (bit% << 16)

   Z%(entry%,1) = left%

   Z%(entry%,2) = right%

472 =entry%

473

474 DEF FNis_hashmap(val%)

475 LOCAL t%

476 t% = FNtype_of(val%)

 =t% = &11 OR t% = &0A

478

479 DEF FNkey_bit(key$, bit%)

480 LOCAL cnum%

481 cnum% = bit% >> 3

   IF cnum% >= LEN(key$) THEN =FALSE

 =ASC(MID$(key$, cnum% + 1, 1)) AND (&80 >> (bit% AND 7))  

484

485 DEF FNkey_bitdiff(key1$, key2$)

486 LOCAL bit%

   WHILE FNkey_bit(key1$, bit%) = FNkey_bit(key2$, bit%)

488 bit% += 1

489 ENDWHILE

490 =bit%

491

 DEF FNhashmap_set(map%, key$, val%)

493 LOCAL bit%, nearest%

   IF FNis_empty(map%) THEN =FNhashmap_alloc_leaf(key$, val%)

   nearest% = FNhashmap_find(map%, key$)

   IF Z$(nearest%) = key$ THEN =FNhashmap_replace(map%, key$, val%)

   bit% = FNkey_bitdiff(key$, Z$(nearest%))

 =FNhashmap_insert(map%, bit%, key$, val%)

499

 DEF FNhashmap_insert(map%, bit%, key$, val%)

501 LOCAL left%, right%

   IF FNtype_of(map%) = &11 AND (Z%(map%,0) >> 16) < bit% THEN

     IF FNkey_bit(key$, Z%(map%,0) >> 16) THEN

       left% = Z%(map%,1)

       right% = FNhashmap_insert(Z%(map%,2), bit%, key$, val%)

506 ELSE

       left% = FNhashmap_insert(Z%(map%,1), bit%, key$, val%)

       right% = Z%(map%,2)

509 ENDIF

     =FNhashmap_alloc_node(Z%(map%,0)>>16, left%, right%)

511 ENDIF

   IF FNkey_bit(key$, bit%) THEN

513 left% = map%

     right% = FNhashmap_alloc_leaf(key$, val%)

515 ELSE

     left% = FNhashmap_alloc_leaf(key$, val%)

517 right% = map%

518 ENDIF

 =FNhashmap_alloc_node(bit%, left%, right%)

520

521

522 REM Replace a known-present key in a non-empty hashmap.

 DEF FNhashmap_replace(map%, key$, val%)

524 LOCAL left%, right%

   IF FNtype_of(map%) = &0A THEN =FNhashmap_alloc_leaf(key$, val%)

   IF FNkey_bit(key$, Z%(map%,0) >> 16) THEN

     left% = Z%(map%,1)

     right% = FNhashmap_replace(Z%(map%,2), key$, val%)

529 ELSE

     left% = FNhashmap_replace(Z%(map%,1), key$, val%)

     right% = Z%(map%,2)

532 ENDIF

 =FNhashmap_alloc_node(Z%(map%,0)>>16, left%, right%)

534

535 DEF FNhashmap_remove(map%, key$)

536 LOCAL child%

   IF FNis_empty(map%) THEN =map%

   IF FNtype_of(map%) = &0A THEN

     IF Z$(map%) = key$ THEN =FNempty_hashmap

540 ENDIF

   IF FNkey_bit(key$, Z%(map%,0) >> 16) THEN

     child% = FNhashmap_remove(Z%(map%,2), key$)

     IF FNis_empty(child%) THEN =Z%(map%,1)

     =FNhashmap_alloc_node(Z%(map%,0)>>16, Z%(map%,1), child%)

545 ELSE

     child% = FNhashmap_remove(Z%(map%,1), key$)

     IF FNis_empty(child%) THEN =Z%(map%,2)

     =FNhashmap_alloc_node(Z%(map%,0)>>16, child%, Z%(map%,2))

549 ENDIF

550

551 REM FNhashmap_find finds the nearest entry in a non-empty hash-map to

552 REM the key requested, and returns the entire entry.

553 DEF FNhashmap_find(map%, key$)

   WHILE FNtype_of(map%) = &11

     IF FNkey_bit(key$, Z%(map%,0) >> 16) THEN map% = Z%(map%,2) ELSE map% = Z%(map%,1)

556 ENDWHILE

557 =map%

558

559 DEF FNhashmap_get(map%, key$)

   IF NOT FNis_hashmap(map%) THEN ERROR &40E80918, "Can't get item from a non-hashmap"

   IF FNis_empty(map%) THEN =FNnil

   map% = FNhashmap_find(map%, key$)

 IF Z$(map%) = key$ THEN =FNref_local(Z%(map%,2)) ELSE =FNnil

564

565 DEF FNhashmap_contains(map%, key$)

   IF NOT FNis_hashmap(map%) THEN ERROR &40E80918, "Can't get item from a non-hashmap"

   IF FNis_empty(map%) THEN =FALSE

   map% = FNhashmap_find(map%, key$)

569 =Z$(map%) = key$

570

571 DEF FNhashmap_keys(map%)

 =FNhashmap_keys1(map%, FNempty)

573

574 DEF FNhashmap_keys1(map%, acc%)

   IF FNis_empty(map%) THEN =acc%

   IF FNtype_of(map%) = &0A THEN

     =FNalloc_pair(FNalloc_string(Z$(map%)), acc%)

578 ENDIF

 =FNhashmap_keys1(Z%(map%,1), FNhashmap_keys1(Z%(map%,2), acc%))

580

581 DEF FNhashmap_vals(map%)

 =FNhashmap_vals1(map%, FNempty)

583

584 DEF FNhashmap_vals1(map%, acc%)

   IF FNis_empty(map%) THEN =acc%

   IF FNtype_of(map%) = &0A THEN

     =FNalloc_pair(Z%(map%,2), acc%)

588 ENDIF

 =FNhashmap_vals1(Z%(map%,1), FNhashmap_vals1(Z%(map%,2), acc%))

590

591 DEF PROChashmap_dump(map%)

   IF FNis_empty(map%) THEN

593 PRINT "[empty]"

594 ELSE

595 PRINT "[-----]"

     PROChashmap_dump_internal(map%, "")

597 ENDIF

598 ENDPROC

599

600 DEF PROChashmap_dump_internal(map%, prefix$)

   IF FNtype_of(map%) = &0A PRINT prefix$;Z$(map%)

   IF FNtype_of(map%) = &11 THEN

     PRINT prefix$;"<";Z%(map%,0) >> 16;">"

     PROChashmap_dump_internal(Z%(map%,1), prefix$ + "L ")

     PROChashmap_dump_internal(Z%(map%,2), prefix$ + "R ")

606 ENDIF

607 ENDPROC

608

609 REM ** Functions **

610

611 REM A function is represented by two cells:

612 REM Z%(x,0) AND &80 = is_macro flag

613 REM Z%(x,1) = index in Z%() of ast

614 REM Z%(x,2) = y

615

616 REM Z%(y,1) = index in Z%() of params

617 REM Z%(y,2) = index in Z%() of env

618

619 DEF FNis_fn(val%)

 =FNtype_of(val%) = &15

621

622 DEF FNis_nonmacro_fn(val%)

 =FNtype_of(val%) = &15 AND (Z%(val%, 0) AND &80) = &00

624

625 DEF FNis_macro(val%)

 =FNtype_of(val%) = &15 AND (Z%(val%, 0) AND &80) = &80

627

 DEF FNalloc_fn(ast%, params%, env%)

629 LOCAL val1%, val2%

   val1% = FNmalloc(&15)

   Z%(val1%,1) = ast%

   val2% = FNmalloc(&19)

   Z%(val1%,2) = val2%

   Z%(val2%,1) = params%

   Z%(val2%,2) = env%

636 =val1%

637

638 DEF FNas_macro(val%)

   IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function"

640 LOCAL newval%

   newval% = FNmalloc(Z%(val%,0) OR &80)

   Z%(newval%,1) = Z%(val%,1)

   Z%(newval%,2) = Z%(val%,2)

   Z%(newval%,3) = Z%(val%,3)

645 =newval%

646

647 DEF FNfn_ast(val%)

   IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function"

 =FNref_local(Z%(val%,1))

650

651 DEF FNfn_params(val%)

   IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function"

 =FNref_local(Z%(Z%(val%,2),1))

654

655 DEF FNfn_env(val%)

   IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function"

 =FNref_local(Z%(Z%(val%,2),2))

658

659 REM ** Atoms **

660

661 REM Z%(x,1) = index in Z% of current referent

662

663 DEF FNis_atom(val%)

 =FNtype_of(val%) = &01

665

666 DEF FNalloc_atom(contents%)

667 LOCAL val%

   val% = FNmalloc(&01)

   Z%(val%,1) = contents%

670 =val%

671

672 DEF FNatom_deref(val%)

 =FNref_local(Z%(val%,1))

674

675 DEF PROCatom_reset(val%, contents%)

   Z%(val%,1) = contents%

677 ENDPROC

678

679 REM ** Environments **

680

681 REM Z%(x,1) = index in Z% of hash-map

682 REM Z%(x,2) = index in Z% of outer environment

683

684 DEF FNis_environment(val%)

 =FNtype_of(val%) = &0D

686

687 DEF FNalloc_environment(outer%)

688 LOCAL val%

   val% = FNmalloc(&0D)

690 Z%(val%,1) = FNempty_hashmap

   Z%(val%,2) = outer%

692 =val%

693

694 DEF FNenvironment_data(val%)

   IF NOT FNis_environment(val%) THEN ERROR &40E8091D, "Not an environment"

 =FNref_local(Z%(val%,1))

697

698 DEF PROCenvironment_set_data(val%, data%)

   IF NOT FNis_environment(val%) THEN ERROR &40E8091D, "Not an environment"

   Z%(val%,1) = data%

701 ENDPROC

702

703 DEF FNenvironment_outer(val%)

   IF NOT FNis_environment(val%) THEN ERROR &40E8091D, "Not an environment"

 =FNref_local(Z%(val%,2))

706

707 REM Local Variables:

708 REM indent-tabs-mode: nil

709 REM End: