bbc-basic/types

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