3 REM $INCLUDE: 'readline.in.bas'
4 REM $INCLUDE: 'types.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)AND31
)<6 OR (Z
%(A
,0)AND31
)>7 THEN GOTO QQ_QUOTE
21 IF (Z
%(A
,1)=0) THEN GOTO QQ_QUOTE
26 AS$="quote":T=5:GOSUB STRING
34 IF (Z
%(R
,0)AND31
)<>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
43 REM push A on the stack
45 REM rest of cases call quasiquote on ast[1..]
46 A
=Z
%(A
,1):CALL QUASIQUOTE
48 REM pop A off the stack
51 REM set A to ast[0] for last two cases
55 IF (Z
%(A
,0)AND31
)<6 OR (Z
%(A
,0)AND31
)>7 THEN GOTO QQ_DEFAULT
56 IF (Z
%(A
,1)=0) THEN GOTO QQ_DEFAULT
59 IF (Z
%(B
,0)AND31
)<>5 THEN GOTO QQ_DEFAULT
60 IF S
$(Z%(B,1))<>"splice-unquote" THEN QQ_DEFAULT
61 REM ['concat, ast[0][1], quasiquote(ast[1..])]
63 B
=Z
%(A
,1)+1:GOSUB DEREF_B
:B2
=B
64 AS$="concat":T=5:GOSUB STRING:B3
=R
66 REM release inner quasiquoted since outer list takes ownership
72 REM ['cons, quasiquote(ast[0]), quasiquote(ast[1..])]
74 REM push T6 on the stack
76 REM A set above to ast[0]
79 REM pop T6 off the stack
82 AS$="cons":T=5:GOSUB STRING:B3
=R
84 REM release inner quasiquoted since outer list takes ownership
92 REM EVAL_AST(A, E) -> R
94 REM push A and E on the stack
95 X
=X
+2:X
%(X
-1)=E
:X
%(X
)=A
97 IF ER
<>-2 THEN GOTO EVAL_AST_RETURN
102 IF T
=5 THEN GOTO EVAL_AST_SYMBOL
103 IF T
>=6 AND T
<=8 THEN GOTO EVAL_AST_SEQ
105 REM scalar: deref to actual value and inc ref cnt
116 REM allocate the first entry (T already set above)
119 REM make space on the stack
121 REM push type of sequence
123 REM push sequence index
125 REM push future return value (new sequence)
127 REM push previous new sequence entry
134 REM check if we are done evaluating the source sequence
135 IF Z
%(A
,1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
137 REM if we are returning to DO, then skip last element
138 IF X
%(X
-6)=2 AND Z
%(Z
%(A
,1),1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
140 REM if hashmap, skip eval of even entries (keys)
141 IF (X
%(X
-3)=8) AND ((X
%(X
-2)AND1
)=0) THEN GOTO EVAL_AST_DO_REF
142 GOTO EVAL_AST_DO_EVAL
145 R
=A
+1:GOSUB DEREF_R
: REM deref to target of referred entry
146 Z
%(R
,0)=Z
%(R
,0)+32: REM inc ref cnt of referred value
147 GOTO EVAL_AST_ADD_VALUE
150 REM call EVAL for each entry
153 GOSUB DEREF_R
: REM deref to target of evaluated entry
157 REM update previous value pointer to evaluated entry
160 IF ER
<>-2 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
162 REM allocate the next entry
163 REM same new sequence entry type
164 T
=X
%(X
-3):L
=0:N
=0:GOSUB ALLOC
166 REM update previous sequence entry value to point to new entry
168 REM update previous ptr to current entry
171 REM process the next sequence entry from source list
174 GOTO EVAL_AST_SEQ_LOOP
175 EVAL_AST_SEQ_LOOP_DONE:
176 REM if no error, get return value (new seq)
177 IF ER
=-2 THEN R
=X
%(X
-1)
178 REM otherwise, free the return value and return nil
179 IF ER
<>-2 THEN R
=0:AY
=X
%(X
-1):GOSUB RELEASE
181 REM pop previous, return, index and type
186 REM pop A and E off the stack
187 E
=X
%(X
-1):A
=X
%(X
):X
=X
-2
192 LV
=LV
+1: REM track basic return stack level
194 REM push A and E on the stack
195 X
=X
+2:X
%(X
-1)=E
:X
%(X
)=A
197 REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0))
201 IF ER
<>-2 THEN GOTO EVAL_RETURN
203 REM AZ=A:PR=1:GOSUB PR_STR
204 REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]"
209 IF R
THEN GOTO APPLY_LIST
216 IF R
THEN R
=A
:Z
%(R
,0)=Z
%(R
,0)+32:GOTO EVAL_RETURN
219 R
=A0
:GOSUB DEREF_R
:A0
=R
222 IF (Z
%(A0
,0)AND31
)<>5 THEN A
$=""
223 IF (Z
%(A0
,0)AND31
)=5 THEN A
$=S$(Z%(A0,1))
225 IF A
$="def!" THEN GOTO EVAL_DEF
226 IF A
$="let*" THEN GOTO EVAL_LET
227 IF A
$="quote" THEN GOTO EVAL_QUOTE
228 IF A
$="quasiquote" THEN GOTO EVAL_QUASIQUOTE
229 IF A
$="do" THEN GOTO EVAL_DO
230 IF A
$="if" THEN GOTO EVAL_IF
231 IF A
$="fn*" THEN GOTO EVAL_FN
235 A3
=Z
%(Z
%(Z
%(A
,1),1),1)+1
236 R
=A3
:GOSUB DEREF_R
:A3
=R
239 R
=A2
:GOSUB DEREF_R
:A2
=R
242 R
=A1
:GOSUB DEREF_R
:A1
=R
247 GOSUB EVAL_GET_A2
: REM set A1 and A2
249 X
=X
+1:X
%(X
)=A1
: REM push A1
250 A
=A2
:CALL EVAL
: REM eval a2
251 A1
=X
%(X
):X
=X
-1: REM pop A1
253 IF ER
<>-2 THEN GOTO EVAL_RETURN
255 REM set a1 in env to a2
256 K
=A1
:V
=R
:GOSUB ENV_SET
261 GOSUB EVAL_GET_A2
: REM set A1 and A2
263 X
=X
+1:X
%(X
)=A2
: REM push/save A2
264 X
=X
+1:X
%(X
)=E
: REM push env for for later release
266 REM create new environment with outer as current environment
270 IF Z
%(A1
,1)=0 THEN GOTO EVAL_LET_LOOP_DONE
272 X
=X
+1:X
%(X
)=A1
: REM push A1
273 REM eval current A1 odd element
274 A
=Z
%(A1
,1)+1:CALL EVAL
275 A1
=X
%(X
):X
=X
-1: REM pop A1
277 IF ER
<>-2 THEN GOTO EVAL_LET_LOOP_DONE
279 REM set environment: even A1 key to odd A1 eval'd above
280 K
=A1
+1:V
=R
:GOSUB ENV_SET
281 AY
=R
:GOSUB RELEASE
: REM release our use, ENV_SET took ownership
283 REM skip to the next pair of A1 elements
288 E4
=X
%(X
):X
=X
-1: REM pop previous env
290 REM release previous environment if not the current EVAL env
291 IF E4
<>X
%(X
-2) THEN AY
=E4
:GOSUB RELEASE
293 A2
=X
%(X
):X
=X
-1: REM pop A2
294 A
=A2
:GOTO EVAL_TCO_RECUR
: REM TCO loop
298 X
=X
+1:X
%(X
)=A
: REM push/save A
303 AY
=R
: REM get eval'd list for release
305 A
=X
%(X
):X
=X
-1: REM pop/restore original A for LAST
306 GOSUB LAST
: REM get last element for return
307 A
=R
: REM new recur AST
310 GOSUB RELEASE
: REM release eval'd list
311 AY
=A
:GOSUB RELEASE
: REM release LAST value (not sure why)
313 GOTO EVAL_TCO_RECUR
: REM TCO loop
316 R
=Z
%(A
,1)+1:GOSUB DEREF_R
321 R
=Z
%(A
,1)+1:GOSUB DEREF_R
323 REM add quasiquote result to pending release queue to free when
324 REM next lower EVAL level returns (LV)
325 Y
=Y
+1:Y
%(Y
,0)=R
:Y
%(Y
,1)=LV
327 A
=R
:GOTO EVAL_TCO_RECUR
: REM TCO loop
330 GOSUB EVAL_GET_A1
: REM set A1
336 IF (R
=0) OR (R
=1) THEN GOTO EVAL_IF_FALSE
340 GOSUB EVAL_GET_A2
: REM set A1 and A2 after EVAL
341 A
=A2
:GOTO EVAL_TCO_RECUR
: REM TCO loop
344 REM if no false case (A3), return nil
346 IF R
<4 THEN R
=0:GOTO EVAL_RETURN
347 GOSUB EVAL_GET_A3
: REM set A1 - A3 after EVAL
348 A
=A3
:GOTO EVAL_TCO_RECUR
: REM TCO loop
351 GOSUB EVAL_GET_A2
: REM set A1 and A2
352 A
=A2
:P
=A1
:GOSUB MAL_FUNCTION
358 REM if error, return f/args for release by caller
359 IF ER
<>-2 THEN GOTO EVAL_RETURN
361 REM push f/args for release after call
367 R
=F
:GOSUB DEREF_R
:F
=R
369 REM if metadata, get the actual object
370 IF (Z
%(F
,0)AND31
)>=16 THEN F
=Z
%(F
,1)
372 IF (Z
%(F
,0)AND31
)=9 THEN GOTO EVAL_DO_FUNCTION
373 IF (Z
%(F
,0)AND31
)=10 THEN GOTO EVAL_DO_MAL_FUNCTION
375 REM if error, pop and return f/args for release by caller
377 ER
=-1:ER
$="apply of non
-function":GOTO EVAL_RETURN
381 IF Z%(F,1)<60 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP
382 REM for recur functions (apply, map, swap!), use GOTO
383 IF Z%(F,1)>60 THEN CALL DO_TCO_FUNCTION
384 EVAL_DO_FUNCTION_SKIP:
386 REM pop and release f/args
387 AY=X%(X):X=X-1:GOSUB RELEASE
390 EVAL_DO_MAL_FUNCTION:
391 E4=E: REM save the current environment for release
393 REM create new environ using env stored with function
394 O=Z%(F+1,1):BI=Z%(F+1,0):EX=AR:GOSUB ENV_NEW_BINDS
396 REM release previous env if it is not the top one on the
397 REM stack (X%(X-2)) because our new env refers to it and
398 REM we no longer need to track it (since we are TCO recurring)
399 IF E4<>X%(X-2) THEN AY=E4:GOSUB RELEASE
401 REM claim the AST before releasing the list containing it
402 A=Z%(F,1):Z%(A,0)=Z%(A,0)+32
403 REM add AST to pending release queue to free as soon as EVAL
404 REM actually returns (LV+1)
405 Y=Y+1:Y%(Y,0)=A:Y%(Y,1)=LV+1
407 REM pop and release f/args
408 AY=X%(X):X=X-1:GOSUB RELEASE
411 E=R:GOTO EVAL_TCO_RECUR: REM TCO loop
414 REM AZ=R: PR=1: GOSUB PR_STR
415 REM PRINT "EVAL_RETURN R
: ["+R$+"] ("+STR
$(R)+"), LV
:"+STR$(LV)+",ER:"+STR$(ER)
417 REM release environment if not the top one on the stack
418 IF E<>X%(X-1) THEN AY=E:GOSUB RELEASE
420 LV=LV-1: REM track basic return stack level
422 REM release everything we couldn't release earlier
428 REM pop A and E off the stack
429 E=X%(X-1):A=X%(X):X=X-2
435 AZ=A:PR=1:GOSUB PR_STR
439 REM Assume D has repl_env
440 REM caller must release result
445 IF ER<>-2 THEN GOTO RE_DONE
450 REM Release memory from MAL_READ
451 IF R1<>0 THEN AY=R1:GOSUB RELEASE
452 RETURN: REM caller must release result of EVAL
455 REM Assume D has repl_env
460 IF ER<>-2 THEN GOTO REP_DONE
464 IF ER<>-2 THEN GOTO REP_DONE
470 REM Release memory from MAL_READ and EVAL
471 IF R2<>0 THEN AY=R2:GOSUB RELEASE
472 IF R1<>0 THEN AY=R1:GOSUB RELEASE
483 O=-1:GOSUB ENV_NEW:D=R
485 REM core.EXT: defined in Basic
486 E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env
488 ZT=ZI: REM top of memory after base repl_env
490 REM core.mal: defined using the language itself
491 A$="(def! not (fn* (a) (if a false true)))"
492 GOSUB RE
:AY
=R
:GOSUB RELEASE
494 A
$="(def! load-file (fn
* (f
) (eval (read
-file f
))))"
495 GOSUB RE:AY=R:GOSUB RELEASE
497 REM load the args file
498 A$="(def! -*ARGS*- (load-file "+CHR
$(34)+".args.mal"+CHR$(34)+"))"
499 GOSUB RE
:AY
=R
:GOSUB RELEASE
501 REM set the argument list
502 A
$="(def! *ARGV
* (rest
-*ARGS
*-))"
503 GOSUB RE:AY=R:GOSUB RELEASE
505 REM get the first argument
506 A$="(first -*ARGS*-)"
509 REM if there is an argument, then run it as a program
510 IF R
<>0 THEN AY
=R
:GOSUB RELEASE
:GOTO RUN_PROG
511 REM no arguments, start REPL loop
512 IF R
=0 THEN GOTO REPL_LOOP
515 REM run a single mal program and exit
516 A
$="(load-file (first
-*ARGS
*-))"
518 IF ER<>-2 THEN GOSUB PRINT_ERROR
522 A$="user> ":GOSUB READLINE
: REM call input parser
523 IF EOF
=1 THEN GOTO QUIT
525 A
$=R$:CALL REP
: REM call REP
527 IF ER
<>-2 THEN GOSUB PRINT_ERROR
:GOTO REPL_LOOP
532 REM P1=ZT: P2=-1: GOSUB PR_MEMORY
533 GOSUB PR_MEMORY_SUMMARY