[jackhill/mal.git] / basic / core.in.bas

REM APPLY should really be in types.in.bas but it is here because it
REM calls DO_TCO_FUNCTION so it will cause syntax errors for steps1-3
REM if it is in types.in.bas because there are unresolved labels.

REM APPLY(F, AR) -> R
REM   - restores E
REM   - call using GOTO and with return label/address on the stack
SUB APPLY
  REM if metadata, get the actual object
  IF (Z%(F,0)AND31)>=16 THEN F=Z%(F,1)

  IF (Z%(F,0)AND31)=9 THEN GOTO APPLY_FUNCTION
  IF (Z%(F,0)AND31)=10 THEN GOTO APPLY_MAL_FUNCTION
  IF (Z%(F,0)AND31)=11 THEN GOTO APPLY_MAL_FUNCTION

  APPLY_FUNCTION:
    REM regular function
    IF Z%(F,1)<60 THEN GOSUB DO_FUNCTION:GOTO APPLY_DONE
    REM for recur functions (apply, map, swap!), use GOTO
    IF Z%(F,1)>60 THEN CALL DO_TCO_FUNCTION
    GOTO APPLY_DONE

  APPLY_MAL_FUNCTION:
    X=X+1:X%(X)=E: REM save the current environment

    REM create new environ using env and params stored in the
    REM function and bind the params to the apply arguments
    O=Z%(F+1,1):BI=Z%(F+1,0):EX=AR:GOSUB ENV_NEW_BINDS

    A=Z%(F,1):E=R:CALL EVAL

    AY=E:GOSUB RELEASE: REM release the new environment

    E=X%(X):X=X-1: REM pop/restore the saved environment

  APPLY_DONE:
END SUB


REM DO_TCO_FUNCTION(F, AR)
SUB DO_TCO_FUNCTION
  FF=Z%(F,1)

  REM Get argument values
  R=AR+1:GOSUB DEREF_R:AA=R
  R=Z%(AR,1)+1:GOSUB DEREF_R:AB=R

  ON FF-60 GOTO DO_APPLY,DO_MAP,DO_SWAP_BANG

  DO_APPLY:
    F=AA
    AR=Z%(AR,1)
    A=AR:GOSUB COUNT:R4=R

    A=Z%(AR+1,1)
    REM no intermediate args, but not a list, so convert it first
    IF R4<=1 AND (Z%(A,0)AND31)<>6 THEN T=6:GOSUB FORCE_SEQ_TYPE:GOTO DO_APPLY_2
    REM no intermediate args, just call APPLY directly
    IF R4<=1 THEN GOTO DO_APPLY_1

    REM prepend intermediate args to final args element
    A=AR:B=0:C=R4-1:GOSUB SLICE
    REM release the terminator of new list (we skip over it)
    AY=Z%(R6,1):GOSUB RELEASE
    REM attach end of slice to final args element
    Z%(R6,1)=Z%(A+1,1)
    Z%(Z%(A+1,1),0)=Z%(Z%(A+1,1),0)+32

    GOTO DO_APPLY_2

    DO_APPLY_1:
      AR=A:CALL APPLY

      GOTO DO_TCO_FUNCTION_DONE

    DO_APPLY_2:
      X=X+1:X%(X)=R: REM push/save new args for release

      AR=R:CALL APPLY

      AY=X%(X):X=X-1:GOSUB RELEASE: REM pop/release new args
      GOTO DO_TCO_FUNCTION_DONE

  DO_MAP:
    F=AA

    REM first result list element
    T=6:L=0:N=0:GOSUB ALLOC

    REM push future return val, prior entry, F and AB
    X=X+4:X%(X-3)=R:X%(X-2)=0:X%(X-1)=F:X%(X)=AB

    DO_MAP_LOOP:
      REM set previous to current if not the first element
      IF X%(X-2)<>0 THEN Z%(X%(X-2),1)=R
      REM update previous reference to current
      X%(X-2)=R

      IF Z%(AB,1)=0 THEN GOTO DO_MAP_DONE

      REM create argument list for apply call
      Z%(3,0)=Z%(3,0)+32
      REM inc ref cnt of referred argument
      T=6:L=3:N=Z%(AB+1,1):GOSUB ALLOC

      REM push argument list
      X=X+1:X%(X)=R

      AR=R:CALL APPLY

      REM pop apply args are release them
      AY=X%(X):X=X-1:GOSUB RELEASE

      REM set the result value
      Z%(X%(X-2)+1,1)=R

      REM restore F
      F=X%(X-1)

      REM update AB to next source element
      X%(X)=Z%(X%(X),1)
      AB=X%(X)

      REM allocate next element
      T=6:L=0:N=0:GOSUB ALLOC

      GOTO DO_MAP_LOOP

    DO_MAP_DONE:
      REM get return val
      R=X%(X-3)
      REM pop everything off stack
      X=X-4
      GOTO DO_TCO_FUNCTION_DONE


  DO_SWAP_BANG:
    F=AB

    REM add atom to front of the args list
    T=6:L=Z%(Z%(AR,1),1):N=Z%(AA,1):GOSUB ALLOC: REM cons
    AR=R

    REM push args for release after
    X=X+1:X%(X)=AR

    REM push atom
    X=X+1:X%(X)=AA

    CALL APPLY

    REM pop atom
    AA=X%(X):X=X-1

    REM pop and release args
    AY=X%(X):X=X-1:GOSUB RELEASE

    REM use reset to update the value
    AB=R:GOSUB DO_RESET_BANG

    REM but decrease ref cnt of return by 1 (not sure why)
    AY=R:GOSUB RELEASE

    GOTO DO_TCO_FUNCTION_DONE

  DO_TCO_FUNCTION_DONE:
END SUB


