3 REM $INCLUDE: 'types.in.bas'
4 REM $INCLUDE: 'readline.in.bas'
5 REM $INCLUDE: 'reader.in.bas'
6 REM $INCLUDE: 'printer.in.bas'
7 REM $INCLUDE: 'env.in.bas'
8 REM $INCLUDE: 'core.in.bas'
10 REM $INCLUDE: 'debug.in.bas'
17 REM QUASIQUOTE(A) -> R
20 IF (Z
%(A
,0)AND 31)<6 OR (Z
%(A
,0)AND 31)>7 THEN GOTO QQ_QUOTE
21 IF (Z
%(A
,1)=0) THEN GOTO QQ_QUOTE
26 B
$="quote":T=5:GOSUB STRING
34 IF (Z
%(R
,0)AND 31)<>5 THEN GOTO QQ_SPLICE_UNQUOTE
35 IF S
$(Z%(R,1))<>"unquote" THEN GOTO QQ_SPLICE_UNQUOTE
37 R
=Z
%(A
,1)+1:GOSUB DEREF_R
44 REM rest of cases call quasiquote on ast[1..]
45 A
=Z
%(A
,1):CALL QUASIQUOTE
49 REM set A to ast[0] for last two cases
53 IF (Z
%(A
,0)AND 31)<6 OR (Z
%(A
,0)AND 31)>7 THEN GOTO QQ_DEFAULT
54 IF (Z
%(A
,1)=0) THEN GOTO QQ_DEFAULT
57 IF (Z
%(B
,0)AND 31)<>5 THEN GOTO QQ_DEFAULT
58 IF S
$(Z%(B,1))<>"splice-unquote" THEN QQ_DEFAULT
59 REM ['concat, ast[0][1], quasiquote(ast[1..])]
61 B
=Z
%(A
,1)+1:GOSUB DEREF_B
:B
=B
62 B
$="concat":T=5:GOSUB STRING:C
=R
64 REM release inner quasiquoted since outer list takes ownership
70 REM ['cons, quasiquote(ast[0]), quasiquote(ast[1..])]
73 REM A set above to ast[0]
78 B
$="cons":T=5:GOSUB STRING:C
=R
80 REM release inner quasiquoted since outer list takes ownership
87 REM MACROEXPAND(A, E) -> A:
93 IF (Z
%(A
,0)AND 31)<>6 THEN GOTO MACROEXPAND_DONE
95 IF Z
%(A
,1)=0 THEN GOTO MACROEXPAND_DONE
97 REM symbol? in first position
98 IF (Z
%(B
,0)AND 31)<>5 THEN GOTO MACROEXPAND_DONE
99 REM defined in environment?
101 IF R
=-1 THEN GOTO MACROEXPAND_DONE
104 IF (Z
%(B
,0)AND 31)<>11 THEN GOTO MACROEXPAND_DONE
106 F
=B
:AR
=Z
%(A
,1):CALL APPLY
110 REM if previous A was not the first A into macroexpand (i.e. an
111 REM intermediate form) then free it
112 IF A
<>AY
THEN GOSUB PEND_A_LV
114 IF ER
<>-2 THEN GOTO MACROEXPAND_DONE
115 GOTO MACROEXPAND_LOOP
118 GOSUB POP_Q
: REM pop original A
121 REM EVAL_AST(A, E) -> R
123 REM push A and E on the stack
127 IF ER
<>-2 THEN GOTO EVAL_AST_RETURN
132 IF T
=5 THEN GOTO EVAL_AST_SYMBOL
133 IF T
>=6 AND T
<=8 THEN GOTO EVAL_AST_SEQ
135 REM scalar: deref to actual value and inc ref cnt
146 REM allocate the first entry (T already set above)
149 REM push type of sequence
151 REM push sequence index
153 REM push future return value (new sequence)
155 REM push previous new sequence entry
159 REM check if we are done evaluating the source sequence
160 IF Z
%(A
,1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
162 REM if we are returning to DO, then skip last element
164 IF Q
=2 AND Z
%(Z
%(A
,1),1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
166 REM if hashmap, skip eval of even entries (keys)
167 Q
=3:GOSUB PEEK_Q_Q
:T
=Q
168 REM get and update index
171 IF T
=8 AND ((Q
-1)AND 1)=0 THEN GOTO EVAL_AST_DO_REF
172 GOTO EVAL_AST_DO_EVAL
175 R
=A
+1:GOSUB DEREF_R
: REM deref to target of referred entry
176 Z
%(R
,0)=Z
%(R
,0)+32: REM inc ref cnt of referred value
177 GOTO EVAL_AST_ADD_VALUE
180 REM call EVAL for each entry
183 GOSUB DEREF_R
: REM deref to target of evaluated entry
187 REM update previous value pointer to evaluated entry
191 IF ER
<>-2 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
193 REM allocate the next entry
194 REM same new sequence entry type
195 Q
=3:GOSUB PEEK_Q_Q
:T
=Q
198 REM update previous sequence entry value to point to new entry
201 REM update previous ptr to current entry
204 REM process the next sequence entry from source list
207 GOTO EVAL_AST_SEQ_LOOP
208 EVAL_AST_SEQ_LOOP_DONE:
210 REM if no error, get return value (new seq)
212 REM otherwise, free the return value and return nil
213 IF ER
<>-2 THEN R
=0:AY
=Q
:GOSUB RELEASE
215 REM pop previous, return, index and type
216 GOSUB POP_Q
:GOSUB POP_Q
:GOSUB POP_Q
:GOSUB POP_Q
220 REM pop A and E off the stack
227 LV
=LV
+1: REM track basic return stack level
229 REM push A and E on the stack
233 REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0))
237 IF ER
<>-2 THEN GOTO EVAL_RETURN
239 REM AZ=A:B=1:GOSUB PR_STR
240 REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]"
245 IF R
THEN GOTO APPLY_LIST
255 IF R
<>1 THEN GOTO EVAL_NOT_LIST
258 IF R
THEN R
=A
:Z
%(R
,0)=Z
%(R
,0)+32:GOTO EVAL_RETURN
261 R
=A0
:GOSUB DEREF_R
:A0
=R
264 IF (Z
%(A0
,0)AND 31)<>5 THEN A
$=""
265 IF (Z
%(A0
,0)AND 31)=5 THEN A
$=S$(Z%(A0,1))
267 IF A
$="def!" THEN GOTO EVAL_DEF
268 IF A
$="let*" THEN GOTO EVAL_LET
269 IF A
$="quote" THEN GOTO EVAL_QUOTE
270 IF A
$="quasiquote" THEN GOTO EVAL_QUASIQUOTE
271 IF A
$="defmacro!" THEN GOTO EVAL_DEFMACRO
272 IF A
$="macroexpand" THEN GOTO EVAL_MACROEXPAND
273 IF A
$="try*" THEN GOTO EVAL_TRY
274 IF A
$="do" THEN GOTO EVAL_DO
275 IF A
$="if" THEN GOTO EVAL_IF
276 IF A
$="fn*" THEN GOTO EVAL_FN
280 A3
=Z
%(Z
%(Z
%(A
,1),1),1)+1
281 R
=A3
:GOSUB DEREF_R
:A3
=R
284 R
=A2
:GOSUB DEREF_R
:A2
=R
287 R
=A1
:GOSUB DEREF_R
:A1
=R
292 GOSUB EVAL_GET_A2
: REM set A1 and A2
295 A
=A2
:CALL EVAL
: REM eval a2
298 IF ER
<>-2 THEN GOTO EVAL_RETURN
300 REM set a1 in env to a2
301 K
=A1
:C
=R
:GOSUB ENV_SET
306 GOSUB EVAL_GET_A2
: REM set A1 and A2
308 Q
=A2
:GOSUB PUSH_Q
: REM push/save A2
309 Q
=E
:GOSUB PUSH_Q
: REM push env for for later release
311 REM create new environment with outer as current environment
315 IF Z
%(A1
,1)=0 THEN GOTO EVAL_LET_LOOP_DONE
317 Q
=A1
:GOSUB PUSH_Q
: REM push A1
318 REM eval current A1 odd element
319 A
=Z
%(A1
,1)+1:CALL EVAL
320 GOSUB POP_Q
:A1
=Q
: REM pop A1
322 IF ER
<>-2 THEN GOTO EVAL_LET_LOOP_DONE
324 REM set environment: even A1 key to odd A1 eval'd above
325 K
=A1
+1:C
=R
:GOSUB ENV_SET
326 AY
=R
:GOSUB RELEASE
: REM release our use, ENV_SET took ownership
328 REM skip to the next pair of A1 elements
333 GOSUB POP_Q
:E4
=Q
: REM pop previous env
335 REM release previous environment if not the current EVAL env
337 IF E4
<>Q
THEN AY
=E4
:GOSUB RELEASE
339 GOSUB POP_Q
:A2
=Q
: REM pop A2
340 A
=A2
:GOTO EVAL_TCO_RECUR
: REM TCO loop
344 GOSUB PUSH_A
: REM push/save A
349 AY
=R
: REM get eval'd list for release
351 GOSUB POP_A
: REM pop/restore original A for LAST
352 GOSUB LAST
: REM get last element for return
353 A
=R
: REM new recur AST
356 GOSUB RELEASE
: REM release eval'd list
357 AY
=A
:GOSUB RELEASE
: REM release LAST value (not sure why)
359 GOTO EVAL_TCO_RECUR
: REM TCO loop
362 R
=Z
%(A
,1)+1:GOSUB DEREF_R
367 R
=Z
%(A
,1)+1:GOSUB DEREF_R
370 REM add quasiquote result to pending release queue to free when
371 REM next lower EVAL level returns (LV)
374 GOTO EVAL_TCO_RECUR
: REM TCO loop
377 REM PRINT "defmacro!"
378 GOSUB EVAL_GET_A2
: REM set A1 and A2
380 Q
=A1
:GOSUB PUSH_Q
: REM push A1
381 A
=A2
:CALL EVAL
: REM eval A2
382 GOSUB POP_Q
:A1
=Q
: REM pop A1
384 REM change function to macro
387 REM set A1 in env to A2
388 K
=A1
:C
=R
:GOSUB ENV_SET
392 REM PRINT "macroexpand"
393 R
=Z
%(A
,1)+1:GOSUB DEREF_R
397 REM since we are returning it unevaluated, inc the ref cnt
403 GOSUB EVAL_GET_A1
: REM set A1, A2, and A3
405 GOSUB PUSH_A
: REM push/save A
406 A
=A1
:CALL EVAL
: REM eval A1
407 GOSUB POP_A
: REM pop/restore A
409 REM if there is not error or catch block then return
410 IF ER
=-2 OR Z
%(A
,1)=0 THEN GOTO EVAL_RETURN
412 REM create environment for the catch block eval
413 C
=E
:GOSUB ENV_NEW
:E
=R
415 GOSUB EVAL_GET_A2
: REM set A1 and A2
416 A
=A2
:GOSUB EVAL_GET_A2
: REM set A1 and A2 from catch block
418 REM create object for ER=-1 type raw string errors
419 IF ER
=-1 THEN B
$=E$:T=4:GOSUB STRING:ER
=R
:Z
%(R
,0)=Z
%(R
,0)+32
421 REM bind the catch symbol to the error object
422 K
=A1
:C
=ER
:GOSUB ENV_SET
423 AY
=R
:GOSUB RELEASE
: REM release our use, env took ownership
425 REM unset error for catch eval
433 GOSUB EVAL_GET_A1
: REM set A1
434 GOSUB PUSH_A
: REM push/save A
436 GOSUB POP_A
: REM pop/restore A
437 IF (R
=0) OR (R
=1) THEN GOTO EVAL_IF_FALSE
441 GOSUB EVAL_GET_A2
: REM set A1 and A2 after EVAL
442 A
=A2
:GOTO EVAL_TCO_RECUR
: REM TCO loop
445 REM if no false case (A3), return nil
447 IF R
<4 THEN R
=0:GOTO EVAL_RETURN
448 GOSUB EVAL_GET_A3
: REM set A1 - A3 after EVAL
449 A
=A3
:GOTO EVAL_TCO_RECUR
: REM TCO loop
452 GOSUB EVAL_GET_A2
: REM set A1 and A2
453 A
=A2
:B
=A1
:GOSUB MAL_FUNCTION
459 REM if error, return f/args for release by caller
460 IF ER
<>-2 THEN GOTO EVAL_RETURN
462 REM push f/args for release after call
468 R
=F
:GOSUB DEREF_R
:F
=R
470 REM if metadata, get the actual object
471 IF (Z
%(F
,0)AND 31)>=16 THEN F
=Z
%(F
,1)
473 IF (Z
%(F
,0)AND 31)=9 THEN GOTO EVAL_DO_FUNCTION
474 IF (Z
%(F
,0)AND 31)=10 THEN GOTO EVAL_DO_MAL_FUNCTION
476 REM if error, pop and return f/args for release by caller
478 ER
=-1:E
$="apply of non
-function":GOTO EVAL_RETURN
482 IF Z%(F,1)<60 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP
483 REM for recur functions (apply, map, swap!), use GOTO
484 IF Z%(F,1)>60 THEN CALL DO_TCO_FUNCTION
485 EVAL_DO_FUNCTION_SKIP:
487 REM pop and release f/args
492 EVAL_DO_MAL_FUNCTION:
493 E4=E: REM save the current environment for release
495 REM create new environ using env stored with function
496 C=Z%(F+1,1):A=Z%(F+1,0):B=AR:GOSUB ENV_NEW_BINDS
498 REM release previous env if it is not the top one on the
499 REM stack (X%(X-2)) because our new env refers to it and
500 REM we no longer need to track it (since we are TCO recurring)
502 IF E4<>Q THEN AY=E4:GOSUB RELEASE
504 REM claim the AST before releasing the list containing it
505 A=Z%(F,1):Z%(A,0)=Z%(A,0)+32
506 REM add AST to pending release queue to free as soon as EVAL
507 REM actually returns (LV+1)
508 LV=LV+1:GOSUB PEND_A_LV:LV=LV-1
510 REM pop and release f/args
515 E=R:GOTO EVAL_TCO_RECUR: REM TCO loop
518 REM AZ=R: B=1: GOSUB PR_STR
519 REM PRINT "EVAL_RETURN R
: ["+R$+"] ("+STR
$(R)+"), LV
:"+STR$(LV)+",ER:"+STR$(ER)
521 REM release environment if not the top one on the stack
523 IF E<>Q THEN AY=E:GOSUB RELEASE
525 LV=LV-1: REM track basic return stack level
527 REM release everything we couldn't release earlier
534 REM pop A and E off the stack
542 AZ=A:B=1:GOSUB PR_STR
546 REM Assume D has repl_env
547 REM caller must release result
552 IF ER<>-2 THEN GOTO RE_DONE
557 REM Release memory from MAL_READ
558 IF R1<>0 THEN AY=R1:GOSUB RELEASE
559 RETURN: REM caller must release result of EVAL
562 REM Assume D has repl_env
567 IF ER<>-2 THEN GOTO REP_DONE
571 IF ER<>-2 THEN GOTO REP_DONE
577 REM Release memory from MAL_READ and EVAL
578 IF R2<>0 THEN AY=R2:GOSUB RELEASE
579 IF R1<>0 THEN AY=R1:GOSUB RELEASE
590 C=-1:GOSUB ENV_NEW:D=R
592 REM core.EXT: defined in Basic
593 E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env
595 ZT=ZI: REM top of memory after base repl_env
597 REM core.mal: defined using the language itself
598 #cbm A$="(def! *host-language* "+CHR
$(34)+"C64 BASIC
"+CHR$(34)+")"
599 #qbasic A$="(def! *host-language* "+CHR
$(34)+"QBasic"+CHR$(34)+")"
600 GOSUB RE
:AY
=R
:GOSUB RELEASE
602 A
$="(def! not (fn
* (a
) (if a
false true)))"
603 GOSUB RE:AY=R:GOSUB RELEASE
605 A$="(def! load-file (fn* (f) (eval (read-file f))))"
606 GOSUB RE
:AY
=R
:GOSUB RELEASE
608 A
$="(defmacro! cond (fn
* (& xs
) (if (> (count xs
) 0) (list
'if (first xs)"
609 A
$=A$+" (if (> (count xs
) 1) (nth xs
1) (throw
"+CHR$(34)+"odd number of"
610 A
$=A$+" forms
to cond
"+CHR$(34)+")) (cons 'cond (rest (rest xs)))))))"
611 GOSUB RE
:AY
=R
:GOSUB RELEASE
613 A
$="(def! *gensym
-counter
* (atom
0))"
614 GOSUB RE:AY=R:GOSUB RELEASE
616 A$="(def! gensym (fn* [] (symbol (str "+CHR
$(34)+"G__"+CHR$(34)
617 A
$=A$+" (swap
! *gensym
-counter
* (fn
* [x
] (+ 1 x
)))))))"
618 GOSUB RE:AY=R:GOSUB RELEASE
620 A$="(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs)"
621 A
$=A$+" (let* (c (gensym
)) `
(let* (~c ~
(first xs
))"
622 A$=A$+" (if ~c ~c (or ~@(rest xs)))))))))"
623 GOSUB RE
:AY
=R
:GOSUB RELEASE
625 REM load the args file
626 A
$="(def! -*ARGS
*- (load-file
"+CHR$(34)+".args.mal"+CHR$(34)+"))"
627 GOSUB RE:AY=R:GOSUB RELEASE
629 REM set the argument list
630 A$="(def! *ARGV* (rest -*ARGS*-))"
631 GOSUB RE
:AY
=R
:GOSUB RELEASE
633 REM get the first argument
634 A
$="(first -*ARGS
*-)"
637 REM if there is an argument, then run it as a program
638 IF R<>0 THEN AY=R:GOSUB RELEASE:GOTO RUN_PROG
639 REM no arguments, start REPL loop
640 IF R=0 THEN GOTO REPL
643 REM run a single mal program and exit
644 A$="(load-file (first -*ARGS*-))"
646 IF ER
<>-2 THEN GOSUB PRINT_ERROR
650 REM print the REPL startup header
651 REM save memory by printing this directly
652 #cbm PRINT
"Mal [C64 BASIC]"
653 #qbasic PRINT
"Mal [C64 QBasic]"
656 A
$="user> ":GOSUB READLINE: REM call input parser
657 IF EZ=1 THEN GOTO QUIT
659 A$=R$:CALL REP: REM call REP
661 IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP
666 GOSUB PR_MEMORY_SUMMARY
670 REM if the error is an object, then print and free it
671 IF ER>=0 THEN AZ=ER:B=0:GOSUB PR_STR:E$=R$:AY=ER:GOSUB RELEASE