1 REM POKE 1, PEEK(1)AND248: REM enable all ROM areas as RAM
2 REM POKE 55,0: POKE 56,192: CLR: REM move BASIC end from $A000 to $C000
5 REM $INCLUDE: 'readline.in.bas'
6 REM $INCLUDE: 'types.in.bas'
7 REM $INCLUDE: 'reader.in.bas'
8 REM $INCLUDE: 'printer.in.bas'
9 REM $INCLUDE: 'env.in.bas'
10 REM $INCLUDE: 'core.in.bas'
12 REM $INCLUDE: 'debug.in.bas'
22 IF (Z
%(B
,0)AND31
)<>6 AND (Z
%(B
,0)AND31
)<>7 THEN RETURN
23 IF (Z
%(B
,1)=0) THEN RETURN
27 REM QUASIQUOTE(A) -> R
30 IF R
=1 THEN GOTO QQ_UNQUOTE
32 AS$="quote":T=5:GOSUB STRING
40 IF (Z
%(R
,0)AND31
)<>5 THEN GOTO QQ_SPLICE_UNQUOTE
41 IF S
$(Z%(R,1))<>"unquote" THEN GOTO QQ_SPLICE_UNQUOTE
43 R
=Z
%(A
,1)+1:GOSUB DEREF_R
49 REM push A on the stack
51 REM rest of cases call quasiquote on ast[1..]
52 A
=Z
%(A
,1):GOSUB QUASIQUOTE
:T6
=R
53 REM pop A off the stack
56 REM set A to ast[0] for last two cases
60 IF R
=0 THEN GOTO QQ_DEFAULT
62 IF (Z
%(B
,0)AND31
)<>5 THEN GOTO QQ_DEFAULT
63 IF S
$(Z%(B,1))<>"splice-unquote" THEN QQ_DEFAULT
64 REM ['concat, ast[0][1], quasiquote(ast[1..])]
66 B
=Z
%(A
,1)+1:GOSUB DEREF_B
:B2
=B
67 AS$="concat":T=5:GOSUB STRING:B3
=R
69 REM release inner quasiquoted since outer list takes ownership
75 REM ['cons, quasiquote(ast[0]), quasiquote(ast[1..])]
77 REM push T6 on the stack
79 REM A set above to ast[0]
81 REM pop T6 off the stack
84 AS$="cons":T=5:GOSUB STRING:B3
=R
86 REM release inner quasiquoted since outer list takes ownership
92 REM MACROEXPAND(A, E) -> A:
99 IF (Z
%(A
,0)AND31
)<>6 THEN GOTO MACROEXPAND_DONE
101 IF Z
%(A
,1)=0 THEN GOTO MACROEXPAND_DONE
103 REM symbol? in first position
104 IF (Z
%(B
,0)AND31
)<>5 THEN GOTO MACROEXPAND_DONE
105 REM defined in environment?
107 IF R
=-1 THEN GOTO MACROEXPAND_DONE
110 IF (Z
%(B
,0)AND31
)<>11 THEN GOTO MACROEXPAND_DONE
113 F
=B
:AR
=Z
%(A
,1):GOSUB APPLY
117 REM if previous A was not the first A into macroexpand (i.e. an
118 REM intermediate form) then free it
119 IF A
<>AY
THEN Y
=Y
+1:Y
%(Y
,0)=A
:Y
%(Y
,1)=LV
121 IF ER
<>-2 THEN GOTO MACROEXPAND_DONE
122 GOTO MACROEXPAND_LOOP
125 X
=X
-1: REM pop original A
128 REM EVAL_AST(A, E) -> R
129 REM called using GOTO to avoid basic return address stack usage
130 REM top of stack should have return label index
132 REM push A and E on the stack
133 X
=X
+2:X
%(X
-1)=E
:X
%(X
)=A
135 IF ER
<>-2 THEN GOTO EVAL_AST_RETURN
140 IF T
=5 THEN GOTO EVAL_AST_SYMBOL
141 IF T
>=6 AND T
<=8 THEN GOTO EVAL_AST_SEQ
143 REM scalar: deref to actual value and inc ref cnt
153 REM allocate the first entry (T already set above)
156 REM make space on the stack
158 REM push type of sequence
160 REM push sequence index
162 REM push future return value (new sequence)
164 REM push previous new sequence entry
171 REM check if we are done evaluating the source sequence
172 IF Z
%(A
,1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
174 REM if hashmap, skip eval of even entries (keys)
175 IF (X
%(X
-3)=8) AND ((X
%(X
-2) AND 1)=0) THEN GOTO EVAL_AST_DO_REF
176 GOTO EVAL_AST_DO_EVAL
179 R
=A
+1:GOSUB DEREF_R
: REM deref to target of referred entry
180 Z
%(R
,0)=Z
%(R
,0)+32: REM inc ref cnt of referred value
181 GOTO EVAL_AST_ADD_VALUE
184 REM call EVAL for each entry
187 GOSUB DEREF_R
: REM deref to target of evaluated entry
191 REM update previous value pointer to evaluated entry
194 IF ER
<>-2 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
196 REM allocate the next entry
197 REM same new sequence entry type
198 T
=X
%(X
-3):L
=0:N
=0:GOSUB ALLOC
200 REM update previous sequence entry value to point to new entry
202 REM update previous ptr to current entry
205 REM process the next sequence entry from source list
208 GOTO EVAL_AST_SEQ_LOOP
209 EVAL_AST_SEQ_LOOP_DONE:
210 REM if no error, get return value (new seq)
211 IF ER
=-2 THEN R
=X
%(X
-1)
212 REM otherwise, free the return value and return nil
213 IF ER
<>-2 THEN R
=0:AY
=X
%(X
-1):GOSUB RELEASE
215 REM pop previous, return, index and type
220 REM pop A and E off the stack
221 E
=X
%(X
-1):A
=X
%(X
):X
=X
-2
223 REM pop EVAL AST return label/address
225 ON RN
GOTO EVAL_AST_RETURN_1
,EVAL_AST_RETURN_2
,EVAL_AST_RETURN_3
230 LV
=LV
+1: REM track basic return stack level
232 REM push A and E on the stack
233 X
=X
+2:X
%(X
-1)=E
:X
%(X
)=A
237 REM AZ=A:PR=1:GOSUB PR_STR
238 REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]"
243 IF R
THEN GOTO APPLY_LIST
246 REM push EVAL_AST return label/address
257 IF R
<>1 THEN GOTO EVAL_NOT_LIST
260 IF R
THEN R
=A
:Z
%(R
,0)=Z
%(R
,0)+32:GOTO EVAL_RETURN
263 R
=A0
:GOSUB DEREF_R
:A0
=R
266 IF (Z
%(A0
,0)AND31
)<>5 THEN A
$=""
267 IF (Z
%(A0
,0)AND31
)=5 THEN A
$=S$(Z%(A0,1))
269 IF A
$="def!" THEN GOTO EVAL_DEF
270 IF A
$="let*" THEN GOTO EVAL_LET
271 IF A
$="quote" THEN GOTO EVAL_QUOTE
272 IF A
$="quasiquote" THEN GOTO EVAL_QUASIQUOTE
273 IF A
$="defmacro!" THEN GOTO EVAL_DEFMACRO
274 IF A
$="macroexpand" THEN GOTO EVAL_MACROEXPAND
275 IF A
$="try*" THEN GOTO EVAL_TRY
276 IF A
$="do" THEN GOTO EVAL_DO
277 IF A
$="if" THEN GOTO EVAL_IF
278 IF A
$="fn*" THEN GOTO EVAL_FN
282 A3
=Z
%(Z
%(Z
%(A
,1),1),1)+1
283 R
=A3
:GOSUB DEREF_R
:A3
=R
286 R
=A2
:GOSUB DEREF_R
:A2
=R
289 R
=A1
:GOSUB DEREF_R
:A1
=R
294 GOSUB EVAL_GET_A2
: REM set A1 and A2
296 X
=X
+1:X
%(X
)=A1
: REM push A1
297 A
=A2
:GOSUB EVAL
: REM eval a2
298 A1
=X
%(X
):X
=X
-1: REM pop A1
300 IF ER
<>-2 THEN GOTO EVAL_RETURN
302 REM set a1 in env to a2
303 K
=A1
:V
=R
:GOSUB ENV_SET
308 GOSUB EVAL_GET_A2
: REM set A1 and A2
310 X
=X
+1:X
%(X
)=A2
: REM push/save A2
311 X
=X
+1:X
%(X
)=E
: REM push env for for later release
313 REM create new environment with outer as current environment
317 IF Z
%(A1
,1)=0 THEN GOTO EVAL_LET_LOOP_DONE
319 X
=X
+1:X
%(X
)=A1
: REM push A1
320 REM eval current A1 odd element
321 A
=Z
%(A1
,1)+1:GOSUB EVAL
322 A1
=X
%(X
):X
=X
-1: REM pop A1
324 REM set environment: even A1 key to odd A1 eval'd above
325 K
=A1
+1:V
=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 E4
=X
%(X
):X
=X
-1: REM pop previous env
335 REM release previous environment if not the current EVAL env
336 IF E4
<>X
%(X
-2) THEN AY
=E4
:GOSUB RELEASE
338 A2
=X
%(X
):X
=X
-1: REM pop A2
339 A
=A2
:GOTO EVAL_TCO_RECUR
: REM TCO loop
346 REM push EVAL_AST return label/address
351 X
=X
+1:X
%(X
)=R
: REM push eval'd list
352 A
=R
:GOSUB LAST
: REM return the last element
353 AY
=X
%(X
):X
=X
-1: REM pop eval'd list
354 GOSUB RELEASE
: REM release the eval'd list
358 R
=Z
%(A
,1)+1:GOSUB DEREF_R
363 R
=Z
%(A
,1)+1:GOSUB DEREF_R
365 REM add quasiquote result to pending release queue to free when
366 REM next lower EVAL level returns (LV)
367 Y
=Y
+1:Y
%(Y
,0)=R
:Y
%(Y
,1)=LV
369 A
=R
:GOTO EVAL_TCO_RECUR
: REM TCO loop
372 REM PRINT "defmacro!"
373 GOSUB EVAL_GET_A2
: REM set A1 and A2
375 X
=X
+1:X
%(X
)=A1
: REM push A1
376 A
=A2
:GOSUB EVAL
: REM eval A2
377 A1
=X
%(X
):X
=X
-1: REM pop A1
379 REM change function to macro
382 REM set A1 in env to A2
383 K
=A1
:V
=R
:GOSUB ENV_SET
387 REM PRINT "macroexpand"
388 R
=Z
%(A
,1)+1:GOSUB DEREF_R
389 A
=R
:GOSUB MACROEXPAND
:R
=A
391 REM since we are returning it unevaluated, inc the ref cnt
397 GOSUB EVAL_GET_A1
: REM set A1, A2, and A3
399 X
=X
+1:X
%(X
)=A
: REM push/save A
400 A
=A1
:GOSUB EVAL
: REM eval A1
401 A
=X
%(X
):X
=X
-1: REM pop/restore A
403 REM if there is not error or catch block then return
404 IF ER
=-2 OR Z
%(A
,1)=0 THEN GOTO EVAL_RETURN
406 REM create environment for the catch block eval
407 O
=E
:GOSUB ENV_NEW
:E
=R
409 GOSUB EVAL_GET_A2
: REM set A1 and A2
410 A
=A2
:GOSUB EVAL_GET_A2
: REM set A1 and A2 from catch block
412 REM create object for ER=-1 type raw string errors
413 IF ER
=-1 THEN AS$=ER$:T=4:GOSUB STRING:ER
=R
:Z
%(R
,0)=Z
%(R
,0)+32
415 REM bind the catch symbol to the error object
416 K
=A1
:V
=ER
:GOSUB ENV_SET
417 AY
=R
:GOSUB RELEASE
: REM release out use, env took ownership
419 REM unset error for catch eval
427 GOSUB EVAL_GET_A1
: REM set A1
433 IF (R
=0) OR (R
=1) THEN GOTO EVAL_IF_FALSE
437 GOSUB EVAL_GET_A2
: REM set A1 and A2 after EVAL
438 A
=A2
:GOTO EVAL_TCO_RECUR
: REM TCO loop
441 REM if no false case (A3), return nil
442 IF Z
%(Z
%(Z
%(A
,1),1),1)=0 THEN R
=0:GOTO EVAL_RETURN
443 GOSUB EVAL_GET_A3
: REM set A1 - A3 after EVAL
444 A
=A3
:GOTO EVAL_TCO_RECUR
: REM TCO loop
447 GOSUB EVAL_GET_A2
: REM set A1 and A2
448 A
=A2
:P
=A1
:GOSUB MAL_FUNCTION
452 REM push EVAL_AST return label/address
457 REM if error, return f/args for release by caller
458 IF ER
<>-2 THEN GOTO EVAL_RETURN
460 REM push f/args for release after call
466 R
=F
:GOSUB DEREF_R
:F
=R
468 REM if metadata, get the actual object
469 IF (Z
%(F
,0)AND31
)>=16 THEN F
=Z
%(F
,1)
471 IF (Z
%(F
,0)AND31
)=9 THEN GOTO EVAL_DO_FUNCTION
472 IF (Z
%(F
,0)AND31
)=10 THEN GOTO EVAL_DO_MAL_FUNCTION
474 REM if error, pop and return f/args for release by caller
476 ER
=-1:ER
$="apply of non
-function":GOTO EVAL_RETURN
481 REM pop and release f/args
482 AY=X%(X):X=X-1:GOSUB RELEASE
485 EVAL_DO_MAL_FUNCTION:
486 E4=E: REM save the current environment for release
488 REM create new environ using env stored with function
489 O=Z%(F+1,1):BI=Z%(F+1,0):EX=AR:GOSUB ENV_NEW_BINDS
491 REM release previous env if it is not the top one on the
492 REM stack (X%(X-2)) because our new env refers to it and
493 REM we no longer need to track it (since we are TCO recurring)
494 IF E4<>X%(X-2) THEN AY=E4:GOSUB RELEASE
496 REM claim the AST before releasing the list containing it
497 A=Z%(F,1):Z%(A,0)=Z%(A,0)+32
498 REM add AST to pending release queue to free as soon as EVAL
499 REM actually returns (LV+1)
500 Y=Y+1:Y%(Y,0)=A:Y%(Y,1)=LV+1
502 REM pop and release f/args
503 AY=X%(X):X=X-1:GOSUB RELEASE
506 E=R:GOTO EVAL_TCO_RECUR: REM TCO loop
509 REM AZ=R: PR=1: GOSUB PR_STR
510 REM PRINT "EVAL_RETURN R
: ["+R$+"] ("+STR
$(R)+"), LV
:"+STR$(LV)+",ER:"+STR$(ER)
512 REM release environment if not the top one on the stack
513 IF E<>X%(X-1) THEN AY=E:GOSUB RELEASE
515 LV=LV-1: REM track basic return stack level
517 REM release everything we couldn't release earlier
523 REM pop A and E off the stack
524 E=X%(X-1):A=X%(X):X=X-2
530 AZ=A:PR=1:GOSUB PR_STR
534 REM Assume D has repl_env
535 REM caller must release result
540 IF ER<>-2 THEN GOTO REP_DONE
545 REM Release memory from MAL_READ
546 IF R1<>0 THEN AY=R1:GOSUB RELEASE
547 RETURN: REM caller must release result of EVAL
550 REM Assume D has repl_env
555 IF ER<>-2 THEN GOTO REP_DONE
559 IF ER<>-2 THEN GOTO REP_DONE
565 REM Release memory from MAL_READ and EVAL
566 IF R2<>0 THEN AY=R2:GOSUB RELEASE
567 IF R1<>0 THEN AY=R1:GOSUB RELEASE
578 O=-1:GOSUB ENV_NEW:D=R
580 REM core.EXT: defined in Basic
581 E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env
583 ZT=ZI: REM top of memory after base repl_env
585 REM core.mal: defined using the language itself
586 A$="(def! *host-language* "+CHR
$(34)+"C64 Basic
"+CHR$(34)+")"
587 GOSUB RE:AY=R:GOSUB RELEASE
589 A$="(def! not (fn* (a) (if a false true)))"
590 GOSUB RE
:AY
=R
:GOSUB RELEASE
592 A
$="(def! load-file (fn
* (f
) (eval (read
-string (str
"
593 A$=A$+CHR$(34)+"(do "+CHR
$(34)+" (slurp f
) "+CHR$(34)+")"+CHR$(34)+")))))"
594 GOSUB RE:AY=R:GOSUB RELEASE
596 A$="(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs)"
597 A
$=A$+" (if (> (count xs
) 1) (nth xs
1) (throw
"+CHR$(34)+"odd number of"
598 A
$=A$+" forms
to cond
"+CHR$(34)+")) (cons 'cond (rest (rest xs)))))))"
599 GOSUB RE
:AY
=R
:GOSUB RELEASE
601 A
$="(defmacro! or (fn
* (& xs
) (if (empty? xs
) nil (if (= 1 (count xs
)) (first xs
)"
602 A$=A$+" `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))"
603 GOSUB RE
:AY
=R
:GOSUB RELEASE
605 REM load the args file
606 A
$="(def! -*ARGS
*- (load-file
"+CHR$(34)+".args.mal"+CHR$(34)+"))"
607 GOSUB RE:AY=R:GOSUB RELEASE
609 REM set the argument list
610 A$="(def! *ARGV* (rest -*ARGS*-))"
611 GOSUB RE
:AY
=R
:GOSUB RELEASE
613 REM get the first argument
614 A
$="(first -*ARGS
*-)"
617 REM if there is an argument, then run it as a program
618 IF R<>0 THEN AY=R:GOSUB RELEASE:GOTO RUN_PROG
619 REM no arguments, start REPL loop
620 IF R=0 THEN GOTO REPL
623 REM run a single mal program and exit
624 A$="(load-file (first -*ARGS*-))"
626 IF ER
<>-2 THEN GOSUB PRINT_ERROR
630 REM print the REPL startup header
631 A
$="(println (str
"+CHR$(34)+"Mal ["+CHR
$(34)+" *host
-language
* "
632 A$=A$+CHR$(34)+"]"+CHR$(34)+"))"
633 GOSUB RE:AY=R:GOSUB RELEASE
636 A$="user> ":GOSUB READLINE
: REM call input parser
637 IF EOF
=1 THEN GOTO QUIT
639 A
$=R$:GOSUB REP
: REM call REP
641 IF ER
<>-2 THEN GOSUB PRINT_ERROR
:GOTO REPL_LOOP
646 REM P1=ZT: P2=-1: GOSUB PR_MEMORY
647 GOSUB PR_MEMORY_SUMMARY
651 REM if the error is an object, then print and free it
652 IF ER
>=0 THEN AZ
=ER
:PR
=0:GOSUB PR_STR
:ER
$=R$:AY=ER:GOSUB RELEASE