bbc-basic: Adjust error message from FNenv_get to match tests.

[jackhill/mal.git] / bbc-basic / types

REM > types library for mal in BBC BASIC

REM  This library should be the only thing that understands the
REM  implementation of mal data types in BBC BASIC.  All other
REM  code should use routines in this library to access them.

REM  As far as other code is concerned, a mal object is just an
REM  opaque 32-bit integer, which might be a pointer, or might not.

REM  Following the 8-bit BASIC implementation, we currently have two
REM  arrays, Z%() containing most objects and S$() containing strings
REM  (referenced from Z%()).  Unlike that implementation, we use a
REM  two-dimensional array where each object is a whole row.  This
REM  is inefficient but should make memory management simpler.

REM  S%() holds reference counts for the strings in S$().  At present
REM  these are all 0 or 1.

REM  Z%(x,0) holds the type of an object.  High-order bits contain flags.

REM  sS%() is a shadow stack, used to keep track of which mal values might
REM  be referenced from local variables at a given depth of the BASIC call
REM  stack.  It grows upwards.  sSP% points to the first unused word.  sFP%
REM  points to the start of the current shadow stack frame.  The first word
REM  of each shadow stack frame is the saved value of sFP%.  The rest are
REM  mal values.

REM  Types are:
REM  0   nil
REM  1   boolean
REM  2   integer
REM  4   string
REM  5   symbol
REM  6   list (each object is a cons cell)
REM  8   hash-map (each object is one entry)
REM  9   core function
REM  10  mal function
REM  13  environment
REM  15  free block

REM  Formats of individual objects are defined below.

DEF PROCtypes_init
  REM  Arbitrarily use half of BASIC's heap as the mal heap, with a bit
  REM  more for strings.  Each heap entry is sixteen bytes.
  DIM Z%((HIMEM-LOMEM)/32,3)
  DIM S$((HIMEM-LOMEM)/64), S%((HIMEM-LOMEM)/64)
  DIM sS%((HIMEM-LOMEM)/64)
  Z%(1,0) = 1: REM false
  Z%(2,0) = 1: Z%(2,1) = TRUE: REM true
  Z%(3,0) = 6: REM empty list
  Z%(5,0) = 8: REM empty hashmap
  next_Z% = 6
  next_S% = 0
  sSP% = 1
  sFP% = 0
  F% = 0
  GCtoggle% = 0
  SF% = 0
ENDPROC

DEF FNtype_of(val%)
=Z%(val%,0) AND 31

DEF PROCgc_enter
  REM PRINT ;sFP%;
  sS%(sSP%) = sFP%
  sFP% = sSP%
  sSP% += 1
  REM PRINT " >>> ";sFP%
ENDPROC

DEF FNgc_save
=sFP%

DEF PROCgc_exit
  REM PRINT ;sS%(sFP%);" <<< ";sFP%
  sSP% = sFP%
  sFP% = sS%(sFP%)
ENDPROC

DEF PROCgc_restore(oldFP%)
  sFP% = oldFP%
  sSP% = sFP% + 1
  REM PRINT "!!! ";sFP%
ENDPROC  

DEF FNref_local(val%)
  sS%(sSP%) = val%
  sSP% += 1
=val%

DEF FNgc_exit(val%)
  PROCgc_exit
  val% = FNref_local(val%)
=val%

DEF PROCgc_keep_only2(val1%, val2%)
  PROCgc_exit
  PROCgc_enter
  val1% = FNref_local(val1%)
  val2% = FNref_local(val2%)
ENDPROC

DEF FNmalloc(type%)
  LOCAL val%
  REM  If the heap is full, collect garbage first.
  IF F% = 0 AND next_Z% > DIM(Z%(),1) THEN PROCgc
  IF F% <> 0 THEN
    val% = F%
    F% = Z%(val%,1)
  ELSE
    val% = next_Z%
    next_Z% += 1
  ENDIF
  Z%(val%,0) = type% OR GCtoggle%
=FNref_local(val%)

DEF FNsalloc(s$)
  LOCAL val%
  IF SF% <> 0 THEN
    val% = SF%
    SF% = S%(val%)
  ELSE
    val% = next_S%
    next_S% += 1
  ENDIF
  S$(val%) = s$