REM DO_FUNCTION(F, AR)
DO_FUNCTION:
  REM Get the function number
  FF=Z%(F,1)

  REM Get argument values
  R=AR+1:GOSUB DEREF_R:AA=R
  R=Z%(AR,1)+1:GOSUB DEREF_R:AB=R

  REM Switch on the function number
  IF FF>59 THEN ER=-1:ER$="unknown function"+STR$(FF):RETURN
  ON FF/10+1 GOTO DO_1_9,DO_10_19,DO_20_29,DO_30_39,DO_40_49,DO_50_56

  DO_1_9:
  ON FF GOTO DO_EQUAL_Q,DO_THROW,DO_NIL_Q,DO_TRUE_Q,DO_FALSE_Q,DO_STRING_Q,DO_SYMBOL,DO_SYMBOL_Q,DO_KEYWORD
  DO_10_19:
  ON FF-9 GOTO DO_KEYWORD_Q,DO_PR_STR,DO_STR,DO_PRN,DO_PRINTLN,DO_READ_STRING,DO_READLINE,DO_SLURP,DO_LT,DO_LTE
  DO_20_29:
  ON FF-19 GOTO DO_GT,DO_GTE,DO_ADD,DO_SUB,DO_MULT,DO_DIV,DO_TIME_MS,DO_LIST,DO_LIST_Q,DO_VECTOR
  DO_30_39:
  ON FF-29 GOTO DO_VECTOR_Q,DO_HASH_MAP,DO_MAP_Q,DO_ASSOC,DO_THROW,DO_GET,DO_CONTAINS,DO_KEYS,DO_VALS,DO_SEQUENTIAL_Q
  DO_40_49:
  ON FF-39 GOTO DO_CONS,DO_CONCAT,DO_NTH,DO_FIRST,DO_REST,DO_EMPTY_Q,DO_COUNT,DO_THROW,DO_THROW,DO_WITH_META
  DO_50_56:
  ON FF-49 GOTO DO_META,DO_ATOM,DO_ATOM_Q,DO_DEREF,DO_RESET_BANG,DO_EVAL,DO_READ_FILE

  DO_EQUAL_Q:
    A=AA:B=AB:GOSUB EQUAL_Q
    R=R+1
    RETURN
  DO_THROW:
    ER=AA
    Z%(ER,0)=Z%(ER,0)+32
    R=0
    RETURN
  DO_NIL_Q:
    R=1
    IF AA=0 THEN R=2
    RETURN
  DO_TRUE_Q:
    R=1
    IF AA=2 THEN R=2
    RETURN
  DO_FALSE_Q:
    R=1
    IF AA=1 THEN R=2
    RETURN
  DO_STRING_Q:
    R=1
    IF (Z%(AA,0)AND31)<>4 THEN RETURN
    IF MID$(S$(Z%(AA,1)),1,1)=CHR$(127) THEN RETURN
    R=2
    RETURN
  DO_SYMBOL:
    T=5:L=Z%(AA,1):GOSUB ALLOC
    RETURN
  DO_SYMBOL_Q:
    R=1
    IF (Z%(AA,0)AND31)=5 THEN R=2
    RETURN
  DO_KEYWORD:
    A=Z%(AA,1)
    AS$=S$(A)
    IF MID$(AS$,1,1)<>CHR$(127) THEN AS$=CHR$(127)+AS$
    GOSUB STRING_
    T=4:L=R:GOSUB ALLOC
    RETURN
  DO_KEYWORD_Q:
    R=1
    IF (Z%(AA,0)AND31)<>4 THEN RETURN
    IF MID$(S$(Z%(AA,1)),1,1)<>CHR$(127) THEN RETURN
    R=2
    RETURN

  DO_PR_STR:
    AZ=AR:PR=1:SE$=" ":GOSUB PR_STR_SEQ
    AS$=R$:T=4:GOSUB STRING
    RETURN
  DO_STR:
    AZ=AR:PR=0:SE$="":GOSUB PR_STR_SEQ
    AS$=R$:T=4:GOSUB STRING
    RETURN
  DO_PRN:
    AZ=AR:PR=1:SE$=" ":GOSUB PR_STR_SEQ
    PRINT R$
    R=0
    RETURN
  DO_PRINTLN:
    AZ=AR:PR=0:SE$=" ":GOSUB PR_STR_SEQ
    PRINT R$
    R=0
    RETURN
  DO_READ_STRING:
    A$=S$(Z%(AA,1))
    GOSUB READ_STR
    RETURN
  DO_READLINE:
    A$=S$(Z%(AA,1)):GOSUB READLINE
    IF EOF=1 THEN EOF=0:R=0:RETURN
    AS$=R$:T=4:GOSUB STRING
    RETURN
  DO_SLURP:
    R$=""
    REM OPEN 1,8,2,S$(Z%(AA,1))+",SEQ,R"
    REM OPEN 1,8,2,S$(Z%(AA,1))
    OPEN 1,8,0,S$(Z%(AA,1))
    DO_SLURP_LOOP:
      A$=""
      GET#1,A$
      IF ASC(A$)=10 THEN R$=R$+CHR$(13)
      IF (ASC(A$)<>10) AND (A$<>"") THEN R$=R$+A$
      IF (ST AND 64) THEN GOTO DO_SLURP_DONE
      IF (ST AND 255) THEN ER=-1:ER$="File read error "+STR$(ST):RETURN
      GOTO DO_SLURP_LOOP
    DO_SLURP_DONE:
      CLOSE 1
      AS$=R$:T=4:GOSUB STRING
      RETURN

  DO_LT:
    R=1
    IF Z%(AA,1)<Z%(AB,1) THEN R=2
    RETURN
  DO_LTE:
    R=1
    IF Z%(AA,1)<=Z%(AB,1) THEN R=2
    RETURN
  DO_GT:
    R=1
    IF Z%(AA,1)>Z%(AB,1) THEN R=2
    RETURN
  DO_GTE:
    R=1
    IF Z%(AA,1)>=Z%(AB,1) THEN R=2
    RETURN

  DO_ADD:
    T=2:L=Z%(AA,1)+Z%(AB,1):GOSUB ALLOC
    RETURN
  DO_SUB:
    T=2:L=Z%(AA,1)-Z%(AB,1):GOSUB ALLOC
    RETURN
  DO_MULT:
    T=2:L=Z%(AA,1)*Z%(AB,1):GOSUB ALLOC
    RETURN
  DO_DIV:
    T=2:L=Z%(AA,1)/Z%(AB,1):GOSUB ALLOC
    RETURN
  DO_TIME_MS:
    T=2:L=INT((TI-BT)*16.667):GOSUB ALLOC
    RETURN

  DO_LIST:
    R=AR
    Z%(R,0)=Z%(R,0)+32
    RETURN
  DO_LIST_Q:
    A=AA:GOSUB LIST_Q
    R=R+1: REM map to mal false/true
    RETURN
  DO_VECTOR:
    A=AR:T=7:GOSUB FORCE_SEQ_TYPE
    RETURN
  DO_VECTOR_Q:
    R=1
    IF (Z%(AA,0)AND31)=7 THEN R=2
    RETURN
  DO_HASH_MAP:
    A=AR:T=8:GOSUB FORCE_SEQ_TYPE
    RETURN
  DO_MAP_Q:
    R=1
    IF (Z%(AA,0)AND31)=8 THEN R=2
    RETURN
  DO_ASSOC:
    H=AA
    AR=Z%(AR,1)
    DO_ASSOC_LOOP:
      R=AR+1:GOSUB DEREF_R:K=R
      R=Z%(AR,1)+1:GOSUB DEREF_R:V=R
      Z%(H,0)=Z%(H,0)+32
      GOSUB ASSOC1:H=R
      AR=Z%(Z%(AR,1),1)
      IF AR=0 OR Z%(AR,1)=0 THEN RETURN
      GOTO DO_ASSOC_LOOP
  DO_GET:
    IF AA=0 THEN R=0:RETURN
    H=AA:K=AB:GOSUB HASHMAP_GET
    GOSUB DEREF_R
    Z%(R,0)=Z%(R,0)+32
    RETURN
  DO_CONTAINS:
    H=AA:K=AB:GOSUB HASHMAP_CONTAINS
    R=R+1
    RETURN
  DO_KEYS:
    GOTO DO_KEYS_VALS
  DO_VALS:
    AA=Z%(AA,1)
  DO_KEYS_VALS:
    REM first result list element
    T=6:L=0:N=0:GOSUB ALLOC:T2=R

    DO_KEYS_VALS_LOOP:
      IF AA=0 OR Z%(AA,1)=0 THEN R=T2:RETURN

      REM copy the value
      T1=Z%(AA+1,1)
      REM inc ref cnt of referred argument
      Z%(T1,0)=Z%(T1,0)+32
      Z%(R+1,1)=T1

      T1=R: REM save previous
      REM allocate next element
      T=6:L=0:N=0:GOSUB ALLOC
      REM point previous element to this one
      Z%(T1,1)=R

      IF Z%(Z%(AA,1),1)=0 THEN R=T2:RETURN

      AA=Z%(Z%(AA,1),1)

      GOTO DO_KEYS_VALS_LOOP

  DO_SEQUENTIAL_Q:
    R=1
    IF (Z%(AA,0)AND31)=6 OR (Z%(AA,0)AND31)=7 THEN R=2
    RETURN
  DO_CONS:
    T=6:L=AB:N=AA:GOSUB ALLOC
    RETURN
  DO_CONCAT:
    REM if empty arguments, return empty list
    IF Z%(AR,1)=0 THEN R=3:Z%(R,0)=Z%(R,0)+32:RETURN

    REM single argument
    IF Z%(Z%(AR,1),1)<>0 THEN GOTO DO_CONCAT_MULT
      REM force to list type
      A=AA:T=6:GOSUB FORCE_SEQ_TYPE
      RETURN

    REM multiple arguments
    DO_CONCAT_MULT:
      CZ=X: REM save current stack position
      REM push arguments onto the stack
      DO_CONCAT_STACK:
        R=AR+1:GOSUB DEREF_R
        X=X+1:X%(X)=R: REM push sequence
        AR=Z%(AR,1)
        IF Z%(AR,1)<>0 THEN GOTO DO_CONCAT_STACK

    REM pop last argument as our seq to prepend to
    AB=X%(X):X=X-1
    REM last arg/seq is not copied so we need to inc ref to it
    Z%(AB,0)=Z%(AB,0)+32
    DO_CONCAT_LOOP:
      IF X=CZ THEN R=AB:RETURN
      AA=X%(X):X=X-1: REM pop off next seq to prepend
      IF Z%(AA,1)=0 THEN GOTO DO_CONCAT_LOOP: REM skip empty seqs
      A=AA:B=0:C=-1:GOSUB SLICE

      REM release the terminator of new list (we skip over it)
      AY=Z%(R6,1):GOSUB RELEASE
      REM attach new list element before terminator (last actual
      REM element to the next sequence
      Z%(R6,1)=AB

      AB=R
      GOTO DO_CONCAT_LOOP
  DO_NTH:
    B=Z%(AB,1)
    A=AA:GOSUB COUNT
    IF R<=B THEN R=0:ER=-1:ER$="nth: index out of range":RETURN
    DO_NTH_LOOP:
      IF B=0 THEN GOTO DO_NTH_DONE
      B=B-1
      AA=Z%(AA,1)
      GOTO DO_NTH_LOOP
    DO_NTH_DONE:
      R=Z%(AA+1,1)
      Z%(R,0)=Z%(R,0)+32
      RETURN
  DO_FIRST:
    IF AA=0 THEN R=0:RETURN
    IF Z%(AA,1)=0 THEN R=0
    IF Z%(AA,1)<>0 THEN R=AA+1:GOSUB DEREF_R
    IF R<>0 THEN Z%(R,0)=Z%(R,0)+32
    RETURN
  DO_REST:
    IF AA=0 THEN R=3:Z%(R,0)=Z%(R,0)+32:RETURN
    IF Z%(AA,1)=0 THEN A=AA
    IF Z%(AA,1)<>0 THEN A=Z%(AA,1)
    T=6:GOSUB FORCE_SEQ_TYPE
    RETURN
  DO_EMPTY_Q:
    R=1
    IF Z%(AA,1)=0 THEN R=2
    RETURN
  DO_COUNT:
    A=AA:GOSUB COUNT
    T=2:L=R:GOSUB ALLOC
    RETURN

  DO_WITH_META:
    T=Z%(AA,0)AND31
    REM remove existing metadata first
    IF T>=16 THEN AA=Z%(AA,1):GOTO DO_WITH_META
    T=T+16:L=AA:N=AB:GOSUB ALLOC
    RETURN
  DO_META:
    IF (Z%(AA,0)AND31)<16 THEN R=0:RETURN
    R=Z%(AA+1,1)
    Z%(R,0)=Z%(R,0)+32
    RETURN
  DO_ATOM:
    T=12:L=AA:GOSUB ALLOC
    RETURN
  DO_ATOM_Q:
    R=1
    IF (Z%(AA,0)AND31)=12 THEN R=2
    RETURN
  DO_DEREF:
    R=Z%(AA,1):GOSUB DEREF_R
    Z%(R,0)=Z%(R,0)+32
    RETURN
  DO_RESET_BANG:
    R=AB
    REM release current value
    AY=Z%(AA,1):GOSUB RELEASE
    REM inc ref by 2 for atom ownership and since we are returning it
    Z%(R,0)=Z%(R,0)+64
    REM update value
    Z%(AA,1)=R
    RETURN

  REM DO_PR_MEMORY:
  REM   P1=ZT:P2=-1:GOSUB PR_MEMORY
  REM   RETURN
  REM DO_PR_MEMORY_SUMMARY:
  REM   GOSUB PR_MEMORY_SUMMARY
  REM   RETURN

  DO_EVAL:
    A=AA:E=D:CALL EVAL
    RETURN

  DO_READ_FILE:
    A$=S$(Z%(AA,1))
    GOSUB READ_FILE
    RETURN

INIT_CORE_SET_FUNCTION:
  GOSUB NATIVE_FUNCTION
  V=R:GOSUB ENV_SET_S
  RETURN

REM INIT_CORE_NS(E)
INIT_CORE_NS:
  REM create the environment mapping
  REM must match DO_FUNCTION mappings

  K$="=":A=1:GOSUB INIT_CORE_SET_FUNCTION
  K$="throw":A=2:GOSUB INIT_CORE_SET_FUNCTION
  K$="nil?":A=3:GOSUB INIT_CORE_SET_FUNCTION
  K$="true?":A=4:GOSUB INIT_CORE_SET_FUNCTION
  K$="false?":A=5:GOSUB INIT_CORE_SET_FUNCTION
  K$="string?":A=6:GOSUB INIT_CORE_SET_FUNCTION
  K$="symbol":A=7:GOSUB INIT_CORE_SET_FUNCTION
  K$="symbol?":A=8:GOSUB INIT_CORE_SET_FUNCTION
  K$="keyword":A=9:GOSUB INIT_CORE_SET_FUNCTION
  K$="keyword?":A=10:GOSUB INIT_CORE_SET_FUNCTION

  K$="pr-str":A=11:GOSUB INIT_CORE_SET_FUNCTION
  K$="str":A=12:GOSUB INIT_CORE_SET_FUNCTION
  K$="prn":A=13:GOSUB INIT_CORE_SET_FUNCTION
  K$="println":A=14:GOSUB INIT_CORE_SET_FUNCTION
  K$="read-string":A=15:GOSUB INIT_CORE_SET_FUNCTION
  K$="readline":A=16:GOSUB INIT_CORE_SET_FUNCTION
  K$="slurp":A=17:GOSUB INIT_CORE_SET_FUNCTION

  K$="<":A=18:GOSUB INIT_CORE_SET_FUNCTION
  K$="<=":A=19:GOSUB INIT_CORE_SET_FUNCTION
  K$=">":A=20:GOSUB INIT_CORE_SET_FUNCTION
  K$=">=":A=21:GOSUB INIT_CORE_SET_FUNCTION
  K$="+":A=22:GOSUB INIT_CORE_SET_FUNCTION
  K$="-":A=23:GOSUB INIT_CORE_SET_FUNCTION
  K$="*":A=24:GOSUB INIT_CORE_SET_FUNCTION
  K$="/":A=25:GOSUB INIT_CORE_SET_FUNCTION
  K$="time-ms":A=26:GOSUB INIT_CORE_SET_FUNCTION

  K$="list":A=27:GOSUB INIT_CORE_SET_FUNCTION
  K$="list?":A=28:GOSUB INIT_CORE_SET_FUNCTION
  K$="vector":A=29:GOSUB INIT_CORE_SET_FUNCTION
  K$="vector?":A=30:GOSUB INIT_CORE_SET_FUNCTION
  K$="hash-map":A=31:GOSUB INIT_CORE_SET_FUNCTION
  K$="map?":A=32:GOSUB INIT_CORE_SET_FUNCTION
  K$="assoc":A=33:GOSUB INIT_CORE_SET_FUNCTION
  K$="dissoc":A=34:GOSUB INIT_CORE_SET_FUNCTION
  K$="get":A=35:GOSUB INIT_CORE_SET_FUNCTION
  K$="contains?":A=36:GOSUB INIT_CORE_SET_FUNCTION
  K$="keys":A=37:GOSUB INIT_CORE_SET_FUNCTION
  K$="vals":A=38:GOSUB INIT_CORE_SET_FUNCTION

  K$="sequential?":A=39:GOSUB INIT_CORE_SET_FUNCTION
  K$="cons":A=40:GOSUB INIT_CORE_SET_FUNCTION
  K$="concat":A=41:GOSUB INIT_CORE_SET_FUNCTION
  K$="nth":A=42:GOSUB INIT_CORE_SET_FUNCTION
  K$="first":A=43:GOSUB INIT_CORE_SET_FUNCTION
  K$="rest":A=44:GOSUB INIT_CORE_SET_FUNCTION
  K$="empty?":A=45:GOSUB INIT_CORE_SET_FUNCTION
  K$="count":A=46:GOSUB INIT_CORE_SET_FUNCTION

  REM K$="conj":A=47:GOSUB INIT_CORE_SET_FUNCTION
  REM K$="seq":A=48:GOSUB INIT_CORE_SET_FUNCTION

  K$="with-meta":A=49:GOSUB INIT_CORE_SET_FUNCTION
  K$="meta":A=50:GOSUB INIT_CORE_SET_FUNCTION
  K$="atom":A=51:GOSUB INIT_CORE_SET_FUNCTION
  K$="atom?":A=52:GOSUB INIT_CORE_SET_FUNCTION
  K$="deref":A=53:GOSUB INIT_CORE_SET_FUNCTION
  K$="reset!":A=54:GOSUB INIT_CORE_SET_FUNCTION

  K$="eval":A=55:GOSUB INIT_CORE_SET_FUNCTION
  K$="read-file":A=56:GOSUB INIT_CORE_SET_FUNCTION

  REM these are in DO_TCO_FUNCTION
  K$="apply":A=61:GOSUB INIT_CORE_SET_FUNCTION
  K$="map":A=62:GOSUB INIT_CORE_SET_FUNCTION
  K$="swap!":A=63:GOSUB INIT_CORE_SET_FUNCTION

  RETURN
Commit	Line	Data
01e8850d	1	REM APPLY should really be in types.in.bas but it is here because it
af621e3a JM	2	REM calls DO_TCO_FUNCTION so it will cause syntax errors for steps1-3
af621e3a JM	3	REM if it is in types.in.bas because there are unresolved labels.
01e8850d JM	4
	5	REM APPLY(F, AR) -> R
	6	REM - restores E
	7	REM - call using GOTO and with return label/address on the stack
af621e3a	8	SUB APPLY
01e8850d JM	9	REM if metadata, get the actual object
	10	IF (Z%(F,0)AND31)>=16 THEN F=Z%(F,1)
	11
	12	IF (Z%(F,0)AND31)=9 THEN GOTO APPLY_FUNCTION
	13	IF (Z%(F,0)AND31)=10 THEN GOTO APPLY_MAL_FUNCTION
	14	IF (Z%(F,0)AND31)=11 THEN GOTO APPLY_MAL_FUNCTION
	15
	16	APPLY_FUNCTION:
	17	REM regular function
af621e3a	18	IF Z%(F,1)<60 THEN GOSUB DO_FUNCTION:GOTO APPLY_DONE
01e8850d	19	REM for recur functions (apply, map, swap!), use GOTO
af621e3a	20	IF Z%(F,1)>60 THEN CALL DO_TCO_FUNCTION
01e8850d JM	21	GOTO APPLY_DONE
	22
	23	APPLY_MAL_FUNCTION:
	24	X=X+1:X%(X)=E: REM save the current environment
	25
	26	REM create new environ using env and params stored in the
	27	REM function and bind the params to the apply arguments
	28	O=Z%(F+1,1):BI=Z%(F+1,0):EX=AR:GOSUB ENV_NEW_BINDS
	29
af621e3a	30	A=Z%(F,1):E=R:CALL EVAL
01e8850d JM	31
	32	AY=E:GOSUB RELEASE: REM release the new environment
	33
	34	E=X%(X):X=X-1: REM pop/restore the saved environment
	35
	36	APPLY_DONE:
af621e3a	37	END SUB
01e8850d JM	38
	39
	40	REM DO_TCO_FUNCTION(F, AR)
af621e3a	41	SUB DO_TCO_FUNCTION
01e8850d JM	42	FF=Z%(F,1)
	43
	44	REM Get argument values
	45	R=AR+1:GOSUB DEREF_R:AA=R
	46	R=Z%(AR,1)+1:GOSUB DEREF_R:AB=R
	47
	48	ON FF-60 GOTO DO_APPLY,DO_MAP,DO_SWAP_BANG
	49
	50	DO_APPLY:
	51	F=AA
	52	AR=Z%(AR,1)
	53	A=AR:GOSUB COUNT:R4=R
	54
	55	A=Z%(AR+1,1)
	56	REM no intermediate args, but not a list, so convert it first
	57	IF R4<=1 AND (Z%(A,0)AND31)<>6 THEN T=6:GOSUB FORCE_SEQ_TYPE:GOTO DO_APPLY_2
	58	REM no intermediate args, just call APPLY directly
	59	IF R4<=1 THEN GOTO DO_APPLY_1
	60
	61	REM prepend intermediate args to final args element
	62	A=AR:B=0:C=R4-1:GOSUB SLICE
	63	REM release the terminator of new list (we skip over it)
	64	AY=Z%(R6,1):GOSUB RELEASE
	65	REM attach end of slice to final args element
	66	Z%(R6,1)=Z%(A+1,1)
	67	Z%(Z%(A+1,1),0)=Z%(Z%(A+1,1),0)+32
	68
	69	GOTO DO_APPLY_2
	70
	71	DO_APPLY_1:
af621e3a	72	AR=A:CALL APPLY
01e8850d	73
af621e3a	74	GOTO DO_TCO_FUNCTION_DONE
01e8850d JM	75
	76	DO_APPLY_2:
	77	X=X+1:X%(X)=R: REM push/save new args for release
	78
af621e3a	79	AR=R:CALL APPLY
01e8850d JM	80
01e8850d JM	81	AY=X%(X):X=X-1:GOSUB RELEASE: REM pop/release new args
af621e3a	82	GOTO DO_TCO_FUNCTION_DONE
01e8850d JM	83
	84	DO_MAP:
	85	F=AA
	86
	87	REM first result list element
	88	T=6:L=0:N=0:GOSUB ALLOC
	89
	90	REM push future return val, prior entry, F and AB
	91	X=X+4:X%(X-3)=R:X%(X-2)=0:X%(X-1)=F:X%(X)=AB
	92
	93	DO_MAP_LOOP:
	94	REM set previous to current if not the first element
	95	IF X%(X-2)<>0 THEN Z%(X%(X-2),1)=R
	96	REM update previous reference to current
	97	X%(X-2)=R
	98
	99	IF Z%(AB,1)=0 THEN GOTO DO_MAP_DONE
	100
	101	REM create argument list for apply call
	102	Z%(3,0)=Z%(3,0)+32
	103	REM inc ref cnt of referred argument
	104	T=6:L=3:N=Z%(AB+1,1):GOSUB ALLOC
	105
	106	REM push argument list
	107	X=X+1:X%(X)=R
	108
af621e3a	109	AR=R:CALL APPLY
01e8850d JM	110
	111	REM pop apply args are release them
	112	AY=X%(X):X=X-1:GOSUB RELEASE
	113
	114	REM set the result value
	115	Z%(X%(X-2)+1,1)=R
	116
	117	REM restore F
	118	F=X%(X-1)
	119
	120	REM update AB to next source element
	121	X%(X)=Z%(X%(X),1)
	122	AB=X%(X)
	123
	124	REM allocate next element
	125	T=6:L=0:N=0:GOSUB ALLOC
	126
	127	GOTO DO_MAP_LOOP
	128
	129	DO_MAP_DONE:
	130	REM get return val
	131	R=X%(X-3)
	132	REM pop everything off stack
	133	X=X-4
af621e3a	134	GOTO DO_TCO_FUNCTION_DONE
01e8850d JM	135
	136
	137	DO_SWAP_BANG:
	138	F=AB
	139
	140	REM add atom to front of the args list
	141	T=6:L=Z%(Z%(AR,1),1):N=Z%(AA,1):GOSUB ALLOC: REM cons
	142	AR=R
	143
	144	REM push args for release after
	145	X=X+1:X%(X)=AR
	146
	147	REM push atom
	148	X=X+1:X%(X)=AA
	149
af621e3a	150	CALL APPLY
01e8850d JM	151
	152	REM pop atom
	153	AA=X%(X):X=X-1
	154
	155	REM pop and release args
	156	AY=X%(X):X=X-1:GOSUB RELEASE
	157
	158	REM use reset to update the value
	159	AB=R:GOSUB DO_RESET_BANG
	160
	161	REM but decrease ref cnt of return by 1 (not sure why)
	162	AY=R:GOSUB RELEASE
	163
af621e3a	164	GOTO DO_TCO_FUNCTION_DONE
01e8850d	165
af621e3a JM	166	DO_TCO_FUNCTION_DONE:
af621e3a JM	167	END SUB
01e8850d	168
241d5d57	169
cc9dbd92	170	REM DO_FUNCTION(F, AR)
241d5d57 JM	171	DO_FUNCTION:
241d5d57 JM	172	REM Get the function number
cc9dbd92	173	FF=Z%(F,1)
241d5d57 JM	174
241d5d57 JM	175	REM Get argument values
cc9dbd92 JM	176	R=AR+1:GOSUB DEREF_R:AA=R
cc9dbd92 JM	177	R=Z%(AR,1)+1:GOSUB DEREF_R:AB=R
241d5d57 JM	178
241d5d57 JM	179	REM Switch on the function number
0e508fa5	180	IF FF>59 THEN ER=-1:ER$="unknown function"+STR$(FF):RETURN
01e8850d	181	ON FF/10+1 GOTO DO_1_9,DO_10_19,DO_20_29,DO_30_39,DO_40_49,DO_50_56
a742287e JM	182
	183	DO_1_9:
	184	ON FF GOTO DO_EQUAL_Q,DO_THROW,DO_NIL_Q,DO_TRUE_Q,DO_FALSE_Q,DO_STRING_Q,DO_SYMBOL,DO_SYMBOL_Q,DO_KEYWORD
	185	DO_10_19:
	186	ON FF-9 GOTO DO_KEYWORD_Q,DO_PR_STR,DO_STR,DO_PRN,DO_PRINTLN,DO_READ_STRING,DO_READLINE,DO_SLURP,DO_LT,DO_LTE
	187	DO_20_29:
	188	ON FF-19 GOTO DO_GT,DO_GTE,DO_ADD,DO_SUB,DO_MULT,DO_DIV,DO_TIME_MS,DO_LIST,DO_LIST_Q,DO_VECTOR
	189	DO_30_39:
bbab5c5d	190	ON FF-29 GOTO DO_VECTOR_Q,DO_HASH_MAP,DO_MAP_Q,DO_ASSOC,DO_THROW,DO_GET,DO_CONTAINS,DO_KEYS,DO_VALS,DO_SEQUENTIAL_Q
a742287e	191	DO_40_49:
01e8850d JM	192	ON FF-39 GOTO DO_CONS,DO_CONCAT,DO_NTH,DO_FIRST,DO_REST,DO_EMPTY_Q,DO_COUNT,DO_THROW,DO_THROW,DO_WITH_META
	193	DO_50_56:
	194	ON FF-49 GOTO DO_META,DO_ATOM,DO_ATOM_Q,DO_DEREF,DO_RESET_BANG,DO_EVAL,DO_READ_FILE
241d5d57 JM	195
241d5d57 JM	196	DO_EQUAL_Q:
cc9dbd92 JM	197	A=AA:B=AB:GOSUB EQUAL_Q
cc9dbd92 JM	198	R=R+1
241d5d57	199	RETURN
5e5ca0d4	200	DO_THROW:
cc9dbd92	201	ER=AA
bbab5c5d	202	Z%(ER,0)=Z%(ER,0)+32
cc9dbd92	203	R=0
5e5ca0d4 JM	204	RETURN
5e5ca0d4 JM	205	DO_NIL_Q:
cc9dbd92 JM	206	R=1
cc9dbd92 JM	207	IF AA=0 THEN R=2
5e5ca0d4 JM	208	RETURN
5e5ca0d4 JM	209	DO_TRUE_Q:
cc9dbd92 JM	210	R=1
cc9dbd92 JM	211	IF AA=2 THEN R=2
5e5ca0d4 JM	212	RETURN
5e5ca0d4 JM	213	DO_FALSE_Q:
cc9dbd92 JM	214	R=1
cc9dbd92 JM	215	IF AA=1 THEN R=2
5e5ca0d4 JM	216	RETURN
5e5ca0d4 JM	217	DO_STRING_Q:
cc9dbd92	218	R=1
bbab5c5d JM	219	IF (Z%(AA,0)AND31)<>4 THEN RETURN
	220	IF MID$(S$(Z%(AA,1)),1,1)=CHR$(127) THEN RETURN
	221	R=2
5e5ca0d4 JM	222	RETURN
5e5ca0d4 JM	223	DO_SYMBOL:
a742287e	224	T=5:L=Z%(AA,1):GOSUB ALLOC
5e5ca0d4 JM	225	RETURN
5e5ca0d4 JM	226	DO_SYMBOL_Q:
cc9dbd92	227	R=1
bbab5c5d	228	IF (Z%(AA,0)AND31)=5 THEN R=2
5e5ca0d4	229	RETURN
a742287e JM	230	DO_KEYWORD:
	231	A=Z%(AA,1)
	232	AS$=S$(A)
	233	IF MID$(AS$,1,1)<>CHR$(127) THEN AS$=CHR$(127)+AS$
	234	GOSUB STRING_
	235	T=4:L=R:GOSUB ALLOC
	236	RETURN
	237	DO_KEYWORD_Q:
	238	R=1
bbab5c5d	239	IF (Z%(AA,0)AND31)<>4 THEN RETURN
a742287e JM	240	IF MID$(S$(Z%(AA,1)),1,1)<>CHR$(127) THEN RETURN
	241	R=2
	242	RETURN
241d5d57 JM	243
241d5d57 JM	244	DO_PR_STR:
cc9dbd92	245	AZ=AR:PR=1:SE$=" ":GOSUB PR_STR_SEQ
a742287e	246	AS$=R$:T=4:GOSUB STRING
241d5d57 JM	247	RETURN
241d5d57 JM	248	DO_STR:
cc9dbd92	249	AZ=AR:PR=0:SE$="":GOSUB PR_STR_SEQ
a742287e	250	AS$=R$:T=4:GOSUB STRING
241d5d57 JM	251	RETURN
241d5d57 JM	252	DO_PRN:
cc9dbd92	253	AZ=AR:PR=1:SE$=" ":GOSUB PR_STR_SEQ
241d5d57	254	PRINT R$
cc9dbd92	255	R=0
241d5d57 JM	256	RETURN
241d5d57 JM	257	DO_PRINTLN:
cc9dbd92	258	AZ=AR:PR=0:SE$=" ":GOSUB PR_STR_SEQ
241d5d57	259	PRINT R$
cc9dbd92	260	R=0
241d5d57	261	RETURN
85d70fb7	262	DO_READ_STRING:
cc9dbd92	263	A$=S$(Z%(AA,1))
85d70fb7 JM	264	GOSUB READ_STR
85d70fb7 JM	265	RETURN
30a3d828	266	DO_READLINE:
cc9dbd92 JM	267	A$=S$(Z%(AA,1)):GOSUB READLINE
	268	IF EOF=1 THEN EOF=0:R=0:RETURN
	269	AS$=R$:T=4:GOSUB STRING
30a3d828	270	RETURN
85d70fb7 JM	271	DO_SLURP:
85d70fb7 JM	272	R$=""
cc9dbd92 JM	273	REM OPEN 1,8,2,S$(Z%(AA,1))+",SEQ,R"
	274	REM OPEN 1,8,2,S$(Z%(AA,1))
	275	OPEN 1,8,0,S$(Z%(AA,1))
85d70fb7 JM	276	DO_SLURP_LOOP:
	277	A$=""
	278	GET#1,A$
	279	IF ASC(A$)=10 THEN R$=R$+CHR$(13)
	280	IF (ASC(A$)<>10) AND (A$<>"") THEN R$=R$+A$
	281	IF (ST AND 64) THEN GOTO DO_SLURP_DONE
cc9dbd92	282	IF (ST AND 255) THEN ER=-1:ER$="File read error "+STR$(ST):RETURN
85d70fb7 JM	283	GOTO DO_SLURP_LOOP
	284	DO_SLURP_DONE:
	285	CLOSE 1
a742287e	286	AS$=R$:T=4:GOSUB STRING
85d70fb7	287	RETURN
241d5d57 JM	288
241d5d57 JM	289	DO_LT:
cc9dbd92 JM	290	R=1
cc9dbd92 JM	291	IF Z%(AA,1)<Z%(AB,1) THEN R=2
241d5d57 JM	292	RETURN
241d5d57 JM	293	DO_LTE:
cc9dbd92 JM	294	R=1
cc9dbd92 JM	295	IF Z%(AA,1)<=Z%(AB,1) THEN R=2
241d5d57 JM	296	RETURN
241d5d57 JM	297	DO_GT:
cc9dbd92 JM	298	R=1
cc9dbd92 JM	299	IF Z%(AA,1)>Z%(AB,1) THEN R=2
241d5d57 JM	300	RETURN
241d5d57 JM	301	DO_GTE:
cc9dbd92 JM	302	R=1
cc9dbd92 JM	303	IF Z%(AA,1)>=Z%(AB,1) THEN R=2
241d5d57 JM	304	RETURN
	305
	306	DO_ADD:
a742287e	307	T=2:L=Z%(AA,1)+Z%(AB,1):GOSUB ALLOC
241d5d57 JM	308	RETURN
241d5d57 JM	309	DO_SUB:
a742287e	310	T=2:L=Z%(AA,1)-Z%(AB,1):GOSUB ALLOC
241d5d57 JM	311	RETURN
241d5d57 JM	312	DO_MULT:
a742287e	313	T=2:L=Z%(AA,1)*Z%(AB,1):GOSUB ALLOC
241d5d57 JM	314	RETURN
241d5d57 JM	315	DO_DIV:
a742287e	316	T=2:L=Z%(AA,1)/Z%(AB,1):GOSUB ALLOC
241d5d57	317	RETURN
60ef223c	318	DO_TIME_MS:
01e8850d	319	T=2:L=INT((TI-BT)*16.667):GOSUB ALLOC
60ef223c	320	RETURN
241d5d57 JM	321
241d5d57 JM	322	DO_LIST:
cc9dbd92	323	R=AR
bbab5c5d	324	Z%(R,0)=Z%(R,0)+32
241d5d57 JM	325	RETURN
241d5d57 JM	326	DO_LIST_Q:
cc9dbd92 JM	327	A=AA:GOSUB LIST_Q
cc9dbd92 JM	328	R=R+1: REM map to mal false/true
241d5d57	329	RETURN
5e5ca0d4	330	DO_VECTOR:
a742287e	331	A=AR:T=7:GOSUB FORCE_SEQ_TYPE
5e5ca0d4 JM	332	RETURN
5e5ca0d4 JM	333	DO_VECTOR_Q:
cc9dbd92	334	R=1
bbab5c5d	335	IF (Z%(AA,0)AND31)=7 THEN R=2
5e5ca0d4 JM	336	RETURN
5e5ca0d4 JM	337	DO_HASH_MAP:
a742287e	338	A=AR:T=8:GOSUB FORCE_SEQ_TYPE
5e5ca0d4 JM	339	RETURN
5e5ca0d4 JM	340	DO_MAP_Q:
cc9dbd92	341	R=1
bbab5c5d JM	342	IF (Z%(AA,0)AND31)=8 THEN R=2
	343	RETURN
	344	DO_ASSOC:
	345	H=AA
	346	AR=Z%(AR,1)
	347	DO_ASSOC_LOOP:
	348	R=AR+1:GOSUB DEREF_R:K=R
	349	R=Z%(AR,1)+1:GOSUB DEREF_R:V=R
	350	Z%(H,0)=Z%(H,0)+32
	351	GOSUB ASSOC1:H=R
	352	AR=Z%(Z%(AR,1),1)
	353	IF AR=0 OR Z%(AR,1)=0 THEN RETURN
	354	GOTO DO_ASSOC_LOOP
	355	DO_GET:
	356	IF AA=0 THEN R=0:RETURN
	357	H=AA:K=AB:GOSUB HASHMAP_GET
	358	GOSUB DEREF_R
	359	Z%(R,0)=Z%(R,0)+32
5e5ca0d4	360	RETURN
bbab5c5d JM	361	DO_CONTAINS:
	362	H=AA:K=AB:GOSUB HASHMAP_CONTAINS
	363	R=R+1
	364	RETURN
	365	DO_KEYS:
	366	GOTO DO_KEYS_VALS
	367	DO_VALS:
	368	AA=Z%(AA,1)
	369	DO_KEYS_VALS:
	370	REM first result list element
	371	T=6:L=0:N=0:GOSUB ALLOC:T2=R
	372
	373	DO_KEYS_VALS_LOOP:
	374	IF AA=0 OR Z%(AA,1)=0 THEN R=T2:RETURN
	375
	376	REM copy the value
	377	T1=Z%(AA+1,1)
	378	REM inc ref cnt of referred argument
	379	Z%(T1,0)=Z%(T1,0)+32
	380	Z%(R+1,1)=T1
	381
	382	T1=R: REM save previous
	383	REM allocate next element
	384	T=6:L=0:N=0:GOSUB ALLOC
	385	REM point previous element to this one
	386	Z%(T1,1)=R
	387
	388	IF Z%(Z%(AA,1),1)=0 THEN R=T2:RETURN
	389
	390	AA=Z%(Z%(AA,1),1)
	391
	392	GOTO DO_KEYS_VALS_LOOP
241d5d57	393
5e5ca0d4	394	DO_SEQUENTIAL_Q:
cc9dbd92	395	R=1
bbab5c5d	396	IF (Z%(AA,0)AND31)=6 OR (Z%(AA,0)AND31)=7 THEN R=2
5e5ca0d4	397	RETURN
85d70fb7	398	DO_CONS:
a742287e	399	T=6:L=AB:N=AA:GOSUB ALLOC
85d70fb7	400	RETURN
9e8f5211 JM	401	DO_CONCAT:
9e8f5211 JM	402	REM if empty arguments, return empty list
bbab5c5d	403	IF Z%(AR,1)=0 THEN R=3:Z%(R,0)=Z%(R,0)+32:RETURN
9e8f5211 JM	404
9e8f5211 JM	405	REM single argument
cc9dbd92	406	IF Z%(Z%(AR,1),1)<>0 THEN GOTO DO_CONCAT_MULT
a742287e JM	407	REM force to list type
a742287e JM	408	A=AA:T=6:GOSUB FORCE_SEQ_TYPE
9e8f5211 JM	409	RETURN
	410
	411	REM multiple arguments
	412	DO_CONCAT_MULT:
bbab5c5d	413	CZ=X: REM save current stack position
9e8f5211 JM	414	REM push arguments onto the stack
9e8f5211 JM	415	DO_CONCAT_STACK:
cc9dbd92	416	R=AR+1:GOSUB DEREF_R
bbab5c5d	417	X=X+1:X%(X)=R: REM push sequence
cc9dbd92 JM	418	AR=Z%(AR,1)
cc9dbd92 JM	419	IF Z%(AR,1)<>0 THEN GOTO DO_CONCAT_STACK
9e8f5211 JM	420
9e8f5211 JM	421	REM pop last argument as our seq to prepend to
bbab5c5d	422	AB=X%(X):X=X-1
9e8f5211	423	REM last arg/seq is not copied so we need to inc ref to it
bbab5c5d	424	Z%(AB,0)=Z%(AB,0)+32
9e8f5211	425	DO_CONCAT_LOOP:
bbab5c5d JM	426	IF X=CZ THEN R=AB:RETURN
bbab5c5d JM	427	AA=X%(X):X=X-1: REM pop off next seq to prepend
cc9dbd92 JM	428	IF Z%(AA,1)=0 THEN GOTO DO_CONCAT_LOOP: REM skip empty seqs
cc9dbd92 JM	429	A=AA:B=0:C=-1:GOSUB SLICE
9e8f5211 JM	430
9e8f5211 JM	431	REM release the terminator of new list (we skip over it)
cc9dbd92	432	AY=Z%(R6,1):GOSUB RELEASE
9e8f5211 JM	433	REM attach new list element before terminator (last actual
9e8f5211 JM	434	REM element to the next sequence
cc9dbd92	435	Z%(R6,1)=AB
9e8f5211	436
cc9dbd92	437	AB=R
9e8f5211	438	GOTO DO_CONCAT_LOOP
60ef223c	439	DO_NTH:
cc9dbd92 JM	440	B=Z%(AB,1)
	441	A=AA:GOSUB COUNT
	442	IF R<=B THEN R=0:ER=-1:ER$="nth: index out of range":RETURN
70f29a2b	443	DO_NTH_LOOP:
cc9dbd92 JM	444	IF B=0 THEN GOTO DO_NTH_DONE
	445	B=B-1
	446	AA=Z%(AA,1)
70f29a2b JM	447	GOTO DO_NTH_LOOP
70f29a2b JM	448	DO_NTH_DONE:
cc9dbd92	449	R=Z%(AA+1,1)
bbab5c5d	450	Z%(R,0)=Z%(R,0)+32
70f29a2b	451	RETURN
85d70fb7	452	DO_FIRST:
a742287e	453	IF AA=0 THEN R=0:RETURN
cc9dbd92 JM	454	IF Z%(AA,1)=0 THEN R=0
cc9dbd92 JM	455	IF Z%(AA,1)<>0 THEN R=AA+1:GOSUB DEREF_R
bbab5c5d	456	IF R<>0 THEN Z%(R,0)=Z%(R,0)+32
85d70fb7 JM	457	RETURN
85d70fb7 JM	458	DO_REST:
bbab5c5d	459	IF AA=0 THEN R=3:Z%(R,0)=Z%(R,0)+32:RETURN
a742287e JM	460	IF Z%(AA,1)=0 THEN A=AA
	461	IF Z%(AA,1)<>0 THEN A=Z%(AA,1)
	462	T=6:GOSUB FORCE_SEQ_TYPE
85d70fb7	463	RETURN
241d5d57	464	DO_EMPTY_Q:
cc9dbd92 JM	465	R=1
cc9dbd92 JM	466	IF Z%(AA,1)=0 THEN R=2
241d5d57 JM	467	RETURN
241d5d57 JM	468	DO_COUNT:
a742287e JM	469	A=AA:GOSUB COUNT
a742287e JM	470	T=2:L=R:GOSUB ALLOC
241d5d57 JM	471	RETURN
241d5d57 JM	472
bbab5c5d JM	473	DO_WITH_META:
	474	T=Z%(AA,0)AND31
	475	REM remove existing metadata first
	476	IF T>=16 THEN AA=Z%(AA,1):GOTO DO_WITH_META
	477	T=T+16:L=AA:N=AB:GOSUB ALLOC
	478	RETURN
	479	DO_META:
	480	IF (Z%(AA,0)AND31)<16 THEN R=0:RETURN
	481	R=Z%(AA+1,1)
	482	Z%(R,0)=Z%(R,0)+32
	483	RETURN
85d70fb7	484	DO_ATOM:
a742287e	485	T=12:L=AA:GOSUB ALLOC
85d70fb7 JM	486	RETURN
85d70fb7 JM	487	DO_ATOM_Q:
cc9dbd92	488	R=1
bbab5c5d	489	IF (Z%(AA,0)AND31)=12 THEN R=2
85d70fb7 JM	490	RETURN
85d70fb7 JM	491	DO_DEREF:
cc9dbd92	492	R=Z%(AA,1):GOSUB DEREF_R
bbab5c5d	493	Z%(R,0)=Z%(R,0)+32
85d70fb7 JM	494	RETURN
85d70fb7 JM	495	DO_RESET_BANG:
cc9dbd92	496	R=AB
85d70fb7	497	REM release current value
cc9dbd92	498	AY=Z%(AA,1):GOSUB RELEASE
85d70fb7	499	REM inc ref by 2 for atom ownership and since we are returning it
bbab5c5d	500	Z%(R,0)=Z%(R,0)+64
85d70fb7	501	REM update value
cc9dbd92	502	Z%(AA,1)=R
85d70fb7	503	RETURN
85d70fb7	504
01e8850d JM	505	REM DO_PR_MEMORY:
	506	REM P1=ZT:P2=-1:GOSUB PR_MEMORY
	507	REM RETURN
	508	REM DO_PR_MEMORY_SUMMARY:
	509	REM GOSUB PR_MEMORY_SUMMARY
	510	REM RETURN
241d5d57	511
85d70fb7	512	DO_EVAL:
af621e3a	513	A=AA:E=D:CALL EVAL
85d70fb7 JM	514	RETURN
85d70fb7 JM	515
0e508fa5 JM	516	DO_READ_FILE:
	517	A$=S$(Z%(AA,1))
	518	GOSUB READ_FILE
	519	RETURN
	520
241d5d57 JM	521	INIT_CORE_SET_FUNCTION:
241d5d57 JM	522	GOSUB NATIVE_FUNCTION
cc9dbd92	523	V=R:GOSUB ENV_SET_S
241d5d57 JM	524	RETURN
241d5d57 JM	525
cc9dbd92	526	REM INIT_CORE_NS(E)
241d5d57 JM	527	INIT_CORE_NS:
	528	REM create the environment mapping
	529	REM must match DO_FUNCTION mappings
	530
cc9dbd92 JM	531	K$="=":A=1:GOSUB INIT_CORE_SET_FUNCTION
	532	K$="throw":A=2:GOSUB INIT_CORE_SET_FUNCTION
	533	K$="nil?":A=3:GOSUB INIT_CORE_SET_FUNCTION
	534	K$="true?":A=4:GOSUB INIT_CORE_SET_FUNCTION
	535	K$="false?":A=5:GOSUB INIT_CORE_SET_FUNCTION
	536	K$="string?":A=6:GOSUB INIT_CORE_SET_FUNCTION
	537	K$="symbol":A=7:GOSUB INIT_CORE_SET_FUNCTION
	538	K$="symbol?":A=8:GOSUB INIT_CORE_SET_FUNCTION
a742287e JM	539	K$="keyword":A=9:GOSUB INIT_CORE_SET_FUNCTION
a742287e JM	540	K$="keyword?":A=10:GOSUB INIT_CORE_SET_FUNCTION
cc9dbd92 JM	541
	542	K$="pr-str":A=11:GOSUB INIT_CORE_SET_FUNCTION
	543	K$="str":A=12:GOSUB INIT_CORE_SET_FUNCTION
	544	K$="prn":A=13:GOSUB INIT_CORE_SET_FUNCTION
	545	K$="println":A=14:GOSUB INIT_CORE_SET_FUNCTION
	546	K$="read-string":A=15:GOSUB INIT_CORE_SET_FUNCTION
	547	K$="readline":A=16:GOSUB INIT_CORE_SET_FUNCTION
	548	K$="slurp":A=17:GOSUB INIT_CORE_SET_FUNCTION
	549
	550	K$="<":A=18:GOSUB INIT_CORE_SET_FUNCTION
	551	K$="<=":A=19:GOSUB INIT_CORE_SET_FUNCTION
	552	K$=">":A=20:GOSUB INIT_CORE_SET_FUNCTION
	553	K$=">=":A=21:GOSUB INIT_CORE_SET_FUNCTION
	554	K$="+":A=22:GOSUB INIT_CORE_SET_FUNCTION
	555	K$="-":A=23:GOSUB INIT_CORE_SET_FUNCTION
	556	K$="*":A=24:GOSUB INIT_CORE_SET_FUNCTION
	557	K$="/":A=25:GOSUB INIT_CORE_SET_FUNCTION
	558	K$="time-ms":A=26:GOSUB INIT_CORE_SET_FUNCTION
	559
	560	K$="list":A=27:GOSUB INIT_CORE_SET_FUNCTION
	561	K$="list?":A=28:GOSUB INIT_CORE_SET_FUNCTION
	562	K$="vector":A=29:GOSUB INIT_CORE_SET_FUNCTION
	563	K$="vector?":A=30:GOSUB INIT_CORE_SET_FUNCTION
	564	K$="hash-map":A=31:GOSUB INIT_CORE_SET_FUNCTION
	565	K$="map?":A=32:GOSUB INIT_CORE_SET_FUNCTION
a742287e JM	566	K$="assoc":A=33:GOSUB INIT_CORE_SET_FUNCTION
	567	K$="dissoc":A=34:GOSUB INIT_CORE_SET_FUNCTION
	568	K$="get":A=35:GOSUB INIT_CORE_SET_FUNCTION
	569	K$="contains?":A=36:GOSUB INIT_CORE_SET_FUNCTION
	570	K$="keys":A=37:GOSUB INIT_CORE_SET_FUNCTION
	571	K$="vals":A=38:GOSUB INIT_CORE_SET_FUNCTION
cc9dbd92 JM	572
	573	K$="sequential?":A=39:GOSUB INIT_CORE_SET_FUNCTION
	574	K$="cons":A=40:GOSUB INIT_CORE_SET_FUNCTION
	575	K$="concat":A=41:GOSUB INIT_CORE_SET_FUNCTION
	576	K$="nth":A=42:GOSUB INIT_CORE_SET_FUNCTION
	577	K$="first":A=43:GOSUB INIT_CORE_SET_FUNCTION
	578	K$="rest":A=44:GOSUB INIT_CORE_SET_FUNCTION
	579	K$="empty?":A=45:GOSUB INIT_CORE_SET_FUNCTION
	580	K$="count":A=46:GOSUB INIT_CORE_SET_FUNCTION
cc9dbd92	581
01e8850d JM	582	REM K$="conj":A=47:GOSUB INIT_CORE_SET_FUNCTION
	583	REM K$="seq":A=48:GOSUB INIT_CORE_SET_FUNCTION
	584
	585	K$="with-meta":A=49:GOSUB INIT_CORE_SET_FUNCTION
	586	K$="meta":A=50:GOSUB INIT_CORE_SET_FUNCTION
	587	K$="atom":A=51:GOSUB INIT_CORE_SET_FUNCTION
	588	K$="atom?":A=52:GOSUB INIT_CORE_SET_FUNCTION
	589	K$="deref":A=53:GOSUB INIT_CORE_SET_FUNCTION
	590	K$="reset!":A=54:GOSUB INIT_CORE_SET_FUNCTION
cc9dbd92	591
01e8850d JM	592	K$="eval":A=55:GOSUB INIT_CORE_SET_FUNCTION
01e8850d JM	593	K$="read-file":A=56:GOSUB INIT_CORE_SET_FUNCTION
241d5d57	594
01e8850d JM	595	REM these are in DO_TCO_FUNCTION
	596	K$="apply":A=61:GOSUB INIT_CORE_SET_FUNCTION
	597	K$="map":A=62:GOSUB INIT_CORE_SET_FUNCTION
	598	K$="swap!":A=63:GOSUB INIT_CORE_SET_FUNCTION
0e508fa5	599
241d5d57	600	RETURN