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


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>=61 THEN ER=-1:ER$="unknown function"+STR$(FF):RETURN
  IF FF>=53 THEN DO_53
  IF FF>=39 THEN DO_39
  IF FF>=27 THEN DO_27
  IF FF>=18 THEN DO_18
  IF FF>=11 THEN DO_11

  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_11:
  ON FF-10 GOTO DO_PR_STR,DO_STR,DO_PRN,DO_PRINTLN,DO_READ_STRING,DO_READLINE,DO_SLURP
  DO_18:
  ON FF-17 GOTO DO_LT,DO_LTE,DO_GT,DO_GTE,DO_ADD,DO_SUB,DO_MULT,DO_DIV,DO_TIME_MS
  DO_27:
  ON FF-26 GOTO DO_LIST,DO_LIST_Q,DO_VECTOR,DO_VECTOR_Q,DO_HASH_MAP,DO_MAP_Q
  DO_39:
  ON FF-38 GOTO DO_SEQUENTIAL_Q,DO_CONS,DO_CONCAT,DO_NTH,DO_FIRST,DO_REST,DO_EMPTY_Q,DO_COUNT,DO_APPLY,DO_MAP
  DO_53:
  ON FF-52 GOTO DO_ATOM,DO_ATOM_Q,DO_DEREF,DO_RESET_BANG,DO_SWAP_BANG,DO_PR_MEMORY,DO_PR_MEMORY_SUMMARY,DO_EVAL

  DO_EQUAL_Q:
    A=AA:B=AB:GOSUB EQUAL_Q
    R=R+1
    RETURN
  DO_THROW:
    ER=AA
    Z%(ER,0)=Z%(ER,0)+16
    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)AND15)=4 THEN R=2
    RETURN
  DO_SYMBOL:
    R=0
    RETURN
  DO_SYMBOL_Q:
    R=1
    IF (Z%(AA,0)AND15)=5 THEN R=2
    RETURN

  DO_PR_STR:
    AZ=AR:PR=1:SE$=" ":GOSUB PR_STR_SEQ
    AS$=R$:T=4+16:GOSUB STRING
    RETURN
  DO_STR:
    AZ=AR:PR=0:SE$="":GOSUB PR_STR_SEQ
    AS$=R$:T=4+16: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
    Z%(R,0)=Z%(R,0)+16
    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+16: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:
    SZ=1:GOSUB ALLOC
    Z%(R,0)=2+16
    Z%(R,1)=Z%(AA,1)+Z%(AB,1)
    RETURN
  DO_SUB:
    SZ=1:GOSUB ALLOC
    Z%(R,0)=2+16
    Z%(R,1)=Z%(AA,1)-Z%(AB,1)
    RETURN
  DO_MULT:
    SZ=1:GOSUB ALLOC
    Z%(R,0)=2+16
    Z%(R,1)=Z%(AA,1)*Z%(AB,1)
    RETURN
  DO_DIV:
    SZ=1:GOSUB ALLOC
    Z%(R,0)=2+16
    Z%(R,1)=Z%(AA,1)/Z%(AB,1)
    RETURN
  DO_TIME_MS:
    R=0
    RETURN

  DO_LIST:
    R=AR
    Z%(R,0)=Z%(R,0)+16
    RETURN
  DO_LIST_Q:
    A=AA:GOSUB LIST_Q
    R=R+1: REM map to mal false/true
    RETURN
  DO_VECTOR:
    R=0
    RETURN
  DO_VECTOR_Q:
    R=1
    IF (Z%(AA,0)AND15)=7 THEN R=2
    RETURN
  DO_HASH_MAP:
    R=0
    RETURN
  DO_MAP_Q:
    R=1
    IF (Z%(AA,0)AND15)=8 THEN R=2
    RETURN

  DO_SEQUENTIAL_Q:
    R=1
    IF (Z%(AA,0)AND15)=6 OR (Z%(AA,0)AND15)=7 THEN R=2
    RETURN
  DO_CONS:
    A=AA:B=AB:GOSUB CONS
    RETURN
  DO_CONCAT:
    REM if empty arguments, return empty list
    IF Z%(AR,1)=0 THEN R=3:Z%(R,0)=Z%(R,0)+16:RETURN

    REM single argument
    IF Z%(Z%(AR,1),1)<>0 THEN GOTO DO_CONCAT_MULT
      REM if single argument and it's a list, return it
      IF (Z%(AA,0)AND15)=6 THEN R=AA:Z%(R,0)=Z%(R,0)+16:RETURN
      REM otherwise, copy first element to turn it into a list
      B=AA+1:GOSUB DEREF_B: REM value to copy
      SZ=2:GOSUB ALLOC
      Z%(R,0)=6+16:Z%(R,1)=Z%(AA,1)
      Z%(R+1,0)=14:Z%(R+1,1)=B
      REM inc ref count of trailing list part and of copied value
      Z%(Z%(AA,1),0)=Z%(Z%(AA,1),0)+16
      Z%(B,0)=Z%(B,0)+16
      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:S%(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=S%(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)+16
    DO_CONCAT_LOOP:
      IF X=CZ% THEN R=AB:RETURN
      AA=S%(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)+16
      RETURN
  DO_FIRST:
    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)+16
    RETURN
  DO_REST:
    IF Z%(AA,1)=0 THEN R=AA
    IF Z%(AA,1)<>0 THEN R=Z%(AA,1)
    Z%(R,0)=Z%(R,0)+16
    RETURN
  DO_EMPTY_Q:
    R=1
    IF Z%(AA,1)=0 THEN R=2
    RETURN
  DO_COUNT:
    A=AA:GOSUB COUNT:R4=R
    SZ=1:GOSUB ALLOC
    Z%(R,0)=2+16
    Z%(R,1)=R4
    RETURN
  DO_APPLY:
    F=AA
    AR=Z%(AR,1)
    A=AR:GOSUB COUNT:R4=R

    REM no intermediate args, just call APPLY directly
    IF R4<=1 THEN AR=Z%(AR+1,1):GOSUB APPLY:RETURN

    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)+16

    X=X+1:S%(X)=R: REM push/save new args for release
    AR=R:GOSUB APPLY
    AY=S%(X):X=X-1:GOSUB RELEASE: REM pop/release new args
    RETURN
  DO_MAP:
    F=AA

    REM first result list element
    SZ=2:GOSUB ALLOC

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

    DO_MAP_LOOP:
      REM set base values
      Z%(R,0)=6+16:Z%(R,1)=0
      Z%(R+1,0)=14:Z%(R+1,1)=0

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

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

      REM create argument list for apply call
      SZ=2:GOSUB ALLOC
      Z%(R,0)=6+16:Z%(R,1)=0
      Z%(R+1,0)=14:Z%(R+1,1)=0
      AR=R: REM save end of list temporarily
      SZ=2:GOSUB ALLOC
      Z%(R,0)=6+16:Z%(R,1)=AR
      REM inc ref cnt of referred argument
      A=Z%(AB+1,1): Z%(A,0)=Z%(A,0)+16
      Z%(R+1,0)=14:Z%(R+1,1)=A

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

      AR=R:GOSUB APPLY

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

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

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

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

      REM allocate next element
      SZ=2:GOSUB ALLOC

      GOTO DO_MAP_LOOP

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

  DO_ATOM:
    SZ=1:GOSUB ALLOC
    Z%(AA,0)=Z%(AA,0)+16: REM inc ref cnt of contained value
    Z%(R,0)=12+16
    Z%(R,1)=AA
    RETURN
  DO_ATOM_Q:
    R=1
    IF (Z%(AA,0)AND15)=12 THEN R=2
    RETURN
  DO_DEREF:
    R=Z%(AA,1):GOSUB DEREF_R
    Z%(R,0)=Z%(R,0)+16
    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)+32
    REM update value
    Z%(AA,1)=R
    RETURN
  DO_SWAP_BANG:
    F=AB

    REM add atom to front of the args list
    A=Z%(AA,1):B=Z%(Z%(AR,1),1):GOSUB CONS
    AR=R

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

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

    GOSUB APPLY

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

    REM pop and release args
    AY=S%(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

    RETURN

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

  DO_EVAL:
    A=AA:E=RE%:GOSUB EVAL
    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$="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$="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
  K$="apply":A=47:GOSUB INIT_CORE_SET_FUNCTION
  K$="map":A=48:GOSUB INIT_CORE_SET_FUNCTION

  K$="atom":A=53:GOSUB INIT_CORE_SET_FUNCTION
  K$="atom?":A=54:GOSUB INIT_CORE_SET_FUNCTION
  K$="deref":A=55:GOSUB INIT_CORE_SET_FUNCTION
  K$="reset!":A=56:GOSUB INIT_CORE_SET_FUNCTION
  K$="swap!":A=57:GOSUB INIT_CORE_SET_FUNCTION

  K$="pr-memory":A=58:GOSUB INIT_CORE_SET_FUNCTION
  K$="pr-memory-summary":A=59:GOSUB INIT_CORE_SET_FUNCTION
  K$="eval":A=60:GOSUB INIT_CORE_SET_FUNCTION

  RETURN
Commit	Line	Data
241d5d57	1
cc9dbd92	2	REM DO_FUNCTION(F, AR)
241d5d57 JM	3	DO_FUNCTION:
241d5d57 JM	4	REM Get the function number
cc9dbd92	5	FF=Z%(F,1)
241d5d57 JM	6
241d5d57 JM	7	REM Get argument values
cc9dbd92 JM	8	R=AR+1:GOSUB DEREF_R:AA=R
cc9dbd92 JM	9	R=Z%(AR,1)+1:GOSUB DEREF_R:AB=R
241d5d57 JM	10
241d5d57 JM	11	REM Switch on the function number
cc9dbd92 JM	12	IF FF>=61 THEN ER=-1:ER$="unknown function"+STR$(FF):RETURN
	13	IF FF>=53 THEN DO_53
	14	IF FF>=39 THEN DO_39
	15	IF FF>=27 THEN DO_27
	16	IF FF>=18 THEN DO_18
	17	IF FF>=11 THEN DO_11
	18
	19	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
60ef223c	20	DO_11:
cc9dbd92	21	ON FF-10 GOTO DO_PR_STR,DO_STR,DO_PRN,DO_PRINTLN,DO_READ_STRING,DO_READLINE,DO_SLURP
60ef223c	22	DO_18:
cc9dbd92	23	ON FF-17 GOTO DO_LT,DO_LTE,DO_GT,DO_GTE,DO_ADD,DO_SUB,DO_MULT,DO_DIV,DO_TIME_MS
60ef223c	24	DO_27:
cc9dbd92	25	ON FF-26 GOTO DO_LIST,DO_LIST_Q,DO_VECTOR,DO_VECTOR_Q,DO_HASH_MAP,DO_MAP_Q
60ef223c	26	DO_39:
cc9dbd92	27	ON FF-38 GOTO DO_SEQUENTIAL_Q,DO_CONS,DO_CONCAT,DO_NTH,DO_FIRST,DO_REST,DO_EMPTY_Q,DO_COUNT,DO_APPLY,DO_MAP
60ef223c	28	DO_53:
cc9dbd92	29	ON FF-52 GOTO DO_ATOM,DO_ATOM_Q,DO_DEREF,DO_RESET_BANG,DO_SWAP_BANG,DO_PR_MEMORY,DO_PR_MEMORY_SUMMARY,DO_EVAL
241d5d57 JM	30
241d5d57 JM	31	DO_EQUAL_Q:
cc9dbd92 JM	32	A=AA:B=AB:GOSUB EQUAL_Q
cc9dbd92 JM	33	R=R+1
241d5d57	34	RETURN
5e5ca0d4	35	DO_THROW:
cc9dbd92 JM	36	ER=AA
	37	Z%(ER,0)=Z%(ER,0)+16
	38	R=0
5e5ca0d4 JM	39	RETURN
5e5ca0d4 JM	40	DO_NIL_Q:
cc9dbd92 JM	41	R=1
cc9dbd92 JM	42	IF AA=0 THEN R=2
5e5ca0d4 JM	43	RETURN
5e5ca0d4 JM	44	DO_TRUE_Q:
cc9dbd92 JM	45	R=1
cc9dbd92 JM	46	IF AA=2 THEN R=2
5e5ca0d4 JM	47	RETURN
5e5ca0d4 JM	48	DO_FALSE_Q:
cc9dbd92 JM	49	R=1
cc9dbd92 JM	50	IF AA=1 THEN R=2
5e5ca0d4 JM	51	RETURN
5e5ca0d4 JM	52	DO_STRING_Q:
cc9dbd92 JM	53	R=1
cc9dbd92 JM	54	IF (Z%(AA,0)AND15)=4 THEN R=2
5e5ca0d4 JM	55	RETURN
5e5ca0d4 JM	56	DO_SYMBOL:
cc9dbd92	57	R=0
5e5ca0d4 JM	58	RETURN
5e5ca0d4 JM	59	DO_SYMBOL_Q:
cc9dbd92 JM	60	R=1
cc9dbd92 JM	61	IF (Z%(AA,0)AND15)=5 THEN R=2
5e5ca0d4	62	RETURN
241d5d57 JM	63
241d5d57 JM	64	DO_PR_STR:
cc9dbd92 JM	65	AZ=AR:PR=1:SE$=" ":GOSUB PR_STR_SEQ
cc9dbd92 JM	66	AS$=R$:T=4+16:GOSUB STRING
241d5d57 JM	67	RETURN
241d5d57 JM	68	DO_STR:
cc9dbd92 JM	69	AZ=AR:PR=0:SE$="":GOSUB PR_STR_SEQ
cc9dbd92 JM	70	AS$=R$:T=4+16:GOSUB STRING
241d5d57 JM	71	RETURN
241d5d57 JM	72	DO_PRN:
cc9dbd92	73	AZ=AR:PR=1:SE$=" ":GOSUB PR_STR_SEQ
241d5d57	74	PRINT R$
cc9dbd92	75	R=0
241d5d57 JM	76	RETURN
241d5d57 JM	77	DO_PRINTLN:
cc9dbd92	78	AZ=AR:PR=0:SE$=" ":GOSUB PR_STR_SEQ
241d5d57	79	PRINT R$
cc9dbd92	80	R=0
241d5d57	81	RETURN
85d70fb7	82	DO_READ_STRING:
cc9dbd92	83	A$=S$(Z%(AA,1))
85d70fb7 JM	84	GOSUB READ_STR
85d70fb7 JM	85	RETURN
30a3d828	86	DO_READLINE:
cc9dbd92 JM	87	A$=S$(Z%(AA,1)):GOSUB READLINE
	88	IF EOF=1 THEN EOF=0:R=0:RETURN
	89	AS$=R$:T=4:GOSUB STRING
	90	Z%(R,0)=Z%(R,0)+16
30a3d828	91	RETURN
85d70fb7 JM	92	DO_SLURP:
85d70fb7 JM	93	R$=""
cc9dbd92 JM	94	REM OPEN 1,8,2,S$(Z%(AA,1))+",SEQ,R"
	95	REM OPEN 1,8,2,S$(Z%(AA,1))
	96	OPEN 1,8,0,S$(Z%(AA,1))
85d70fb7 JM	97	DO_SLURP_LOOP:
	98	A$=""
	99	GET#1,A$
	100	IF ASC(A$)=10 THEN R$=R$+CHR$(13)
	101	IF (ASC(A$)<>10) AND (A$<>"") THEN R$=R$+A$
	102	IF (ST AND 64) THEN GOTO DO_SLURP_DONE
cc9dbd92	103	IF (ST AND 255) THEN ER=-1:ER$="File read error "+STR$(ST):RETURN
85d70fb7 JM	104	GOTO DO_SLURP_LOOP
	105	DO_SLURP_DONE:
	106	CLOSE 1
cc9dbd92	107	AS$=R$:T=4+16:GOSUB STRING
85d70fb7	108	RETURN
241d5d57 JM	109
241d5d57 JM	110	DO_LT:
cc9dbd92 JM	111	R=1
cc9dbd92 JM	112	IF Z%(AA,1)<Z%(AB,1) THEN R=2
241d5d57 JM	113	RETURN
241d5d57 JM	114	DO_LTE:
cc9dbd92 JM	115	R=1
cc9dbd92 JM	116	IF Z%(AA,1)<=Z%(AB,1) THEN R=2
241d5d57 JM	117	RETURN
241d5d57 JM	118	DO_GT:
cc9dbd92 JM	119	R=1
cc9dbd92 JM	120	IF Z%(AA,1)>Z%(AB,1) THEN R=2
241d5d57 JM	121	RETURN
241d5d57 JM	122	DO_GTE:
cc9dbd92 JM	123	R=1
cc9dbd92 JM	124	IF Z%(AA,1)>=Z%(AB,1) THEN R=2
241d5d57 JM	125	RETURN
	126
	127	DO_ADD:
cc9dbd92 JM	128	SZ=1:GOSUB ALLOC
	129	Z%(R,0)=2+16
	130	Z%(R,1)=Z%(AA,1)+Z%(AB,1)
241d5d57 JM	131	RETURN
241d5d57 JM	132	DO_SUB:
cc9dbd92 JM	133	SZ=1:GOSUB ALLOC
	134	Z%(R,0)=2+16
	135	Z%(R,1)=Z%(AA,1)-Z%(AB,1)
241d5d57 JM	136	RETURN
241d5d57 JM	137	DO_MULT:
cc9dbd92 JM	138	SZ=1:GOSUB ALLOC
	139	Z%(R,0)=2+16
	140	Z%(R,1)=Z%(AA,1)*Z%(AB,1)
241d5d57 JM	141	RETURN
241d5d57 JM	142	DO_DIV:
cc9dbd92 JM	143	SZ=1:GOSUB ALLOC
	144	Z%(R,0)=2+16
	145	Z%(R,1)=Z%(AA,1)/Z%(AB,1)
241d5d57	146	RETURN
60ef223c	147	DO_TIME_MS:
cc9dbd92	148	R=0
60ef223c	149	RETURN
241d5d57 JM	150
241d5d57 JM	151	DO_LIST:
cc9dbd92 JM	152	R=AR
cc9dbd92 JM	153	Z%(R,0)=Z%(R,0)+16
241d5d57 JM	154	RETURN
241d5d57 JM	155	DO_LIST_Q:
cc9dbd92 JM	156	A=AA:GOSUB LIST_Q
cc9dbd92 JM	157	R=R+1: REM map to mal false/true
241d5d57	158	RETURN
5e5ca0d4	159	DO_VECTOR:
cc9dbd92	160	R=0
5e5ca0d4 JM	161	RETURN
5e5ca0d4 JM	162	DO_VECTOR_Q:
cc9dbd92 JM	163	R=1
cc9dbd92 JM	164	IF (Z%(AA,0)AND15)=7 THEN R=2
5e5ca0d4 JM	165	RETURN
5e5ca0d4 JM	166	DO_HASH_MAP:
cc9dbd92	167	R=0
5e5ca0d4 JM	168	RETURN
5e5ca0d4 JM	169	DO_MAP_Q:
cc9dbd92 JM	170	R=1
cc9dbd92 JM	171	IF (Z%(AA,0)AND15)=8 THEN R=2
5e5ca0d4	172	RETURN
241d5d57	173
5e5ca0d4	174	DO_SEQUENTIAL_Q:
cc9dbd92 JM	175	R=1
cc9dbd92 JM	176	IF (Z%(AA,0)AND15)=6 OR (Z%(AA,0)AND15)=7 THEN R=2
5e5ca0d4	177	RETURN
85d70fb7	178	DO_CONS:
cc9dbd92	179	A=AA:B=AB:GOSUB CONS
85d70fb7	180	RETURN
9e8f5211 JM	181	DO_CONCAT:
9e8f5211 JM	182	REM if empty arguments, return empty list
cc9dbd92	183	IF Z%(AR,1)=0 THEN R=3:Z%(R,0)=Z%(R,0)+16:RETURN
9e8f5211 JM	184
9e8f5211 JM	185	REM single argument
cc9dbd92	186	IF Z%(Z%(AR,1),1)<>0 THEN GOTO DO_CONCAT_MULT
9e8f5211	187	REM if single argument and it's a list, return it
cc9dbd92	188	IF (Z%(AA,0)AND15)=6 THEN R=AA:Z%(R,0)=Z%(R,0)+16:RETURN
9e8f5211	189	REM otherwise, copy first element to turn it into a list
cc9dbd92 JM	190	B=AA+1:GOSUB DEREF_B: REM value to copy
	191	SZ=2:GOSUB ALLOC
	192	Z%(R,0)=6+16:Z%(R,1)=Z%(AA,1)
	193	Z%(R+1,0)=14:Z%(R+1,1)=B
9e8f5211	194	REM inc ref count of trailing list part and of copied value
cc9dbd92 JM	195	Z%(Z%(AA,1),0)=Z%(Z%(AA,1),0)+16
cc9dbd92 JM	196	Z%(B,0)=Z%(B,0)+16
9e8f5211 JM	197	RETURN
	198
	199	REM multiple arguments
	200	DO_CONCAT_MULT:
cc9dbd92	201	CZ%=X: REM save current stack position
9e8f5211 JM	202	REM push arguments onto the stack
9e8f5211 JM	203	DO_CONCAT_STACK:
cc9dbd92 JM	204	R=AR+1:GOSUB DEREF_R
	205	X=X+1:S%(X)=R: REM push sequence
	206	AR=Z%(AR,1)
	207	IF Z%(AR,1)<>0 THEN GOTO DO_CONCAT_STACK
9e8f5211 JM	208
9e8f5211 JM	209	REM pop last argument as our seq to prepend to
cc9dbd92	210	AB=S%(X):X=X-1
9e8f5211	211	REM last arg/seq is not copied so we need to inc ref to it
cc9dbd92	212	Z%(AB,0)=Z%(AB,0)+16
9e8f5211	213	DO_CONCAT_LOOP:
cc9dbd92 JM	214	IF X=CZ% THEN R=AB:RETURN
	215	AA=S%(X):X=X-1: REM pop off next seq to prepend
	216	IF Z%(AA,1)=0 THEN GOTO DO_CONCAT_LOOP: REM skip empty seqs
	217	A=AA:B=0:C=-1:GOSUB SLICE
9e8f5211 JM	218
9e8f5211 JM	219	REM release the terminator of new list (we skip over it)
cc9dbd92	220	AY=Z%(R6,1):GOSUB RELEASE
9e8f5211 JM	221	REM attach new list element before terminator (last actual
9e8f5211 JM	222	REM element to the next sequence
cc9dbd92	223	Z%(R6,1)=AB
9e8f5211	224
cc9dbd92	225	AB=R
9e8f5211	226	GOTO DO_CONCAT_LOOP
60ef223c	227	DO_NTH:
cc9dbd92 JM	228	B=Z%(AB,1)
	229	A=AA:GOSUB COUNT
	230	IF R<=B THEN R=0:ER=-1:ER$="nth: index out of range":RETURN
70f29a2b	231	DO_NTH_LOOP:
cc9dbd92 JM	232	IF B=0 THEN GOTO DO_NTH_DONE
	233	B=B-1
	234	AA=Z%(AA,1)
70f29a2b JM	235	GOTO DO_NTH_LOOP
70f29a2b JM	236	DO_NTH_DONE:
cc9dbd92 JM	237	R=Z%(AA+1,1)
cc9dbd92 JM	238	Z%(R,0)=Z%(R,0)+16
70f29a2b	239	RETURN
85d70fb7	240	DO_FIRST:
cc9dbd92 JM	241	IF Z%(AA,1)=0 THEN R=0
	242	IF Z%(AA,1)<>0 THEN R=AA+1:GOSUB DEREF_R
	243	IF R<>0 THEN Z%(R,0)=Z%(R,0)+16
85d70fb7 JM	244	RETURN
85d70fb7 JM	245	DO_REST:
cc9dbd92 JM	246	IF Z%(AA,1)=0 THEN R=AA
	247	IF Z%(AA,1)<>0 THEN R=Z%(AA,1)
	248	Z%(R,0)=Z%(R,0)+16
85d70fb7	249	RETURN
241d5d57	250	DO_EMPTY_Q:
cc9dbd92 JM	251	R=1
cc9dbd92 JM	252	IF Z%(AA,1)=0 THEN R=2
241d5d57 JM	253	RETURN
241d5d57 JM	254	DO_COUNT:
cc9dbd92 JM	255	A=AA:GOSUB COUNT:R4=R
	256	SZ=1:GOSUB ALLOC
	257	Z%(R,0)=2+16
	258	Z%(R,1)=R4
241d5d57	259	RETURN
5e5ca0d4	260	DO_APPLY:
cc9dbd92 JM	261	F=AA
	262	AR=Z%(AR,1)
	263	A=AR:GOSUB COUNT:R4=R
5e5ca0d4 JM	264
5e5ca0d4 JM	265	REM no intermediate args, just call APPLY directly
cc9dbd92	266	IF R4<=1 THEN AR=Z%(AR+1,1):GOSUB APPLY:RETURN
5e5ca0d4 JM	267
5e5ca0d4 JM	268	REM prepend intermediate args to final args element
cc9dbd92	269	A=AR:B=0:C=R4-1:GOSUB SLICE
5e5ca0d4	270	REM release the terminator of new list (we skip over it)
cc9dbd92	271	AY=Z%(R6,1):GOSUB RELEASE
5e5ca0d4	272	REM attach end of slice to final args element
cc9dbd92 JM	273	Z%(R6,1)=Z%(A+1,1)
cc9dbd92 JM	274	Z%(Z%(A+1,1),0)=Z%(Z%(A+1,1),0)+16
5e5ca0d4	275
cc9dbd92 JM	276	X=X+1:S%(X)=R: REM push/save new args for release
	277	AR=R:GOSUB APPLY
	278	AY=S%(X):X=X-1:GOSUB RELEASE: REM pop/release new args
5e5ca0d4 JM	279	RETURN
5e5ca0d4 JM	280	DO_MAP:
cc9dbd92	281	F=AA
5e5ca0d4 JM	282
5e5ca0d4 JM	283	REM first result list element
cc9dbd92	284	SZ=2:GOSUB ALLOC
5e5ca0d4	285
cc9dbd92 JM	286	REM push future return val, prior entry, F and AB
cc9dbd92 JM	287	X=X+4:S%(X-3)=R:S%(X-2)=0:S%(X-1)=F:S%(X)=AB
5e5ca0d4 JM	288
	289	DO_MAP_LOOP:
	290	REM set base values
cc9dbd92 JM	291	Z%(R,0)=6+16:Z%(R,1)=0
cc9dbd92 JM	292	Z%(R+1,0)=14:Z%(R+1,1)=0
5e5ca0d4 JM	293
5e5ca0d4 JM	294	REM set previous to current if not the first element
cc9dbd92	295	IF S%(X-2)<>0 THEN Z%(S%(X-2),1)=R
5e5ca0d4	296	REM update previous reference to current
cc9dbd92	297	S%(X-2)=R
5e5ca0d4	298
cc9dbd92	299	IF Z%(AB,1)=0 THEN GOTO DO_MAP_DONE
5e5ca0d4 JM	300
5e5ca0d4 JM	301	REM create argument list for apply call
cc9dbd92 JM	302	SZ=2:GOSUB ALLOC
	303	Z%(R,0)=6+16:Z%(R,1)=0
	304	Z%(R+1,0)=14:Z%(R+1,1)=0
	305	AR=R: REM save end of list temporarily
	306	SZ=2:GOSUB ALLOC
	307	Z%(R,0)=6+16:Z%(R,1)=AR
5e5ca0d4	308	REM inc ref cnt of referred argument
cc9dbd92 JM	309	A=Z%(AB+1,1): Z%(A,0)=Z%(A,0)+16
cc9dbd92 JM	310	Z%(R+1,0)=14:Z%(R+1,1)=A
5e5ca0d4 JM	311
5e5ca0d4 JM	312	REM push argument list
cc9dbd92	313	X=X+1:S%(X)=R
5e5ca0d4	314
cc9dbd92	315	AR=R:GOSUB APPLY
5e5ca0d4 JM	316
5e5ca0d4 JM	317	REM pop apply args are release them
cc9dbd92	318	AY=S%(X):X=X-1:GOSUB RELEASE
5e5ca0d4 JM	319
5e5ca0d4 JM	320	REM set the result value
cc9dbd92	321	Z%(S%(X-2)+1,1)=R
5e5ca0d4	322
cc9dbd92 JM	323	REM restore F
cc9dbd92 JM	324	F=S%(X-1)
5e5ca0d4	325
cc9dbd92 JM	326	REM update AB to next source element
	327	S%(X)=Z%(S%(X),1)
	328	AB=S%(X)
5e5ca0d4 JM	329
5e5ca0d4 JM	330	REM allocate next element
cc9dbd92	331	SZ=2:GOSUB ALLOC
5e5ca0d4 JM	332
	333	GOTO DO_MAP_LOOP
	334
	335	DO_MAP_DONE:
	336	REM get return val
cc9dbd92	337	R=S%(X-3)
5e5ca0d4	338	REM pop everything off stack
cc9dbd92	339	X=X-4
5e5ca0d4	340	RETURN
241d5d57	341
85d70fb7	342	DO_ATOM:
cc9dbd92 JM	343	SZ=1:GOSUB ALLOC
	344	Z%(AA,0)=Z%(AA,0)+16: REM inc ref cnt of contained value
	345	Z%(R,0)=12+16
	346	Z%(R,1)=AA
85d70fb7 JM	347	RETURN
85d70fb7 JM	348	DO_ATOM_Q:
cc9dbd92 JM	349	R=1
cc9dbd92 JM	350	IF (Z%(AA,0)AND15)=12 THEN R=2
85d70fb7 JM	351	RETURN
85d70fb7 JM	352	DO_DEREF:
cc9dbd92 JM	353	R=Z%(AA,1):GOSUB DEREF_R
cc9dbd92 JM	354	Z%(R,0)=Z%(R,0)+16
85d70fb7 JM	355	RETURN
85d70fb7 JM	356	DO_RESET_BANG:
cc9dbd92	357	R=AB
85d70fb7	358	REM release current value
cc9dbd92	359	AY=Z%(AA,1):GOSUB RELEASE
85d70fb7	360	REM inc ref by 2 for atom ownership and since we are returning it
cc9dbd92	361	Z%(R,0)=Z%(R,0)+32
85d70fb7	362	REM update value
cc9dbd92	363	Z%(AA,1)=R
85d70fb7 JM	364	RETURN
85d70fb7 JM	365	DO_SWAP_BANG:
cc9dbd92	366	F=AB
85d70fb7 JM	367
85d70fb7 JM	368	REM add atom to front of the args list
cc9dbd92 JM	369	A=Z%(AA,1):B=Z%(Z%(AR,1),1):GOSUB CONS
cc9dbd92 JM	370	AR=R
85d70fb7 JM	371
85d70fb7 JM	372	REM push args for release after
cc9dbd92	373	X=X+1:S%(X)=AR
85d70fb7	374
70f29a2b	375	REM push atom
cc9dbd92	376	X=X+1:S%(X)=AA
85d70fb7	377
70f29a2b	378	GOSUB APPLY
85d70fb7	379
70f29a2b	380	REM pop atom
cc9dbd92	381	AA=S%(X):X=X-1
85d70fb7	382
70f29a2b	383	REM pop and release args
cc9dbd92	384	AY=S%(X):X=X-1:GOSUB RELEASE
85d70fb7	385
70f29a2b	386	REM use reset to update the value
cc9dbd92	387	AB=R:GOSUB DO_RESET_BANG
85d70fb7	388
70f29a2b	389	REM but decrease ref cnt of return by 1 (not sure why)
cc9dbd92	390	AY=R:GOSUB RELEASE
85d70fb7	391
70f29a2b	392	RETURN
85d70fb7	393
241d5d57	394	DO_PR_MEMORY:
60ef223c	395	P1%=ZT%:P2%=-1:GOSUB PR_MEMORY
241d5d57	396	RETURN
241d5d57 JM	397	DO_PR_MEMORY_SUMMARY:
	398	GOSUB PR_MEMORY_SUMMARY
	399	RETURN
	400
85d70fb7	401	DO_EVAL:
cc9dbd92	402	A=AA:E=RE%:GOSUB EVAL
85d70fb7 JM	403	RETURN
85d70fb7 JM	404
241d5d57 JM	405	INIT_CORE_SET_FUNCTION:
241d5d57 JM	406	GOSUB NATIVE_FUNCTION
cc9dbd92	407	V=R:GOSUB ENV_SET_S
241d5d57 JM	408	RETURN
241d5d57 JM	409
cc9dbd92	410	REM INIT_CORE_NS(E)
241d5d57 JM	411	INIT_CORE_NS:
	412	REM create the environment mapping
	413	REM must match DO_FUNCTION mappings
	414
cc9dbd92 JM	415	K$="=":A=1:GOSUB INIT_CORE_SET_FUNCTION
	416	K$="throw":A=2:GOSUB INIT_CORE_SET_FUNCTION
	417	K$="nil?":A=3:GOSUB INIT_CORE_SET_FUNCTION
	418	K$="true?":A=4:GOSUB INIT_CORE_SET_FUNCTION
	419	K$="false?":A=5:GOSUB INIT_CORE_SET_FUNCTION
	420	K$="string?":A=6:GOSUB INIT_CORE_SET_FUNCTION
	421	K$="symbol":A=7:GOSUB INIT_CORE_SET_FUNCTION
	422	K$="symbol?":A=8:GOSUB INIT_CORE_SET_FUNCTION
	423
	424	K$="pr-str":A=11:GOSUB INIT_CORE_SET_FUNCTION
	425	K$="str":A=12:GOSUB INIT_CORE_SET_FUNCTION
	426	K$="prn":A=13:GOSUB INIT_CORE_SET_FUNCTION
	427	K$="println":A=14:GOSUB INIT_CORE_SET_FUNCTION
	428	K$="read-string":A=15:GOSUB INIT_CORE_SET_FUNCTION
	429	K$="readline":A=16:GOSUB INIT_CORE_SET_FUNCTION
	430	K$="slurp":A=17:GOSUB INIT_CORE_SET_FUNCTION
	431
	432	K$="<":A=18:GOSUB INIT_CORE_SET_FUNCTION
	433	K$="<=":A=19:GOSUB INIT_CORE_SET_FUNCTION
	434	K$=">":A=20:GOSUB INIT_CORE_SET_FUNCTION
	435	K$=">=":A=21:GOSUB INIT_CORE_SET_FUNCTION
	436	K$="+":A=22:GOSUB INIT_CORE_SET_FUNCTION
	437	K$="-":A=23:GOSUB INIT_CORE_SET_FUNCTION
	438	K$="*":A=24:GOSUB INIT_CORE_SET_FUNCTION
	439	K$="/":A=25:GOSUB INIT_CORE_SET_FUNCTION
	440	K$="time-ms":A=26:GOSUB INIT_CORE_SET_FUNCTION
	441
	442	K$="list":A=27:GOSUB INIT_CORE_SET_FUNCTION
	443	K$="list?":A=28:GOSUB INIT_CORE_SET_FUNCTION
	444	K$="vector":A=29:GOSUB INIT_CORE_SET_FUNCTION
	445	K$="vector?":A=30:GOSUB INIT_CORE_SET_FUNCTION
	446	K$="hash-map":A=31:GOSUB INIT_CORE_SET_FUNCTION
	447	K$="map?":A=32:GOSUB INIT_CORE_SET_FUNCTION
	448
	449	K$="sequential?":A=39:GOSUB INIT_CORE_SET_FUNCTION
	450	K$="cons":A=40:GOSUB INIT_CORE_SET_FUNCTION
	451	K$="concat":A=41:GOSUB INIT_CORE_SET_FUNCTION
	452	K$="nth":A=42:GOSUB INIT_CORE_SET_FUNCTION
	453	K$="first":A=43:GOSUB INIT_CORE_SET_FUNCTION
	454	K$="rest":A=44:GOSUB INIT_CORE_SET_FUNCTION
	455	K$="empty?":A=45:GOSUB INIT_CORE_SET_FUNCTION
	456	K$="count":A=46:GOSUB INIT_CORE_SET_FUNCTION
	457	K$="apply":A=47:GOSUB INIT_CORE_SET_FUNCTION
	458	K$="map":A=48:GOSUB INIT_CORE_SET_FUNCTION
	459
	460	K$="atom":A=53:GOSUB INIT_CORE_SET_FUNCTION
	461	K$="atom?":A=54:GOSUB INIT_CORE_SET_FUNCTION
	462	K$="deref":A=55:GOSUB INIT_CORE_SET_FUNCTION
	463	K$="reset!":A=56:GOSUB INIT_CORE_SET_FUNCTION
	464	K$="swap!":A=57:GOSUB INIT_CORE_SET_FUNCTION
	465
	466	K$="pr-memory":A=58:GOSUB INIT_CORE_SET_FUNCTION
	467	K$="pr-memory-summary":A=59:GOSUB INIT_CORE_SET_FUNCTION
	468	K$="eval":A=60:GOSUB INIT_CORE_SET_FUNCTION
241d5d57 JM	469
241d5d57 JM	470	RETURN