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'
19 REM QUASIQUOTE(A) -> R
22 IF (Z
%(A
,0)AND31
)<6 OR (Z
%(A
,0)AND31
)>7 THEN GOTO QQ_QUOTE
23 IF (Z
%(A
,1)=0) THEN GOTO QQ_QUOTE
28 AS$="quote":T=5:GOSUB STRING
36 IF (Z
%(R
,0)AND31
)<>5 THEN GOTO QQ_SPLICE_UNQUOTE
37 IF S
$(Z%(R,1))<>"unquote" THEN GOTO QQ_SPLICE_UNQUOTE
39 R
=Z
%(A
,1)+1:GOSUB DEREF_R
45 REM push A on the stack
47 REM rest of cases call quasiquote on ast[1..]
48 A
=Z
%(A
,1):CALL QUASIQUOTE
50 REM pop A off the stack
53 REM set A to ast[0] for last two cases
57 IF (Z
%(A
,0)AND31
)<6 OR (Z
%(A
,0)AND31
)>7 THEN GOTO QQ_DEFAULT
58 IF (Z
%(A
,1)=0) THEN GOTO QQ_DEFAULT
61 IF (Z
%(B
,0)AND31
)<>5 THEN GOTO QQ_DEFAULT
62 IF S
$(Z%(B,1))<>"splice-unquote" THEN QQ_DEFAULT
63 REM ['concat, ast[0][1], quasiquote(ast[1..])]
65 B
=Z
%(A
,1)+1:GOSUB DEREF_B
:B2
=B
66 AS$="concat":T=5:GOSUB STRING:B3
=R
68 REM release inner quasiquoted since outer list takes ownership
74 REM ['cons, quasiquote(ast[0]), quasiquote(ast[1..])]
76 REM push T6 on the stack
78 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
93 REM MACROEXPAND(A, E) -> A:
100 IF (Z
%(A
,0)AND31
)<>6 THEN GOTO MACROEXPAND_DONE
102 IF Z
%(A
,1)=0 THEN GOTO MACROEXPAND_DONE
104 REM symbol? in first position
105 IF (Z
%(B
,0)AND31
)<>5 THEN GOTO MACROEXPAND_DONE
106 REM defined in environment?
108 IF R
=-1 THEN GOTO MACROEXPAND_DONE
111 IF (Z
%(B
,0)AND31
)<>11 THEN GOTO MACROEXPAND_DONE
113 F
=B
:AR
=Z
%(A
,1):CALL 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
130 REM push A and E on the stack
131 X
=X
+2:X
%(X
-1)=E
:X
%(X
)=A
133 IF ER
<>-2 THEN GOTO EVAL_AST_RETURN
138 IF T
=5 THEN GOTO EVAL_AST_SYMBOL
139 IF T
>=6 AND T
<=8 THEN GOTO EVAL_AST_SEQ
141 REM scalar: deref to actual value and inc ref cnt
152 REM allocate the first entry (T already set above)
155 REM make space on the stack
157 REM push type of sequence
159 REM push sequence index
161 REM push future return value (new sequence)
163 REM push previous new sequence entry
170 REM check if we are done evaluating the source sequence
171 IF Z
%(A
,1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
173 REM if we are returning to DO, then skip last element
174 IF X
%(X
-6)=2 AND Z
%(Z
%(A
,1),1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
176 REM if hashmap, skip eval of even entries (keys)
177 IF (X
%(X
-3)=8) AND ((X
%(X
-2)AND1
)=0) THEN GOTO EVAL_AST_DO_REF
178 GOTO EVAL_AST_DO_EVAL
181 R
=A
+1:GOSUB DEREF_R
: REM deref to target of referred entry
182 Z
%(R
,0)=Z
%(R
,0)+32: REM inc ref cnt of referred value
183 GOTO EVAL_AST_ADD_VALUE
186 REM call EVAL for each entry
189 GOSUB DEREF_R
: REM deref to target of evaluated entry
193 REM update previous value pointer to evaluated entry
196 IF ER
<>-2 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
198 REM allocate the next entry
199 REM same new sequence entry type
200 T
=X
%(X
-3):L
=0:N
=0:GOSUB ALLOC
202 REM update previous sequence entry value to point to new entry
204 REM update previous ptr to current entry
207 REM process the next sequence entry from source list
210 GOTO EVAL_AST_SEQ_LOOP
211 EVAL_AST_SEQ_LOOP_DONE:
212 REM if no error, get return value (new seq)
213 IF ER
=-2 THEN R
=X
%(X
-1)
214 REM otherwise, free the return value and return nil
215 IF ER
<>-2 THEN R
=0:AY
=X
%(X
-1):GOSUB RELEASE
217 REM pop previous, return, index and type
222 REM pop A and E off the stack
223 E
=X
%(X
-1):A
=X
%(X
):X
=X
-2
228 LV
=LV
+1: REM track basic return stack level
230 REM push A and E on the stack
231 X
=X
+2:X
%(X
-1)=E
:X
%(X
)=A
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:PR=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)AND31
)<>5 THEN A
$=""
265 IF (Z
%(A0
,0)AND31
)=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
$="do" THEN GOTO EVAL_DO
274 IF A
$="if" THEN GOTO EVAL_IF
275 IF A
$="fn*" THEN GOTO EVAL_FN
279 A3
=Z
%(Z
%(Z
%(A
,1),1),1)+1
280 R
=A3
:GOSUB DEREF_R
:A3
=R
283 R
=A2
:GOSUB DEREF_R
:A2
=R
286 R
=A1
:GOSUB DEREF_R
:A1
=R
291 GOSUB EVAL_GET_A2
: REM set A1 and A2
293 X
=X
+1:X
%(X
)=A1
: REM push A1
294 A
=A2
:CALL EVAL
: REM eval a2
295 A1
=X
%(X
):X
=X
-1: REM pop A1
297 IF ER
<>-2 THEN GOTO EVAL_RETURN
299 REM set a1 in env to a2
300 K
=A1
:V
=R
:GOSUB ENV_SET
305 GOSUB EVAL_GET_A2
: REM set A1 and A2
307 X
=X
+1:X
%(X
)=A2
: REM push/save A2
308 X
=X
+1:X
%(X
)=E
: REM push env for for later release
310 REM create new environment with outer as current environment
314 IF Z
%(A1
,1)=0 THEN GOTO EVAL_LET_LOOP_DONE
316 X
=X
+1:X
%(X
)=A1
: REM push A1
317 REM eval current A1 odd element
318 A
=Z
%(A1
,1)+1:CALL EVAL
319 A1
=X
%(X
):X
=X
-1: REM pop A1
321 IF ER
<>-2 THEN GOTO EVAL_LET_LOOP_DONE
323 REM set environment: even A1 key to odd A1 eval'd above
324 K
=A1
+1:V
=R
:GOSUB ENV_SET
325 AY
=R
:GOSUB RELEASE
: REM release our use, ENV_SET took ownership
327 REM skip to the next pair of A1 elements
332 E4
=X
%(X
):X
=X
-1: REM pop previous env
334 REM release previous environment if not the current EVAL env
335 IF E4
<>X
%(X
-2) THEN AY
=E4
:GOSUB RELEASE
337 A2
=X
%(X
):X
=X
-1: REM pop A2
338 A
=A2
:GOTO EVAL_TCO_RECUR
: REM TCO loop
342 X
=X
+1:X
%(X
)=A
: REM push/save A
347 AY
=R
: REM get eval'd list for release
349 A
=X
%(X
):X
=X
-1: REM pop/restore original A for LAST
350 GOSUB LAST
: REM get last element for return
351 A
=R
: REM new recur AST
354 GOSUB RELEASE
: REM release eval'd list
355 AY
=A
:GOSUB RELEASE
: REM release LAST value (not sure why)
357 GOTO EVAL_TCO_RECUR
: REM TCO loop
360 R
=Z
%(A
,1)+1:GOSUB DEREF_R
365 R
=Z
%(A
,1)+1:GOSUB DEREF_R
367 REM add quasiquote result to pending release queue to free when
368 REM next lower EVAL level returns (LV)
369 Y
=Y
+1:Y
%(Y
,0)=R
:Y
%(Y
,1)=LV
371 A
=R
:GOTO EVAL_TCO_RECUR
: REM TCO loop
374 REM PRINT "defmacro!"
375 GOSUB EVAL_GET_A2
: REM set A1 and A2
377 X
=X
+1:X
%(X
)=A1
: REM push A1
378 A
=A2
:CALL EVAL
: REM eval A2
379 A1
=X
%(X
):X
=X
-1: REM pop A1
381 REM change function to macro
384 REM set A1 in env to A2
385 K
=A1
:V
=R
:GOSUB ENV_SET
389 REM PRINT "macroexpand"
390 R
=Z
%(A
,1)+1:GOSUB DEREF_R
394 REM since we are returning it unevaluated, inc the ref cnt
399 GOSUB EVAL_GET_A1
: REM set A1
405 IF (R
=0) OR (R
=1) THEN GOTO EVAL_IF_FALSE
409 GOSUB EVAL_GET_A2
: REM set A1 and A2 after EVAL
410 A
=A2
:GOTO EVAL_TCO_RECUR
: REM TCO loop
413 REM if no false case (A3), return nil
415 IF R
<4 THEN R
=0:GOTO EVAL_RETURN
416 GOSUB EVAL_GET_A3
: REM set A1 - A3 after EVAL
417 A
=A3
:GOTO EVAL_TCO_RECUR
: REM TCO loop
420 GOSUB EVAL_GET_A2
: REM set A1 and A2
421 A
=A2
:P
=A1
:GOSUB MAL_FUNCTION
427 REM if error, return f/args for release by caller
428 IF ER
<>-2 THEN GOTO EVAL_RETURN
430 REM push f/args for release after call
436 R
=F
:GOSUB DEREF_R
:F
=R
438 REM if metadata, get the actual object
439 IF (Z
%(F
,0)AND31
)>=16 THEN F
=Z
%(F
,1)
441 IF (Z
%(F
,0)AND31
)=9 THEN GOTO EVAL_DO_FUNCTION
442 IF (Z
%(F
,0)AND31
)=10 THEN GOTO EVAL_DO_MAL_FUNCTION
444 REM if error, pop and return f/args for release by caller
446 ER
=-1:ER
$="apply of non
-function":GOTO EVAL_RETURN
450 IF Z%(F,1)<60 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP
451 REM for recur functions (apply, map, swap!), use GOTO
452 IF Z%(F,1)>60 THEN CALL DO_TCO_FUNCTION
453 EVAL_DO_FUNCTION_SKIP:
455 REM pop and release f/args
456 AY=X%(X):X=X-1:GOSUB RELEASE
459 EVAL_DO_MAL_FUNCTION:
460 E4=E: REM save the current environment for release
462 REM create new environ using env stored with function
463 O=Z%(F+1,1):BI=Z%(F+1,0):EX=AR:GOSUB ENV_NEW_BINDS
465 REM release previous env if it is not the top one on the
466 REM stack (X%(X-2)) because our new env refers to it and
467 REM we no longer need to track it (since we are TCO recurring)
468 IF E4<>X%(X-2) THEN AY=E4:GOSUB RELEASE
470 REM claim the AST before releasing the list containing it
471 A=Z%(F,1):Z%(A,0)=Z%(A,0)+32
472 REM add AST to pending release queue to free as soon as EVAL
473 REM actually returns (LV+1)
474 Y=Y+1:Y%(Y,0)=A:Y%(Y,1)=LV+1
476 REM pop and release f/args
477 AY=X%(X):X=X-1:GOSUB RELEASE
480 E=R:GOTO EVAL_TCO_RECUR: REM TCO loop
483 REM AZ=R: PR=1: GOSUB PR_STR
484 REM PRINT "EVAL_RETURN R
: ["+R$+"] ("+STR
$(R)+"), LV
:"+STR$(LV)+",ER:"+STR$(ER)
486 REM release environment if not the top one on the stack
487 IF E<>X%(X-1) THEN AY=E:GOSUB RELEASE
489 LV=LV-1: REM track basic return stack level
491 REM release everything we couldn't release earlier
497 REM pop A and E off the stack
498 E=X%(X-1):A=X%(X):X=X-2
504 AZ=A:PR=1:GOSUB PR_STR
508 REM Assume D has repl_env
509 REM caller must release result
514 IF ER<>-2 THEN GOTO RE_DONE
519 REM Release memory from MAL_READ
520 IF R1<>0 THEN AY=R1:GOSUB RELEASE
521 RETURN: REM caller must release result of EVAL
524 REM Assume D has repl_env
529 IF ER<>-2 THEN GOTO REP_DONE
533 IF ER<>-2 THEN GOTO REP_DONE
539 REM Release memory from MAL_READ and EVAL
540 IF R2<>0 THEN AY=R2:GOSUB RELEASE
541 IF R1<>0 THEN AY=R1:GOSUB RELEASE
552 O=-1:GOSUB ENV_NEW:D=R
554 REM core.EXT: defined in Basic
555 E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env
557 ZT=ZI: REM top of memory after base repl_env
559 REM core.mal: defined using the language itself
560 A$="(def! not (fn* (a) (if a false true)))"
561 GOSUB RE
:AY
=R
:GOSUB RELEASE
563 A
$="(def! load-file (fn
* (f
) (eval (read
-file f
))))"
564 GOSUB RE:AY=R:GOSUB RELEASE
566 A$="(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs)"
567 A
$=A$+" (if (> (count xs
) 1) (nth xs
1) (throw
"+CHR$(34)+"odd number of"
568 A
$=A$+" forms
to cond
"+CHR$(34)+")) (cons 'cond (rest (rest xs)))))))"
569 GOSUB RE
:AY
=R
:GOSUB RELEASE
571 A
$="(defmacro! or (fn
* (& xs
) (if (empty? xs
) nil (if (= 1 (count xs
)) (first xs
)"
572 A$=A$+" `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))"
573 GOSUB RE
:AY
=R
:GOSUB RELEASE
575 REM load the args file
576 A
$="(def! -*ARGS
*- (load-file
"+CHR$(34)+".args.mal"+CHR$(34)+"))"
577 GOSUB RE:AY=R:GOSUB RELEASE
579 REM set the argument list
580 A$="(def! *ARGV* (rest -*ARGS*-))"
581 GOSUB RE
:AY
=R
:GOSUB RELEASE
583 REM get the first argument
584 A
$="(first -*ARGS
*-)"
587 REM if there is an argument, then run it as a program
588 IF R<>0 THEN AY=R:GOSUB RELEASE:GOTO RUN_PROG
589 REM no arguments, start REPL loop
590 IF R=0 THEN GOTO REPL_LOOP
593 REM run a single mal program and exit
594 A$="(load-file (first -*ARGS*-))"
596 IF ER
<>-2 THEN GOSUB PRINT_ERROR
600 A
$="user> ":GOSUB READLINE: REM call input parser
601 IF EOF=1 THEN GOTO QUIT
603 A$=R$:CALL REP: REM call REP
605 IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP
610 REM P1=ZT: P2=-1: GOSUB PR_MEMORY
611 GOSUB PR_MEMORY_SUMMARY