3 REM $INCLUDE: 'mem.in.bas'
4 REM $INCLUDE: 'types.in.bas'
5 REM $INCLUDE: 'readline.in.bas'
6 REM $INCLUDE: 'reader.in.bas'
7 REM $INCLUDE: 'printer.in.bas'
8 REM $INCLUDE: 'env.in.bas'
9 REM $INCLUDE: 'core.in.bas'
11 REM $INCLUDE: 'debug.in.bas'
18 REM QUASIQUOTE(A) -> R
22 IF T
<6 OR T
>7 THEN GOTO QQ_QUOTE
23 IF (Z
%(A
+1)=0) THEN GOTO QQ_QUOTE
28 B
$="quote":T=5:GOSUB STRING
36 IF (Z
%(R
)AND 31)<>5 THEN GOTO QQ_SPLICE_UNQUOTE
37 IF S
$(Z%(R+1))<>"unquote" THEN GOTO QQ_SPLICE_UNQUOTE
46 REM rest of cases call quasiquote on ast[1..]
47 A
=Z
%(A
+1):CALL QUASIQUOTE
51 REM set A to ast[0] for last two cases
56 IF T
<6 OR T
>7 THEN GOTO QQ_DEFAULT
57 IF (Z
%(A
+1)=0) THEN GOTO QQ_DEFAULT
60 IF (Z
%(B
)AND 31)<>5 THEN GOTO QQ_DEFAULT
61 IF S
$(Z%(B+1))<>"splice-unquote" THEN QQ_DEFAULT
62 REM ['concat, ast[0][1], quasiquote(ast[1..])]
65 B
$="concat":T=5:GOSUB STRING:C
=R
67 REM release inner quasiquoted since outer list takes ownership
73 REM ['cons, quasiquote(ast[0]), quasiquote(ast[1..])]
76 REM A set above to ast[0]
81 B
$="cons":T=5:GOSUB STRING:C
=R
83 REM release inner quasiquoted since outer list takes ownership
90 REM MACROEXPAND(A, E) -> A:
97 IF T
<>6 THEN GOTO MACROEXPAND_DONE
99 IF Z
%(A
+1)=0 THEN GOTO MACROEXPAND_DONE
101 REM symbol? in first position
102 IF (Z
%(B
)AND 31)<>5 THEN GOTO MACROEXPAND_DONE
103 REM defined in environment?
105 IF R
=-1 THEN GOTO MACROEXPAND_DONE
108 IF (Z
%(B
)AND 31)<>11 THEN GOTO MACROEXPAND_DONE
110 F
=B
:AR
=Z
%(A
+1):CALL APPLY
114 REM if previous A was not the first A into macroexpand (i.e. an
115 REM intermediate form) then free it
116 IF A
<>AY
THEN GOSUB PEND_A_LV
118 IF ER
<>-2 THEN GOTO MACROEXPAND_DONE
119 GOTO MACROEXPAND_LOOP
122 GOSUB POP_Q
: REM pop original A
125 REM EVAL_AST(A, E) -> R
127 REM push A and E on the stack
131 IF ER
<>-2 THEN GOTO EVAL_AST_RETURN
134 IF T
=5 THEN GOTO EVAL_AST_SYMBOL
135 IF T
>=6 AND T
<=8 THEN GOTO EVAL_AST_SEQ
137 REM scalar: deref to actual value and inc ref cnt
148 REM setup the stack for the loop
152 REM check if we are done evaluating the source sequence
153 IF Z
%(A
+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
155 REM if we are returning to DO, then skip last element
156 REM The EVAL_DO call to EVAL_AST must be call #2 for EVAL_AST to
157 REM return early and for TCO to work
159 IF Q
=2 AND Z
%(Z
%(A
+1)+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
161 REM call EVAL for each entry
163 IF T
<>8 THEN A
=Z
%(A
+2)
164 IF T
=8 THEN A
=Z
%(A
+3)
165 Q
=T
:GOSUB PUSH_Q
: REM push/save type
167 GOSUB POP_Q
:T
=Q
: REM pop/restore type
171 REM if error, release the unattached element
172 REM TODO: is R=0 correct?
173 IF ER
<>-2 THEN AY
=R
:GOSUB RELEASE
:R
=0:GOTO EVAL_AST_SEQ_LOOP_DONE
175 REM for hash-maps, copy the key (inc ref since we are going to
176 REM release it below)
177 IF T
=8 THEN N
=M
:M
=Z
%(A
+2):Z
%(M
)=Z
%(M
)+32
180 REM update the return sequence structure
181 REM release N (and M if T=8) since seq takes full ownership
182 C
=1:GOSUB MAP_LOOP_UPDATE
184 REM process the next sequence entry from source list
187 GOTO EVAL_AST_SEQ_LOOP
188 EVAL_AST_SEQ_LOOP_DONE:
189 REM cleanup stack and get return value
194 REM pop A and E off the stack
201 LV
=LV
+1: REM track basic return stack level
203 REM push A and E on the stack
207 REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0))
211 IF ER
<>-2 THEN GOTO EVAL_RETURN
213 REM AZ=A:B=1:GOSUB PR_STR
214 REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]"
217 IF R
THEN GOTO APPLY_LIST
227 IF R
<>1 THEN GOTO EVAL_NOT_LIST
230 IF R
THEN R
=A
:GOSUB INC_REF_R
:GOTO EVAL_RETURN
235 IF (Z
%(A0
)AND 31)<>5 THEN A
$=""
236 IF (Z
%(A0
)AND 31)=5 THEN A
$=S$(Z%(A0+1))
238 IF A
$="def!" THEN GOTO EVAL_DEF
239 IF A
$="let*" THEN GOTO EVAL_LET
240 IF A
$="quote" THEN GOTO EVAL_QUOTE
241 IF A
$="quasiquote" THEN GOTO EVAL_QUASIQUOTE
242 IF A
$="defmacro!" THEN GOTO EVAL_DEFMACRO
243 IF A
$="macroexpand" THEN GOTO EVAL_MACROEXPAND
244 IF A
$="do" THEN GOTO EVAL_DO
245 IF A
$="if" THEN GOTO EVAL_IF
246 IF A
$="fn*" THEN GOTO EVAL_FN
250 A3
=Z
%(Z
%(Z
%(Z
%(A
+1)+1)+1)+2)
252 A2
=Z
%(Z
%(Z
%(A
+1)+1)+2)
259 GOSUB EVAL_GET_A2
: REM set A1 and A2
262 A
=A2
:CALL EVAL
: REM eval a2
265 IF ER
<>-2 THEN GOTO EVAL_RETURN
267 REM set a1 in env to a2
268 K
=A1
:C
=R
:GOSUB ENV_SET
273 GOSUB EVAL_GET_A2
: REM set A1 and A2
275 Q
=A2
:GOSUB PUSH_Q
: REM push/save A2
276 Q
=E
:GOSUB PUSH_Q
: REM push env for for later release
278 REM create new environment with outer as current environment
282 IF Z
%(A1
+1)=0 THEN GOTO EVAL_LET_LOOP_DONE
284 Q
=A1
:GOSUB PUSH_Q
: REM push A1
285 REM eval current A1 odd element
286 A
=Z
%(Z
%(A1
+1)+2):CALL EVAL
287 GOSUB POP_Q
:A1
=Q
: REM pop A1
289 IF ER
<>-2 THEN GOTO EVAL_LET_LOOP_DONE
291 REM set key/value in the environment
292 K
=Z
%(A1
+2):C
=R
:GOSUB ENV_SET
293 AY
=R
:GOSUB RELEASE
: REM release our use, ENV_SET took ownership
295 REM skip to the next pair of A1 elements
300 GOSUB POP_Q
:AY
=Q
: REM pop previous env
302 REM release previous environment if not the current EVAL env
304 IF AY
<>Q
THEN GOSUB RELEASE
306 GOSUB POP_Q
:A2
=Q
: REM pop A2
307 A
=A2
:GOTO EVAL_TCO_RECUR
: REM TCO loop
311 GOSUB PUSH_A
: REM push/save A
313 REM this must be EVAL_AST call #2 for EVAL_AST to return early
314 REM and for TCO to work
318 AY
=R
: REM get eval'd list for release
320 GOSUB POP_A
: REM pop/restore original A for LAST
321 GOSUB LAST
: REM get last element for return
322 A
=R
: REM new recur AST
325 GOSUB RELEASE
: REM release eval'd list
326 AY
=A
:GOSUB RELEASE
: REM release LAST value (not sure why)
328 GOTO EVAL_TCO_RECUR
: REM TCO loop
339 REM add quasiquote result to pending release queue to free when
340 REM next lower EVAL level returns (LV)
343 GOTO EVAL_TCO_RECUR
: REM TCO loop
346 REM PRINT "defmacro!"
347 GOSUB EVAL_GET_A2
: REM set A1 and A2
349 Q
=A1
:GOSUB PUSH_Q
: REM push A1
350 A
=A2
:CALL EVAL
: REM eval A2
351 GOSUB POP_Q
:A1
=Q
: REM pop A1
353 REM change function to macro
356 REM set A1 in env to A2
357 K
=A1
:C
=R
:GOSUB ENV_SET
361 REM PRINT "macroexpand"
366 REM since we are returning it unevaluated, inc the ref cnt
371 GOSUB EVAL_GET_A1
: REM set A1
372 GOSUB PUSH_A
: REM push/save A
374 GOSUB POP_A
: REM pop/restore A
375 IF (R
=0) OR (R
=2) THEN GOTO EVAL_IF_FALSE
379 GOSUB EVAL_GET_A2
: REM set A1 and A2 after EVAL
380 A
=A2
:GOTO EVAL_TCO_RECUR
: REM TCO loop
383 REM if no false case (A3), return nil
385 IF R
<4 THEN R
=0:GOSUB INC_REF_R
:GOTO EVAL_RETURN
386 GOSUB EVAL_GET_A3
: REM set A1 - A3 after EVAL
387 A
=A3
:GOTO EVAL_TCO_RECUR
: REM TCO loop
390 GOSUB EVAL_GET_A2
: REM set A1 and A2
391 T
=10:L
=A2
:M
=A1
:N
=E
:GOSUB ALLOC
: REM mal function
397 REM if error, return f/args for release by caller
398 IF ER
<>-2 THEN GOTO EVAL_RETURN
400 REM push f/args for release after call
406 REM if metadata, get the actual object
408 IF T
=14 THEN F
=Z
%(F
+1):GOSUB TYPE_F
410 ON T
-8 GOTO EVAL_DO_FUNCTION
,EVAL_DO_MAL_FUNCTION
,EVAL_DO_MAL_FUNCTION
412 REM if error, pop and return f/args for release by caller
414 ER
=-1:E
$="apply of non
-function":GOTO EVAL_RETURN
418 IF Z%(F+1)<60 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP
419 REM for recur functions (apply, map, swap!), use GOTO
420 IF Z%(F+1)>60 THEN CALL DO_TCO_FUNCTION
421 EVAL_DO_FUNCTION_SKIP:
423 REM pop and release f/args
428 EVAL_DO_MAL_FUNCTION:
429 Q=E:GOSUB PUSH_Q: REM save the current environment for release
431 REM create new environ using env and params stored in function
432 C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS
434 REM release previous env if it is not the top one on the
435 REM stack (X%(X-2)) because our new env refers to it and
436 REM we no longer need to track it (since we are TCO recurring)
439 IF AY<>Q THEN GOSUB RELEASE
441 REM claim the AST before releasing the list containing it
442 A=Z%(F+1):Z%(A)=Z%(A)+32
443 REM add AST to pending release queue to free as soon as EVAL
444 REM actually returns (LV+1)
445 LV=LV+1:GOSUB PEND_A_LV:LV=LV-1
447 REM pop and release f/args
452 E=R:GOTO EVAL_TCO_RECUR: REM TCO loop
455 REM AZ=R: B=1: GOSUB PR_STR
456 REM PRINT "EVAL_RETURN R
: ["+R$+"] ("+STR
$(R)+"), LV
:"+STR$(LV)+",ER:"+STR$(ER)
458 REM release environment if not the top one on the stack
460 IF E<>Q THEN AY=E:GOSUB RELEASE
462 LV=LV-1: REM track basic return stack level
464 REM release everything we couldn't release earlier
471 REM pop A and E off the stack
479 AZ=A:B=1:GOSUB PR_STR
483 REM Assume D has repl_env
484 REM caller must release result
489 IF ER<>-2 THEN GOTO RE_DONE
494 REM Release memory from MAL_READ
496 RETURN: REM caller must release result of EVAL
499 REM Assume D has repl_env
505 IF ER<>-2 THEN GOTO REP_DONE
510 REM Release memory from MAL_READ and EVAL
521 C=0:GOSUB ENV_NEW:D=R
523 REM core.EXT: defined in Basic
524 E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env
526 ZT=ZI: REM top of memory after base repl_env
528 REM core.mal: defined using the language itself
529 A$="(def! not (fn* (a) (if a false true)))"
530 GOSUB RE
:AY
=R
:GOSUB RELEASE
532 A
$="(def! load-file (fn
* (f
) (eval (read
-file f
))))"
533 GOSUB RE:AY=R:GOSUB RELEASE
535 A$="(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs)"
536 A
$=A$+" (if (> (count xs
) 1) (nth xs
1) (throw
"+CHR$(34)+"odd number of"
537 A
$=A$+" forms
to cond
"+CHR$(34)+")) (cons 'cond (rest (rest xs)))))))"
538 GOSUB RE
:AY
=R
:GOSUB RELEASE
540 A
$="(defmacro! or (fn
* (& xs
) (if (empty? xs
) nil (if (= 1 (count xs
)) (first xs
)"
541 A$=A$+" `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))"
542 GOSUB RE
:AY
=R
:GOSUB RELEASE
544 REM load the args file
545 A
$="(def! -*ARGS
*- (load-file
"+CHR$(34)+".args.mal"+CHR$(34)+"))"
546 GOSUB RE:AY=R:GOSUB RELEASE
548 IF ER>-2 THEN GOSUB PRINT_ERROR:END
550 REM set the argument list
551 A$="(def! *ARGV* (rest -*ARGS*-))"
552 GOSUB RE
:AY
=R
:GOSUB RELEASE
554 REM get the first argument
555 A
$="(first -*ARGS
*-)"
558 REM no arguments, start REPL loop
559 IF R<16 THEN GOTO REPL_LOOP
561 REM if there is an argument, then run it as a program
564 REM free up first arg because we get it again
566 REM run a single mal program and exit
567 A$="(load-file (first -*ARGS*-))"
569 IF ER
<>-2 THEN GOSUB PRINT_ERROR
573 A
$="user> ":GOSUB READLINE: REM call input parser
574 IF EZ=1 THEN GOTO QUIT
575 IF R$="" THEN GOTO REPL_LOOP
577 A$=R$:CALL REP: REM call REP
579 IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP
584 REM GOSUB PR_MEMORY_SUMMARY_SMALL