-
-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>58 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_59
-
- 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_THROW,DO_THROW,DO_THROW,DO_THROW,DO_THROW,DO_THROW,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_APPLY,DO_MAP,DO_THROW
- DO_50_59:
- ON FF-49 GOTO DO_THROW,DO_THROW,DO_THROW,DO_ATOM,DO_ATOM_Q,DO_DEREF,DO_RESET_BANG,DO_SWAP_BANG,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:
- T=5:L=Z%(AA,1):GOSUB ALLOC
- RETURN
- DO_SYMBOL_Q:
- R=1
- IF (Z%(AA,0)AND15)=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)AND15)<>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:
- 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:
- A=AR:T=7:GOSUB FORCE_SEQ_TYPE
- RETURN
- DO_VECTOR_Q:
- R=1
- IF (Z%(AA,0)AND15)=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)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:
- 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)+16: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: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 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)+16
- RETURN
- DO_REST:
- IF AA=0 THEN R=3:Z%(R,0)=Z%(R,0)+16: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_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)AND15)<>6 THEN :T=6:GOSUB FORCE_SEQ_TYPE:GOTO DO_APPLY_2
- REM no intermediate args, just call APPLY directly
- IF R4<=1 THEN AR=A: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
-
- DO_APPLY_2:
- 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
- T=6:L=0:N=0: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 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
- Z%(3,0)=Z%(3,0)+16
- 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: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
- T=6:L=0:N=0: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:
- T=12:L=AA:GOSUB ALLOC
- 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
- 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: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$="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
- K$="apply":A=47:GOSUB INIT_CORE_SET_FUNCTION
- K$="map":A=48:GOSUB INIT_CORE_SET_FUNCTION
-
- K$="with-meta":A=51:GOSUB INIT_CORE_SET_FUNCTION
- K$="meta":A=52: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$="eval":A=58:GOSUB INIT_CORE_SET_FUNCTION
-
- RETURN
+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
+ GOSUB TYPE_F
+ IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F
+
+ ON T-8 GOTO APPLY_FUNCTION,APPLY_MAL_FUNCTION,APPLY_MAL_FUNCTION
+
+ APPLY_FUNCTION:
+ REM regular function
+ IF Z%(F+1)<64 THEN GOSUB DO_FUNCTION:GOTO APPLY_DONE
+ REM for recur functions (apply, map, swap!), use GOTO
+ IF Z%(F+1)>64 THEN CALL DO_TCO_FUNCTION
+ GOTO APPLY_DONE
+
+ APPLY_MAL_FUNCTION:
+ Q=E:GOSUB PUSH_Q: 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
+ C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS
+
+ A=Z%(F+1):E=R:CALL EVAL
+
+ AY=E:GOSUB RELEASE: REM release the new environment
+
+ GOSUB POP_Q:E=Q: REM pop/restore the saved environment
+
+ APPLY_DONE:
+END SUB
+
+
+REM DO_TCO_FUNCTION(F, AR)
+SUB DO_TCO_FUNCTION
+ G=Z%(F+1)
+
+ REM Get argument values
+ A=Z%(AR+2)
+ B=Z%(Z%(AR+1)+2)
+
+REM PRINT "F:"+STR$(F)+", Z%(F):"+STR$(Z%(F))+", G:"+STR$(G)
+ ON G-64 GOTO DO_APPLY,DO_MAP,DO_SWAP_BANG
+
+ DO_APPLY:
+ F=A
+ AR=Z%(AR+1)
+ A=AR:GOSUB COUNT:C=R
+
+ A=Z%(AR+2)
+ REM no intermediate args, but not a list, so convert it first
+ GOSUB TYPE_A
+ IF C<=1 AND T<>6 THEN T=6:GOSUB FORCE_SEQ_TYPE:GOTO DO_APPLY_2
+ REM no intermediate args, just call APPLY directly
+ IF C<=1 THEN GOTO DO_APPLY_1
+
+ REM prepend intermediate args to final args element
+ A=AR:B=0:C=C-1:GOSUB SLICE
+ REM release the terminator of new list (we skip over it)
+ REM we already checked for an empty list above, so R6 is pointer
+ REM a real non-empty list
+ AY=Z%(R6+1):GOSUB RELEASE
+ REM attach end of slice to final args element
+ A2=Z%(A+2)
+ Z%(R6+1)=A2
+ Z%(A2)=Z%(A2)+32
+
+ GOTO DO_APPLY_2
+
+ DO_APPLY_1:
+ AR=A:CALL APPLY
+
+ GOTO DO_TCO_FUNCTION_DONE
+
+ DO_APPLY_2:
+ GOSUB PUSH_R: REM push/save new args for release
+
+ AR=R:CALL APPLY
+
+ REM pop/release new args
+ GOSUB POP_Q:AY=Q
+ GOSUB RELEASE
+ GOTO DO_TCO_FUNCTION_DONE
+
+ DO_MAP:
+ F=A
+
+ REM setup the stack for the loop
+ T=6:GOSUB MAP_LOOP_START
+
+ DO_MAP_LOOP:
+ IF Z%(B+1)=0 THEN GOTO DO_MAP_DONE
+
+ REM create argument list for apply
+ T=6:L=6:M=Z%(B+2):GOSUB ALLOC
+
+ GOSUB PUSH_R: REM push argument list
+ Q=F:GOSUB PUSH_Q: REM push F
+ Q=B:GOSUB PUSH_Q: REM push B
+
+ AR=R:CALL APPLY
+
+ GOSUB POP_Q:B=Q: REM pop B
+ GOSUB POP_Q:F=Q: REM pop F
+ GOSUB POP_Q: REM pop apply args and release them
+ AY=Q:GOSUB RELEASE
+
+ REM main value is result of apply
+ M=R
+
+ B=Z%(B+1): REM go to the next element
+
+ REM if error, release the unattached element
+ IF ER<>-2 THEN AY=R:GOSUB RELEASE:GOTO DO_MAP_DONE
+
+ REM update the return sequence structure
+ REM release N since list takes full ownership
+ C=1:T=6:GOSUB MAP_LOOP_UPDATE
+
+ GOTO DO_MAP_LOOP
+
+ DO_MAP_DONE:
+ REM cleanup stack and get return value
+ GOSUB MAP_LOOP_DONE
+ GOTO DO_TCO_FUNCTION_DONE
+
+ DO_SWAP_BANG:
+ F=B
+
+ REM add atom to front of the args list
+ T=6:L=Z%(Z%(AR+1)+1):M=Z%(A+1):GOSUB ALLOC: REM cons
+ AR=R
+
+ REM push args for release after
+ Q=AR:GOSUB PUSH_Q
+
+ REM push atom
+ GOSUB PUSH_A
+
+ CALL APPLY
+
+ REM pop atom
+ GOSUB POP_A
+
+ REM pop and release args
+ GOSUB POP_Q:AY=Q
+ GOSUB RELEASE
+
+ REM use reset to update the value
+ B=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
+ G=Z%(F+1)
+
+ REM Get argument values
+ A=Z%(AR+2):A1=Z%(A+1)
+ B=Z%(Z%(AR+1)+2):B1=Z%(B+1)
+
+ REM Switch on the function number
+ REM MEMORY DEBUGGING:
+ REM IF G>59 THEN ER=-1:E$="unknown function"+STR$(G):RETURN
+ ON INT(G/10)+1 GOTO DO_1_9,DO_10_19,DO_20_29,DO_30_39,DO_40_49,DO_50_59,DO_60_69
+
+ DO_1_9:
+ ON G 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 G-9 GOTO DO_KEYWORD_Q,DO_NUMBER_Q,DO_FN_Q,DO_MACRO_Q,DO_PR_STR,DO_STR,DO_PRN,DO_PRINTLN,DO_READ_STRING,DO_READLINE
+ DO_20_29:
+ ON G-19 GOTO DO_SLURP,DO_LT,DO_LTE,DO_GT,DO_GTE,DO_ADD,DO_SUB,DO_MULT,DO_DIV,DO_TIME_MS
+ DO_30_39:
+ ON G-29 GOTO DO_LIST,DO_LIST_Q,DO_VECTOR,DO_VECTOR_Q,DO_HASH_MAP,DO_MAP_Q,DO_ASSOC,DO_THROW,DO_GET,DO_CONTAINS
+ DO_40_49:
+ ON G-39 GOTO DO_KEYS,DO_VALS,DO_SEQUENTIAL_Q,DO_CONS,DO_CONCAT,DO_NTH,DO_FIRST,DO_REST,DO_EMPTY_Q,DO_COUNT
+ DO_50_59:
+ ON G-49 GOTO DO_CONJ,DO_SEQ,DO_WITH_META,DO_META,DO_ATOM,DO_ATOM_Q,DO_DEREF,DO_RESET_BANG,DO_EVAL,DO_READ_FILE
+ DO_60_69:
+ ON G-59 GOTO DO_PR_MEMORY_SUMMARY
+
+ DO_EQUAL_Q:
+ GOSUB EQUAL_Q
+ GOTO RETURN_TRUE_FALSE
+ DO_THROW:
+ ER=A
+ Z%(ER)=Z%(ER)+32
+ R=-1
+ RETURN
+ DO_NIL_Q:
+ R=A=0
+ GOTO RETURN_TRUE_FALSE
+ DO_TRUE_Q:
+ R=A=4
+ GOTO RETURN_TRUE_FALSE
+ DO_FALSE_Q:
+ R=A=2
+ GOTO RETURN_TRUE_FALSE
+ DO_STRING_Q:
+ R=0
+ GOSUB TYPE_A
+ IF T<>4 THEN GOTO RETURN_TRUE_FALSE
+ IF MID$(S$(A1),1,1)=CHR$(127) THEN GOTO RETURN_TRUE_FALSE
+ R=1
+ GOTO RETURN_TRUE_FALSE
+ DO_SYMBOL:
+ B$=S$(A1)
+ T=5:GOSUB STRING
+ RETURN
+ DO_SYMBOL_Q:
+ GOSUB TYPE_A
+ R=T=5
+ GOTO RETURN_TRUE_FALSE
+ DO_KEYWORD:
+ B$=S$(A1)
+ IF MID$(B$,1,1)<>CHR$(127) THEN B$=CHR$(127)+B$
+ T=4:GOSUB STRING
+ RETURN
+ DO_KEYWORD_Q:
+ R=0
+ GOSUB TYPE_A
+ IF T<>4 THEN GOTO RETURN_TRUE_FALSE
+ IF MID$(S$(A1),1,1)<>CHR$(127) THEN GOTO RETURN_TRUE_FALSE
+ R=1
+ GOTO RETURN_TRUE_FALSE
+ DO_NUMBER_Q:
+ GOSUB TYPE_A
+ R=T=2
+ GOTO RETURN_TRUE_FALSE
+ DO_FN_Q:
+ GOSUB TYPE_A
+ R=T=9 OR T=10
+ GOTO RETURN_TRUE_FALSE
+ DO_MACRO_Q:
+ GOSUB TYPE_A
+ R=T=11
+ GOTO RETURN_TRUE_FALSE
+
+ DO_PR_STR:
+ AZ=AR:B=1:B$=" ":GOSUB PR_STR_SEQ
+ B$=R$:T=4:GOSUB STRING
+ RETURN
+ DO_STR:
+ AZ=AR:B=0:B$="":GOSUB PR_STR_SEQ
+ B$=R$:T=4:GOSUB STRING
+ RETURN
+ DO_PRN:
+ AZ=AR:B=1:B$=" ":GOSUB PR_STR_SEQ
+ PRINT R$
+ R=0
+ GOTO INC_REF_R
+ DO_PRINTLN:
+ AZ=AR:B=0:B$=" ":GOSUB PR_STR_SEQ
+ PRINT R$
+ R=0
+ GOTO INC_REF_R
+ DO_READ_STRING:
+ A$=S$(A1)
+ GOSUB READ_STR
+ RETURN
+ DO_READLINE:
+ A$=S$(A1):GOSUB READLINE
+ IF EZ>0 THEN EZ=0:R=0:GOTO INC_REF_R
+ B$=R$:T=4:GOSUB STRING
+ RETURN
+ DO_SLURP:
+ R$=""
+ EZ=0
+ #cbm OPEN 2,8,0,S$(A1)
+ #qbasic A$=S$(A1)
+ #qbasic IF NOT _FILEEXISTS(A$) THEN ER=-1:E$="File not found":RETURN
+ #qbasic OPEN A$ FOR INPUT AS #2
+ DO_SLURP_LOOP:
+ C$=""
+ RJ=1:GOSUB READ_FILE_CHAR
+ #cbm IF ASC(C$)=10 THEN R$=R$+CHR$(13)
+ #qbasic IF ASC(C$)=10 THEN R$=R$+CHR$(10)
+ IF (ASC(C$)<>10) AND (C$<>"") THEN R$=R$+C$
+ IF EZ>0 THEN GOTO DO_SLURP_DONE
+ GOTO DO_SLURP_LOOP
+ DO_SLURP_DONE:
+ CLOSE 2
+ IF ER>-2 THEN RETURN
+ B$=R$:T=4:GOSUB STRING
+ RETURN
+
+ DO_LT:
+ R=A1<B1
+ GOTO RETURN_TRUE_FALSE
+ DO_LTE:
+ R=A1<=B1
+ GOTO RETURN_TRUE_FALSE
+ DO_GT:
+ R=A1>B1
+ GOTO RETURN_TRUE_FALSE
+ DO_GTE:
+ R=A1>=B1
+ GOTO RETURN_TRUE_FALSE
+
+ DO_ADD:
+ T=2:L=A1+B1:GOSUB ALLOC
+ RETURN
+ DO_SUB:
+ T=2:L=A1-B1:GOSUB ALLOC
+ RETURN
+ DO_MULT:
+ T=2:L=A1*B1:GOSUB ALLOC
+ RETURN
+ DO_DIV:
+ T=2:L=A1/B1:GOSUB ALLOC
+ RETURN
+ DO_TIME_MS:
+ #cbm T=2:L=INT((TI-BT)*16.667):GOSUB ALLOC
+ #qbasic T=2:L=INT((TIMER(0.001)-BT#)*1000):GOSUB ALLOC
+ RETURN
+
+ DO_LIST:
+ R=AR
+ GOTO INC_REF_R
+ DO_LIST_Q:
+ GOSUB LIST_Q
+ GOTO RETURN_TRUE_FALSE
+ DO_VECTOR:
+ A=AR:T=7:GOSUB FORCE_SEQ_TYPE
+ RETURN
+ DO_VECTOR_Q:
+ GOSUB TYPE_A
+ R=T=7
+ GOTO RETURN_TRUE_FALSE
+ DO_HASH_MAP:
+ REM setup the stack for the loop
+ T=8:GOSUB MAP_LOOP_START
+
+ A=AR
+ DO_HASH_MAP_LOOP:
+ IF Z%(A+1)=0 THEN GOTO DO_HASH_MAP_LOOP_DONE
+
+ M=Z%(A+2)
+ N=Z%(Z%(A+1)+2)
+
+ A=Z%(Z%(A+1)+1): REM skip two
+
+ REM update the return sequence structure
+ REM do not release M and N since we are pulling them from the
+ REM arguments (and not creating them here)
+ C=0:GOSUB MAP_LOOP_UPDATE
+
+ GOTO DO_HASH_MAP_LOOP
+
+ DO_HASH_MAP_LOOP_DONE:
+ REM cleanup stack and get return value
+ GOSUB MAP_LOOP_DONE
+ RETURN
+
+ DO_MAP_Q:
+ GOSUB TYPE_A
+ R=T=8
+ GOTO RETURN_TRUE_FALSE
+ DO_ASSOC:
+ H=A
+ AR=Z%(AR+1)
+ DO_ASSOC_LOOP:
+ K=Z%(AR+2)
+ C=Z%(Z%(AR+1)+2)
+ Z%(H)=Z%(H)+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 A=0 THEN R=0:GOTO INC_REF_R
+ H=A:K=B:GOSUB HASHMAP_GET
+ GOTO INC_REF_R
+ DO_CONTAINS:
+ H=A:K=B:GOSUB HASHMAP_CONTAINS
+ GOTO RETURN_TRUE_FALSE
+ DO_KEYS:
+ T1=0
+ GOTO DO_KEYS_VALS
+ DO_VALS:
+ T1=1
+ DO_KEYS_VALS:
+ REM setup the stack for the loop
+ T=6:GOSUB MAP_LOOP_START
+
+ DO_KEYS_VALS_LOOP:
+ IF Z%(A+1)=0 THEN GOTO DO_KEYS_VALS_LOOP_DONE
+
+ IF T1=0 THEN M=Z%(A+2)
+ IF T1=1 THEN M=Z%(A+3)
+
+ A=Z%(A+1): REM next element
+
+ REM update the return sequence structure
+ REM do not release N since we are pulling it from the
+ REM hash-map (and not creating them here)
+ C=0:GOSUB MAP_LOOP_UPDATE
+
+ GOTO DO_KEYS_VALS_LOOP
+
+ DO_KEYS_VALS_LOOP_DONE:
+ REM cleanup stack and get return value
+ GOSUB MAP_LOOP_DONE
+ RETURN
+
+ DO_SEQUENTIAL_Q:
+ GOSUB TYPE_A
+ R=T=6 OR T=7
+ GOTO RETURN_TRUE_FALSE
+ DO_CONS:
+ T=6:L=B:M=A:GOSUB ALLOC
+ RETURN
+ DO_CONCAT:
+ REM always a list
+ R=6:GOSUB INC_REF_R
+ GOSUB PUSH_R: REM current value
+ GOSUB PUSH_R: REM return value
+
+ DO_CONCAT_LOOP:
+ IF AR<16 THEN GOTO DO_CONCAT_DONE: REM no more elements
+
+ REM slice/copy current element to a list
+ A=Z%(AR+2)
+ IF A<16 THEN GOTO DO_CONCAT_LOOP_NEXT: REM skip empty elements
+ B=0:C=-1:GOSUB SLICE
+
+ GOSUB PEEK_Q: REM return value
+ REM if this is the first element, set return element
+ IF Q=6 THEN Q=R:GOSUB PUT_Q:GOTO DO_CONCAT_LOOP_AGAIN
+ REM otherwise Q<>6, so attach current to sliced
+ GOSUB PEEK_Q_1
+ Z%(Q+1)=R
+
+ DO_CONCAT_LOOP_AGAIN:
+ REM update current to end of sliced list
+ Q=R6:GOSUB PUT_Q_1
+ REM dec empty since no longer part of slice
+ AY=6:GOSUB RELEASE
+ DO_CONCAT_LOOP_NEXT:
+ REM next list element
+ AR=Z%(AR+1)
+ GOTO DO_CONCAT_LOOP
+
+ DO_CONCAT_DONE:
+ GOSUB POP_R: REM pop return value
+ GOSUB POP_Q: REM pop current
+ RETURN
+
+ DO_NTH:
+ B=B1
+ GOSUB COUNT
+ IF R<=B THEN R=-1:ER=-1:E$="nth: index out of range":RETURN
+ DO_NTH_LOOP:
+ IF B=0 THEN GOTO DO_NTH_DONE
+ B=B-1
+ A=Z%(A+1)
+ GOTO DO_NTH_LOOP
+ DO_NTH_DONE:
+ R=Z%(A+2)
+ GOTO INC_REF_R
+ DO_FIRST:
+ R=0
+ IF A=0 THEN GOTO INC_REF_R
+ IF A1<>0 THEN R=Z%(A+2)
+ GOTO INC_REF_R
+ DO_REST:
+ IF A=0 THEN R=6:GOTO INC_REF_R
+ IF A1<>0 THEN A=A1: REM get the next sequence element
+ T=6:GOSUB FORCE_SEQ_TYPE
+ RETURN
+ DO_EMPTY_Q:
+ R=A1=0
+ GOTO RETURN_TRUE_FALSE
+ DO_COUNT:
+ GOSUB COUNT
+ T=2:L=R:GOSUB ALLOC
+ RETURN
+ DO_CONJ:
+ R=0
+ GOTO INC_REF_R
+ DO_SEQ:
+ R=0
+ GOTO INC_REF_R
+
+ DO_WITH_META:
+ GOSUB TYPE_A
+ REM remove existing metadata first
+ IF T=14 THEN A=A1:GOTO DO_WITH_META
+ T=14:L=A:M=B:GOSUB ALLOC
+ RETURN
+ DO_META:
+ R=0
+ GOSUB TYPE_A
+ IF T=14 THEN R=Z%(A+2)
+ GOTO INC_REF_R
+ DO_ATOM:
+ T=12:L=A:GOSUB ALLOC
+ RETURN
+ DO_ATOM_Q:
+ GOSUB TYPE_A
+ R=T=12
+ GOTO RETURN_TRUE_FALSE
+ DO_DEREF:
+ R=A1
+ GOTO INC_REF_R
+ DO_RESET_BANG:
+ R=B
+ REM release current value
+ REM can't use A1 here because DO_RESET_BANG is called from swap!
+ AY=Z%(A+1):GOSUB RELEASE
+ REM inc ref by 2 for atom ownership and since we are returning it
+ Z%(R)=Z%(R)+64
+ REM update value
+ Z%(A+1)=R
+ RETURN
+
+ DO_EVAL:
+ Q=E:GOSUB PUSH_Q: REM push/save environment
+ E=D:CALL EVAL
+ GOSUB POP_Q:E=Q
+ RETURN
+
+ DO_READ_FILE:
+ A$=S$(A1)
+ GOSUB READ_FILE
+ RETURN
+
+ REM DO_PR_MEMORY:
+ REM P1=ZT:P2=-1:GOSUB PR_MEMORY
+ REM RETURN
+ DO_PR_MEMORY_SUMMARY:
+ REM GOSUB PR_MEMORY_SUMMARY
+ GOSUB PR_MEMORY_SUMMARY_SMALL
+ R=0
+ GOTO INC_REF_R
+ RETURN
+
+INIT_CORE_SET_FUNCTION:
+ T=9:L=A:GOSUB ALLOC: REM native function
+ C=R:GOSUB ENV_SET_S
+ A=A+1
+ RETURN
+
+REM INIT_CORE_NS(E)
+INIT_CORE_NS:
+ REM create the environment mapping
+ REM must match DO_FUNCTION mappings
+
+ A=1
+ B$="=":GOSUB INIT_CORE_SET_FUNCTION: REM A=1
+ B$="throw":GOSUB INIT_CORE_SET_FUNCTION: REM A=2
+ B$="nil?":GOSUB INIT_CORE_SET_FUNCTION: REM A=3
+ B$="true?":GOSUB INIT_CORE_SET_FUNCTION: REM A=4
+ B$="false?":GOSUB INIT_CORE_SET_FUNCTION: REM A=5
+ B$="string?":GOSUB INIT_CORE_SET_FUNCTION: REM A=6
+ B$="symbol":GOSUB INIT_CORE_SET_FUNCTION: REM A=7
+ B$="symbol?":GOSUB INIT_CORE_SET_FUNCTION: REM A=8
+ B$="keyword":GOSUB INIT_CORE_SET_FUNCTION: REM A=9
+ B$="keyword?":GOSUB INIT_CORE_SET_FUNCTION: REM A=10
+ B$="number?":GOSUB INIT_CORE_SET_FUNCTION: REM A=11
+ B$="fn?":GOSUB INIT_CORE_SET_FUNCTION: REM A=12
+ B$="macro?":GOSUB INIT_CORE_SET_FUNCTION: REM A=13
+
+ B$="pr-str":GOSUB INIT_CORE_SET_FUNCTION: REM A=14
+ B$="str":GOSUB INIT_CORE_SET_FUNCTION: REM A=15
+ B$="prn":GOSUB INIT_CORE_SET_FUNCTION: REM A=16
+ B$="println":GOSUB INIT_CORE_SET_FUNCTION: REM A=17
+ B$="read-string":GOSUB INIT_CORE_SET_FUNCTION: REM A=18
+ B$="readline":GOSUB INIT_CORE_SET_FUNCTION: REM A=19
+ B$="slurp":GOSUB INIT_CORE_SET_FUNCTION: REM A=20
+
+ B$="<":GOSUB INIT_CORE_SET_FUNCTION: REM A=21
+ B$="<=":GOSUB INIT_CORE_SET_FUNCTION: REM A=22
+ B$=">":GOSUB INIT_CORE_SET_FUNCTION: REM A=23
+ B$=">=":GOSUB INIT_CORE_SET_FUNCTION: REM A=24
+ B$="+":GOSUB INIT_CORE_SET_FUNCTION: REM A=25
+ B$="-":GOSUB INIT_CORE_SET_FUNCTION: REM A=26
+ B$="*":GOSUB INIT_CORE_SET_FUNCTION: REM A=27
+ B$="/":GOSUB INIT_CORE_SET_FUNCTION: REM A=28
+ B$="time-ms":GOSUB INIT_CORE_SET_FUNCTION: REM A=29
+
+ B$="list":GOSUB INIT_CORE_SET_FUNCTION: REM A=30
+ B$="list?":GOSUB INIT_CORE_SET_FUNCTION: REM A=31
+ B$="vector":GOSUB INIT_CORE_SET_FUNCTION: REM A=32
+ B$="vector?":GOSUB INIT_CORE_SET_FUNCTION: REM A=33
+ B$="hash-map":GOSUB INIT_CORE_SET_FUNCTION: REM A=34
+ B$="map?":GOSUB INIT_CORE_SET_FUNCTION: REM A=35
+ B$="assoc":GOSUB INIT_CORE_SET_FUNCTION: REM A=36
+ B$="dissoc":GOSUB INIT_CORE_SET_FUNCTION: REM A=37
+ B$="get":GOSUB INIT_CORE_SET_FUNCTION: REM A=38
+ B$="contains?":GOSUB INIT_CORE_SET_FUNCTION: REM A=39
+ B$="keys":GOSUB INIT_CORE_SET_FUNCTION: REM A=40
+ B$="vals":GOSUB INIT_CORE_SET_FUNCTION: REM A=41
+
+ B$="sequential?":GOSUB INIT_CORE_SET_FUNCTION: REM A=42
+ B$="cons":GOSUB INIT_CORE_SET_FUNCTION: REM A=43
+ B$="concat":GOSUB INIT_CORE_SET_FUNCTION: REM A=44
+ B$="nth":GOSUB INIT_CORE_SET_FUNCTION: REM A=45
+ B$="first":GOSUB INIT_CORE_SET_FUNCTION: REM A=46
+ B$="rest":GOSUB INIT_CORE_SET_FUNCTION: REM A=47
+ B$="empty?":GOSUB INIT_CORE_SET_FUNCTION: REM A=48
+ B$="count":GOSUB INIT_CORE_SET_FUNCTION: REM A=49
+
+ B$="conj":GOSUB INIT_CORE_SET_FUNCTION: REM A=50
+ B$="seq":GOSUB INIT_CORE_SET_FUNCTION: REM A=51
+
+ B$="with-meta":GOSUB INIT_CORE_SET_FUNCTION: REM A=52
+ B$="meta":GOSUB INIT_CORE_SET_FUNCTION: REM A=53
+ B$="atom":GOSUB INIT_CORE_SET_FUNCTION: REM A=54
+ B$="atom?":GOSUB INIT_CORE_SET_FUNCTION: REM A=55
+ B$="deref":GOSUB INIT_CORE_SET_FUNCTION: REM A=56
+ B$="reset!":GOSUB INIT_CORE_SET_FUNCTION: REM A=57
+
+ B$="eval":GOSUB INIT_CORE_SET_FUNCTION: REM A=58
+ B$="read-file":GOSUB INIT_CORE_SET_FUNCTION: REM A=59
+ B$="pr-memory-summary":GOSUB INIT_CORE_SET_FUNCTION: REM A=60
+
+ REM these are in DO_TCO_FUNCTION
+ A=65
+ B$="apply":GOSUB INIT_CORE_SET_FUNCTION: REM A=65
+ B$="map":GOSUB INIT_CORE_SET_FUNCTION: REM A=66
+ B$="swap!":GOSUB INIT_CORE_SET_FUNCTION: REM A=67
+
+ RETURN
HCoop / jackhill / mal.git / blobdiff