=val%

DEF PROCfree(val%)
  CASE FNtype_of(val%) OF
    WHEN 4 : PROCfree_string(val%)
    WHEN 5 : PROCfree_symbol(val%)
    WHEN 8 : PROCfree_hashmap(val%)
  ENDCASE
  Z%(val%,0) = 15
  Z%(val%,1) = F%
  Z%(val%,2) = 0
  Z%(val%,3) = 0
  F% = val%
ENDPROC

DEF PROCsfree(val%)
  S$(val%) = ""
  S%(val%) = SF%
  SF% = val%
ENDPROC

DEF PROCgc
  REM PRINT "** START GC **"
  GCtoggle% = GCtoggle% EOR &100
  PROCgc_markall
  PROCgc_sweep
  REM PRINT "** FINISH GC **"
ENDPROC

DEF PROCgc_markall
  LOCAL sp%, fp%
  fp% = sFP%
  REM PRINT ">>marking...";
  FOR sp% = sSP% - 1 TO 0 STEP -1
    IF sp% = fp% THEN
      fp% = sS%(sp%)
      REM PRINT " / ";
    ELSE PROCgc_mark(sS%(sp%))
    ENDIF
  NEXT sp%
  REM PRINT
ENDPROC

DEF PROCgc_mark(val%)
  IF (Z%(val%,0) AND &100) <> GCtoggle% THEN
    REM PRINT " ";val%;
    Z%(val%,0) = Z%(val%,0) EOR &100
    CASE FNtype_of(val%) OF
      WHEN 6 :  PROCgc_mark_list(val%)
      WHEN 8 :  PROCgc_mark_hashmap(val%)
      WHEN 10 : PROCgc_mark_fn(val%)
      WHEN 12 : PROCgc_mark_atom(val%)
      WHEN 13 : PROCgc_mark_environment(val%)
    ENDCASE
  ENDIF
ENDPROC

DEF PROCgc_sweep
  LOCAL val%
  REM PRINT ">>sweeping ...";
  FOR val% = 6 TO next_Z% - 1
    IF FNtype_of(val%) <> 15 AND (Z%(val%,0) AND &100) <> GCtoggle% THEN
      REM PRINT " ";val%;
      PROCfree(val%)
    ENDIF
  NEXT val%
  REM PRINT
ENDPROC

REM ** Nil **

DEF FNis_nil(val%)
=FNtype_of(val%) = 0

DEF FNnil
=0

REM ** Boolean **

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

DEF FNis_boolean(val%)
=FNtype_of(val%) = 1

DEF FNalloc_boolean(bval%)
  IF bval% THEN =2
=1

DEF FNunbox_boolean(val%)
  IF NOT FNis_boolean(val%) THEN ERROR &40E80911, "Not a boolean"
=Z%(val%,1)

DEF FNis_truish(val%)
  IF FNis_nil(val%) THEN =FALSE
  IF FNis_boolean(val%) THEN =FNunbox_boolean(val%)
=TRUE

REM ** Integers **

REM  Z%(x,1) = integer value

DEF FNis_int(val%)
=FNtype_of(val%) = 2

DEF FNalloc_int(ival%)
  LOCAL val%
  val% = FNmalloc(2)
  Z%(val%,1) = ival%
=val%

DEF FNunbox_int(val%)
  IF NOT FNis_int(val%) THEN ERROR &40E80912, "Not an integer"
=Z%(val%,1)

REM ** Strings **

DEF FNis_string(val%)
=FNtype_of(val%) = 4

DEF FNalloc_string(sval$)
  LOCAL val%
  val% = FNmalloc(4)
  Z%(val%,1) = FNsalloc(sval$)
=val%

DEF PROCfree_string(val%)
  PROCsfree(Z%(val%,1))
ENDPROC

DEF FNunbox_string(val%)
  IF NOT FNis_string(val%) THEN ERROR &40E80914, "Not a string"
=S$(Z%(val%,1))

REM ** Symbols **

REM  Z%(x,1) = index in S$() of the value of the symbol

DEF FNis_symbol(val%)
=FNtype_of(val%) = 5

DEF FNalloc_symbol(sval$)
  LOCAL val%
  val% = FNmalloc(5)
  Z%(val%,1) = FNsalloc(sval$)
