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
$="try*" THEN GOTO EVAL_TRY
245 IF A
$="do" THEN GOTO EVAL_DO
246 IF A
$="if" THEN GOTO EVAL_IF
247 IF A
$="fn*" THEN GOTO EVAL_FN
251 A3
=Z
%(Z
%(Z
%(Z
%(A
+1)+1)+1)+2)
253 A2
=Z
%(Z
%(Z
%(A
+1)+1)+2)
260 GOSUB EVAL_GET_A2
: REM set A1 and A2
263 A
=A2
:CALL EVAL
: REM eval a2
266 IF ER
<>-2 THEN GOTO EVAL_RETURN
268 REM set a1 in env to a2
269 K
=A1
:C
=R
:GOSUB ENV_SET
274 GOSUB EVAL_GET_A2
: REM set A1 and A2
276 Q
=A2
:GOSUB PUSH_Q
: REM push/save A2
277 Q
=E
:GOSUB PUSH_Q
: REM push env for for later release
279 REM create new environment with outer as current environment
283 IF Z
%(A1
+1)=0 THEN GOTO EVAL_LET_LOOP_DONE
285 Q
=A1
:GOSUB PUSH_Q
: REM push A1
286 REM eval current A1 odd element
287 A
=Z
%(Z
%(A1
+1)+2):CALL EVAL
288 GOSUB POP_Q
:A1
=Q
: REM pop A1
290 IF ER
<>-2 THEN GOTO EVAL_LET_LOOP_DONE
292 REM set key/value in the environment
293 K
=Z
%(A1
+2):C
=R
:GOSUB ENV_SET
294 AY
=R
:GOSUB RELEASE
: REM release our use, ENV_SET took ownership
296 REM skip to the next pair of A1 elements
301 GOSUB POP_Q
:AY
=Q
: REM pop previous env
303 REM release previous environment if not the current EVAL env
305 IF AY
<>Q
THEN GOSUB RELEASE
307 GOSUB POP_Q
:A2
=Q
: REM pop A2
308 A
=A2
:GOTO EVAL_TCO_RECUR
: REM TCO loop
312 GOSUB PUSH_A
: REM push/save A
314 REM this must be EVAL_AST call #2 for EVAL_AST to return early
315 REM and for TCO to work
319 AY
=R
: REM get eval'd list for release
321 GOSUB POP_A
: REM pop/restore original A for LAST
322 GOSUB LAST
: REM get last element for return
323 A
=R
: REM new recur AST
326 GOSUB RELEASE
: REM release eval'd list
327 AY
=A
:GOSUB RELEASE
: REM release LAST value (not sure why)
329 GOTO EVAL_TCO_RECUR
: REM TCO loop
340 REM add quasiquote result to pending release queue to free when
341 REM next lower EVAL level returns (LV)
344 GOTO EVAL_TCO_RECUR
: REM TCO loop
347 REM PRINT "defmacro!"
348 GOSUB EVAL_GET_A2
: REM set A1 and A2
350 Q
=A1
:GOSUB PUSH_Q
: REM push A1
351 A
=A2
:CALL EVAL
: REM eval A2
352 GOSUB POP_Q
:A1
=Q
: REM pop A1
354 REM change function to macro
357 REM set A1 in env to A2
358 K
=A1
:C
=R
:GOSUB ENV_SET
362 REM PRINT "macroexpand"
367 REM since we are returning it unevaluated, inc the ref cnt
373 GOSUB EVAL_GET_A1
: REM set A1
375 GOSUB PUSH_A
: REM push/save A
376 A
=A1
:CALL EVAL
: REM eval A1
377 GOSUB POP_A
: REM pop/restore A
379 GOSUB EVAL_GET_A2
: REM set A1 and A2
381 REM if there is no error or catch block then return
382 IF ER
=-2 OR A2
=0 THEN GOTO EVAL_RETURN
384 REM create environment for the catch block eval
385 C
=E
:GOSUB ENV_NEW
:E
=R
387 A
=A2
:GOSUB EVAL_GET_A2
: REM set A1 and A2 from catch block
389 REM create object for ER=-1 type raw string errors
390 IF ER
=-1 THEN B
$=E$:T=4:GOSUB STRING:ER
=R
:GOSUB INC_REF_R
392 REM bind the catch symbol to the error object
393 K
=A1
:C
=ER
:GOSUB ENV_SET
394 AY
=R
:GOSUB RELEASE
: REM release our use, env took ownership
396 REM unset error for catch eval
404 GOSUB EVAL_GET_A1
: REM set A1
405 GOSUB PUSH_A
: REM push/save A
407 GOSUB POP_A
: REM pop/restore A
408 IF (R
=0) OR (R
=2) THEN GOTO EVAL_IF_FALSE
412 GOSUB EVAL_GET_A2
: REM set A1 and A2 after EVAL
413 A
=A2
:GOTO EVAL_TCO_RECUR
: REM TCO loop
416 REM if no false case (A3), return nil
418 IF R
<4 THEN R
=0:GOSUB INC_REF_R
:GOTO EVAL_RETURN
419 GOSUB EVAL_GET_A3
: REM set A1 - A3 after EVAL
420 A
=A3
:GOTO EVAL_TCO_RECUR
: REM TCO loop
423 GOSUB EVAL_GET_A2
: REM set A1 and A2
424 T
=10:L
=A2
:M
=A1
:N
=E
:GOSUB ALLOC
: REM mal function
430 REM if error, return f/args for release by caller
431 IF ER
<>-2 THEN GOTO EVAL_RETURN
433 REM push f/args for release after call
439 REM if metadata, get the actual object
441 IF T
=14 THEN F
=Z
%(F
+1):GOSUB TYPE_F
443 ON T
-8 GOTO EVAL_DO_FUNCTION
,EVAL_DO_MAL_FUNCTION
,EVAL_DO_MAL_FUNCTION
445 REM if error, pop and return f/args for release by caller
447 ER
=-1:E
$="apply of non
-function":GOTO EVAL_RETURN
451 IF Z%(F+1)<60 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP
452 REM for recur functions (apply, map, swap!), use GOTO
453 IF Z%(F+1)>60 THEN CALL DO_TCO_FUNCTION
454 EVAL_DO_FUNCTION_SKIP:
456 REM pop and release f/args
461 EVAL_DO_MAL_FUNCTION:
462 Q=E:GOSUB PUSH_Q: REM save the current environment for release
464 REM create new environ using env and params stored in function
465 C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS
467 REM release previous env if it is not the top one on the
468 REM stack (X%(X-2)) because our new env refers to it and
469 REM we no longer need to track it (since we are TCO recurring)
472 IF AY<>Q THEN GOSUB RELEASE
474 REM claim the AST before releasing the list containing it
475 A=Z%(F+1):Z%(A)=Z%(A)+32
476 REM add AST to pending release queue to free as soon as EVAL
477 REM actually returns (LV+1)
478 LV=LV+1:GOSUB PEND_A_LV:LV=LV-1
480 REM pop and release f/args
485 E=R:GOTO EVAL_TCO_RECUR: REM TCO loop
488 REM AZ=R: B=1: GOSUB PR_STR
489 REM PRINT "EVAL_RETURN R
: ["+R$+"] ("+STR
$(R)+"), LV
:"+STR$(LV)+",ER:"+STR$(ER)
491 REM release environment if not the top one on the stack
493 IF E<>Q THEN AY=E:GOSUB RELEASE
495 LV=LV-1: REM track basic return stack level
497 REM release everything we couldn't release earlier
504 REM pop A and E off the stack
512 AZ=A:B=1:GOSUB PR_STR
516 REM Assume D has repl_env
517 REM caller must release result
522 IF ER<>-2 THEN GOTO RE_DONE
527 REM Release memory from MAL_READ
529 RETURN: REM caller must release result of EVAL
532 REM Assume D has repl_env
538 IF ER<>-2 THEN GOTO REP_DONE
543 REM Release memory from MAL_READ and EVAL
554 C=0:GOSUB ENV_NEW:D=R
556 REM core.EXT: defined in Basic
557 E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env
559 ZT=ZI: REM top of memory after base repl_env
561 REM core.mal: defined using the language itself
562 A$="(def! not (fn* (a) (if a false true)))"
563 GOSUB RE
:AY
=R
:GOSUB RELEASE
565 A
$="(def! load-file (fn
* (f
) (eval (read
-file f
))))"
566 GOSUB RE:AY=R:GOSUB RELEASE
568 A$="(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs)"
569 A
$=A$+" (if (> (count xs
) 1) (nth xs
1) (throw
"+CHR$(34)+"odd number of"
570 A
$=A$+" forms
to cond
"+CHR$(34)+")) (cons 'cond (rest (rest xs)))))))"
571 GOSUB RE
:AY
=R
:GOSUB RELEASE
573 A
$="(defmacro! or (fn
* (& xs
) (if (empty? xs
) nil (if (= 1 (count xs
)) (first xs
)"
574 A$=A$+" `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))"
575 GOSUB RE
:AY
=R
:GOSUB RELEASE
577 REM load the args file
578 A
$="(def! -*ARGS
*- (load-file
"+CHR$(34)+".args.mal"+CHR$(34)+"))"
579 GOSUB RE:AY=R:GOSUB RELEASE
581 IF ER>-2 THEN GOSUB PRINT_ERROR:END
583 REM set the argument list
584 A$="(def! *ARGV* (rest -*ARGS*-))"
585 GOSUB RE
:AY
=R
:GOSUB RELEASE
587 REM get the first argument
588 A
$="(first -*ARGS
*-)"
591 REM no arguments, start REPL loop
592 IF R<16 THEN GOTO REPL_LOOP
594 REM if there is an argument, then run it as a program
597 REM free up first arg because we get it again
599 REM run a single mal program and exit
600 A$="(load-file (first -*ARGS*-))"
602 IF ER
<>-2 THEN GOSUB PRINT_ERROR
606 A
$="user> ":GOSUB READLINE: REM call input parser
607 IF EZ=1 THEN GOTO QUIT
608 IF R$="" THEN GOTO REPL_LOOP
610 A$=R$:CALL REP: REM call REP
612 IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP
617 REM GOSUB PR_MEMORY_SUMMARY_SMALL
622 REM if the error is an object, then print and free it
623 IF ER>=0 THEN AZ=ER:B=0:GOSUB PR_STR:E$=R$:AY=ER:GOSUB RELEASE