=val%

DEF PROCfree_symbol(val%)
  PROCsfree(Z%(val%,1))
ENDPROC

DEF FNunbox_symbol(val%)
  IF NOT FNis_symbol(val%) THEN ERROR &40E80915, "Not a symbol"
=S$(Z%(val%,1))

REM ** Lists **

REM  Z%(x,1) = index in Z%() of next pair
REM  Z%(x,2) = index in Z%() of first element

REM  The empty list is a distinguished value, which happens to have
REM  both elements nil.

DEF FNempty
=3

DEF FNalloc_pair(car%, cdr%)
  LOCAL val%
  val% = FNmalloc(6)
  Z%(val%,2) = car%
  Z%(val%,1) = cdr%
=val%

DEF FNis_empty(val%)
=val% = FNempty

DEF FNis_list(val%)
=FNtype_of(val%) = 6

DEF PROCgc_mark_list(val%)
  IF NOT FNis_empty(val%) THEN
    PROCgc_mark(Z%(val%,1))
    PROCgc_mark(Z%(val%,2))
  ENDIF
ENDPROC

DEF FNlist_car(val%)
  IF NOT FNis_list(val%) THEN ERROR &40E80916, "Can't get car of non-list"
  IF Z%(val%,1) = 0 THEN ERROR &40E80920, "Can't get car of empty list"
=FNref_local(Z%(val%,2))

DEF FNlist_cdr(val%)
  IF NOT FNis_list(val%) THEN ERROR &40E80916, "Can't get cdr of non-list"
  IF Z%(val%,1) = 0 THEN ERROR &40E80920, "Can't get cdr of empty list"
=FNref_local(Z%(val%,1))

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

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

DEF FNlist_len(val%)
  LOCAL i%
  WHILE NOT FNis_empty(val%)
    val% = FNlist_cdr(val%)
    i% += 1
  ENDWHILE
= i%

DEF FNlist_nth(val%, n%)
  WHILE n% > 0
    IF FNis_empty(val%) THEN ERROR &40E80923, "Subscript out of range"
    val% = FNlist_cdr(val%)
    n% -= 1
  ENDWHILE
  IF FNis_empty(val%) THEN ERROR &40E80923, "Subscript out of range"
=FNlist_car(val%)

DEF PROClist_to_array(val%, a%())
  REM  a%() must already be correctly dimensioned.
  LOCAL i%
  WHILE NOT FNis_empty(val%)
    a%(i%) = FNref_local(FNlist_car(val%))
    val% = FNlist_cdr(val%)
    i% += 1
  ENDWHILE
ENDPROC

DEF FNarray_to_list(a%())
  LOCAL i%, val%
  PROCgc_enter
  val% = FNempty
  IF DIM(a%(), 1) = 0 THEN =val%
  FOR i% = DIM(a%(), 1) - 1 TO 0 STEP -1
    val% = FNalloc_pair(a%(i%), val%)
  NEXT i%
=FNgc_exit(val%)

REM ** Core functions **

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

DEF FNis_corefn(val%)
=FNtype_of(val%) = 9

DEF FNalloc_corefn(fn%)
  LOCAL val%
  val% = FNmalloc(9)
  Z%(val%,1) = fn%
=val%

DEF FNunbox_corefn(val%)
  IF NOT FNis_corefn(val%) THEN ERROR &40E80919, "Not a core function"
=Z%(val%,1)

REM ** Hash-maps **

REM  Z%(x,1) = index in Z%() of next element
REM  Z%(x,2) = index in S$() of value
REM  Z%(x,3) = index in Z%() of value

REM  To defer implementing mal strings for a bit, hashmap keys are
REM  currently BASIC strings rather than arbitrary values.

DEF FNempty_hashmap
=5

DEF FNalloc_hashmap_entry(key$, val%, next%)
  LOCAL entry%
  entry% = FNmalloc(8)
  Z%(entry%,1) = next%
  Z%(entry%,2) = FNsalloc(key$)
  Z%(entry%,3) = val%
=entry%

DEF FNis_hashmap(val%)
=FNtype_of(val%) = 8

DEF PROCgc_mark_hashmap(val%)
  PROCgc_mark(Z%(val%,1))
  PROCgc_mark(Z%(val%,3))
ENDPROC

DEF PROCfree_hashmap(val%)
  PROCsfree(Z%(val%,2))
ENDPROC

DEF FNhashmap_get(map%, key$)
  IF NOT FNis_hashmap(map%) THEN ERROR &40E80918, "Can't get item from a non-hashmap"
  IF map% = FNempty_hashmap THEN =FNnil
  IF S$(Z%(map%,2)) = key$ THEN =FNref_local(Z%(map%,3))
=FNhashmap_get(Z%(map%,1), key$)

DEF FNhashmap_contains(map%, key$)
  IF NOT FNis_hashmap(map%) THEN ERROR &40E80918, "Can't get item from a non-hashmap"
  IF map% = FNempty_hashmap THEN =FALSE
  IF S$(Z%(map%,2)) = key$ THEN =TRUE
=FNhashmap_get(Z%(map%,1), key$)

REM ** Functions **

REM  Z%(x,0) AND &80 = is_macro flag
REM  Z%(x,1) = index in Z%() of ast
REM  Z%(x,2) = index in Z%() of params
REM  Z%(x,3) = index in Z%() of env

DEF FNis_fn(val%)
=FNtype_of(val%) = 10

DEF FNis_nonmacro_fn(val%)
=FNtype_of(val%) = 10 AND (Z%(val%, 0) AND &80) = &00

DEF FNis_macro(val%)
=FNtype_of(val%) = 10 AND (Z%(val%, 0) AND &80) = &80

DEF FNalloc_fn(ast%, params%, env%)
  LOCAL val%
  val% = FNmalloc(10)
  Z%(val%,1) = ast%
  Z%(val%,2) = params%
  Z%(val%,3) = env%
=val%

DEF PROCmake_macro(val%)
  IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function"
  Z%(val%, 0) = Z%(val%, 0) OR &80
ENDPROC

DEF PROCgc_mark_fn(val%)
  PROCgc_mark(Z%(val%,1))
  PROCgc_mark(Z%(val%,2))
  PROCgc_mark(Z%(val%,3))
ENDPROC

DEF FNfn_ast(val%)
  IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function"
=FNref_local(Z%(val%,1))

DEF FNfn_params(val%)
  IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function"
=FNref_local(Z%(val%,2))

DEF FNfn_env(val%)
  IF NOT FNis_fn(val%) THEN ERROR &40E8091A, "Not a function"
=FNref_local(Z%(val%,3))

REM ** Atoms **

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

DEF FNis_atom(val%)
=FNtype_of(val%) = 12

DEF FNalloc_atom(contents%)
  LOCAL val%
  val% = FNmalloc(12)
  Z%(val%,1) = contents%
=val%

DEF PROCgc_mark_atom(val%)
  PROCgc_mark(Z%(val%,1))
ENDPROC

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

DEF PROCatom_reset(val%, contents%)
  Z%(val%,1) = contents%
ENDPROC

REM ** Environments **

REM  Z%(x,1) = index in Z% of hash-map
REM  Z%(x,2) = index in Z% of outer environment

DEF FNis_environment(val%)
=FNtype_of(val%) = 13

DEF FNalloc_environment(outer%)
  LOCAL val%
  val% = FNmalloc(13)
  Z%(val%,1) = FNempty_hashmap
  Z%(val%,2) = outer%
=val%

DEF PROCgc_mark_environment(val%)
  PROCgc_mark(Z%(val%,1))
  PROCgc_mark(Z%(val%,2))
ENDPROC

DEF FNenvironment_data(val%)
  IF NOT FNis_environment(val%) THEN ERROR &40E8091D, "Not an environment"
=FNref_local(Z%(val%,1))

DEF PROCenvironment_set_data(val%, data%)
  IF NOT FNis_environment(val%) THEN ERROR &40E8091D, "Not an environment"
  Z%(val%,1) = data%
ENDPROC

DEF FNenvironment_outer(val%)
  IF NOT FNis_environment(val%) THEN ERROR &40E8091D, "Not an environment"
=FNref_local(Z%(val%,2))

REM Local Variables:
REM indent-tabs-mode: nil
REM End: