Commit | Line | Data |
---|---|---|
30a3d828 JM |
1 | GOTO MAIN |
2 | ||
d7a6c2d6 | 3 | REM $INCLUDE: 'mem.in.bas' |
30a3d828 | 4 | REM $INCLUDE: 'types.in.bas' |
93593012 | 5 | REM $INCLUDE: 'readline.in.bas' |
30a3d828 JM |
6 | REM $INCLUDE: 'reader.in.bas' |
7 | REM $INCLUDE: 'printer.in.bas' | |
8 | REM $INCLUDE: 'env.in.bas' | |
9 | REM $INCLUDE: 'core.in.bas' | |
10 | ||
11 | REM $INCLUDE: 'debug.in.bas' | |
12 | ||
7895453b | 13 | REM READ is inlined in RE |
30a3d828 | 14 | |
cc9dbd92 | 15 | REM QUASIQUOTE(A) -> R |
af621e3a | 16 | SUB QUASIQUOTE |
01e8850d | 17 | REM pair? |
4202ef7b JM |
18 | GOSUB TYPE_A |
19 | IF T<6 OR T>7 THEN GOTO QQ_QUOTE | |
d7a6c2d6 | 20 | IF (Z%(A+1)=0) THEN GOTO QQ_QUOTE |
01e8850d JM |
21 | GOTO QQ_UNQUOTE |
22 | ||
23 | QQ_QUOTE: | |
30a3d828 | 24 | REM ['quote, ast] |
c756af81 JM |
25 | B$="quote":T=5:GOSUB STRING |
26 | B=R:A=A:GOSUB LIST2 | |
27 | AY=B:GOSUB RELEASE | |
30a3d828 | 28 | |
af621e3a | 29 | GOTO QQ_DONE |
30a3d828 JM |
30 | |
31 | QQ_UNQUOTE: | |
d7a6c2d6 JM |
32 | R=Z%(A+2) |
33 | IF (Z%(R)AND 31)<>5 THEN GOTO QQ_SPLICE_UNQUOTE | |
34 | IF S$(Z%(R+1))<>"unquote" THEN GOTO QQ_SPLICE_UNQUOTE | |
30a3d828 | 35 | REM [ast[1]] |
d7a6c2d6 | 36 | R=Z%(Z%(A+1)+2) |
4202ef7b | 37 | GOSUB INC_REF_R |
30a3d828 | 38 | |
af621e3a | 39 | GOTO QQ_DONE |
30a3d828 JM |
40 | |
41 | QQ_SPLICE_UNQUOTE: | |
93593012 | 42 | GOSUB PUSH_A |
30a3d828 | 43 | REM rest of cases call quasiquote on ast[1..] |
d7a6c2d6 | 44 | A=Z%(A+1):CALL QUASIQUOTE |
037815e0 | 45 | W=R |
93593012 | 46 | GOSUB POP_A |
cc9dbd92 JM |
47 | |
48 | REM set A to ast[0] for last two cases | |
d7a6c2d6 | 49 | A=Z%(A+2) |
cc9dbd92 | 50 | |
01e8850d | 51 | REM pair? |
4202ef7b JM |
52 | GOSUB TYPE_A |
53 | IF T<6 OR T>7 THEN GOTO QQ_DEFAULT | |
d7a6c2d6 | 54 | IF (Z%(A+1)=0) THEN GOTO QQ_DEFAULT |
01e8850d | 55 | |
d7a6c2d6 JM |
56 | B=Z%(A+2) |
57 | IF (Z%(B)AND 31)<>5 THEN GOTO QQ_DEFAULT | |
58 | IF S$(Z%(B+1))<>"splice-unquote" THEN QQ_DEFAULT | |
30a3d828 JM |
59 | REM ['concat, ast[0][1], quasiquote(ast[1..])] |
60 | ||
d7a6c2d6 | 61 | B=Z%(Z%(A+1)+2) |
c756af81 | 62 | B$="concat":T=5:GOSUB STRING:C=R |
037815e0 | 63 | A=W:GOSUB LIST3 |
30a3d828 | 64 | REM release inner quasiquoted since outer list takes ownership |
c756af81 JM |
65 | AY=A:GOSUB RELEASE |
66 | AY=C:GOSUB RELEASE | |
af621e3a | 67 | GOTO QQ_DONE |
30a3d828 JM |
68 | |
69 | QQ_DEFAULT: | |
70 | REM ['cons, quasiquote(ast[0]), quasiquote(ast[1..])] | |
71 | ||
037815e0 | 72 | Q=W:GOSUB PUSH_Q |
cc9dbd92 | 73 | REM A set above to ast[0] |
af621e3a | 74 | CALL QUASIQUOTE |
c756af81 | 75 | B=R |
037815e0 | 76 | GOSUB POP_Q:W=Q |
30a3d828 | 77 | |
c756af81 | 78 | B$="cons":T=5:GOSUB STRING:C=R |
037815e0 | 79 | A=W:GOSUB LIST3 |
30a3d828 | 80 | REM release inner quasiquoted since outer list takes ownership |
c756af81 JM |
81 | AY=A:GOSUB RELEASE |
82 | AY=B:GOSUB RELEASE | |
83 | AY=C:GOSUB RELEASE | |
af621e3a JM |
84 | QQ_DONE: |
85 | END SUB | |
30a3d828 | 86 | |
cc9dbd92 | 87 | REM MACROEXPAND(A, E) -> A: |
af621e3a | 88 | SUB MACROEXPAND |
93593012 | 89 | GOSUB PUSH_A |
30a3d828 JM |
90 | |
91 | MACROEXPAND_LOOP: | |
92 | REM list? | |
4202ef7b JM |
93 | GOSUB TYPE_A |
94 | IF T<>6 THEN GOTO MACROEXPAND_DONE | |
30a3d828 | 95 | REM non-empty? |
d7a6c2d6 JM |
96 | IF Z%(A+1)=0 THEN GOTO MACROEXPAND_DONE |
97 | B=Z%(A+2) | |
30a3d828 | 98 | REM symbol? in first position |
d7a6c2d6 | 99 | IF (Z%(B)AND 31)<>5 THEN GOTO MACROEXPAND_DONE |
30a3d828 | 100 | REM defined in environment? |
af621e3a | 101 | K=B:CALL ENV_FIND |
cc9dbd92 | 102 | IF R=-1 THEN GOTO MACROEXPAND_DONE |
9d59cdb3 | 103 | B=R4 |
30a3d828 | 104 | REM macro? |
d7a6c2d6 | 105 | IF (Z%(B)AND 31)<>11 THEN GOTO MACROEXPAND_DONE |
93593012 | 106 | |
d7a6c2d6 | 107 | F=B:AR=Z%(A+1):CALL APPLY |
cc9dbd92 | 108 | A=R |
30a3d828 | 109 | |
93593012 | 110 | GOSUB PEEK_Q:AY=Q |
cc9dbd92 | 111 | REM if previous A was not the first A into macroexpand (i.e. an |
30a3d828 | 112 | REM intermediate form) then free it |
93593012 JM |
113 | IF A<>AY THEN GOSUB PEND_A_LV |
114 | ||
cc9dbd92 | 115 | IF ER<>-2 THEN GOTO MACROEXPAND_DONE |
30a3d828 JM |
116 | GOTO MACROEXPAND_LOOP |
117 | ||
118 | MACROEXPAND_DONE: | |
93593012 | 119 | GOSUB POP_Q: REM pop original A |
af621e3a | 120 | END SUB |
30a3d828 | 121 | |
cc9dbd92 | 122 | REM EVAL_AST(A, E) -> R |
af621e3a | 123 | SUB EVAL_AST |
cc9dbd92 | 124 | REM push A and E on the stack |
93593012 JM |
125 | Q=E:GOSUB PUSH_Q |
126 | GOSUB PUSH_A | |
30a3d828 | 127 | |
cc9dbd92 | 128 | IF ER<>-2 THEN GOTO EVAL_AST_RETURN |
30a3d828 | 129 | |
4202ef7b | 130 | GOSUB TYPE_A |
cc9dbd92 | 131 | IF T=5 THEN GOTO EVAL_AST_SYMBOL |
7895453b | 132 | IF T>5 AND T<9 THEN GOTO EVAL_AST_SEQ |
30a3d828 JM |
133 | |
134 | REM scalar: deref to actual value and inc ref cnt | |
9d59cdb3 | 135 | R=A |
4202ef7b | 136 | GOSUB INC_REF_R |
30a3d828 JM |
137 | GOTO EVAL_AST_RETURN |
138 | ||
139 | EVAL_AST_SYMBOL: | |
af621e3a JM |
140 | K=A:GOTO ENV_GET |
141 | ENV_GET_RETURN: | |
30a3d828 JM |
142 | GOTO EVAL_AST_RETURN |
143 | ||
144 | EVAL_AST_SEQ: | |
9d59cdb3 JM |
145 | REM setup the stack for the loop |
146 | GOSUB MAP_LOOP_START | |
30a3d828 JM |
147 | |
148 | EVAL_AST_SEQ_LOOP: | |
30a3d828 | 149 | REM check if we are done evaluating the source sequence |
d7a6c2d6 | 150 | IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE |
30a3d828 | 151 | |
01e8850d | 152 | REM if we are returning to DO, then skip last element |
9d59cdb3 JM |
153 | REM The EVAL_DO call to EVAL_AST must be call #2 for EVAL_AST to |
154 | REM return early and for TCO to work | |
155 | Q=5:GOSUB PEEK_Q_Q | |
d7a6c2d6 | 156 | IF Q=2 AND Z%(Z%(A+1)+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE |
01e8850d | 157 | |
9d59cdb3 JM |
158 | REM call EVAL for each entry |
159 | GOSUB PUSH_A | |
d7a6c2d6 JM |
160 | IF T<>8 THEN A=Z%(A+2) |
161 | IF T=8 THEN A=Z%(A+3) | |
9d59cdb3 JM |
162 | Q=T:GOSUB PUSH_Q: REM push/save type |
163 | CALL EVAL | |
164 | GOSUB POP_Q:T=Q: REM pop/restore type | |
165 | GOSUB POP_A | |
d7a6c2d6 | 166 | M=R |
30a3d828 | 167 | |
9d59cdb3 JM |
168 | REM if error, release the unattached element |
169 | REM TODO: is R=0 correct? | |
170 | IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE | |
30a3d828 | 171 | |
9d59cdb3 JM |
172 | REM for hash-maps, copy the key (inc ref since we are going to |
173 | REM release it below) | |
d7a6c2d6 | 174 | IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 |
30a3d828 | 175 | |
30a3d828 | 176 | |
9d59cdb3 JM |
177 | REM update the return sequence structure |
178 | REM release N (and M if T=8) since seq takes full ownership | |
179 | C=1:GOSUB MAP_LOOP_UPDATE | |
30a3d828 JM |
180 | |
181 | REM process the next sequence entry from source list | |
d7a6c2d6 | 182 | A=Z%(A+1) |
30a3d828 JM |
183 | |
184 | GOTO EVAL_AST_SEQ_LOOP | |
185 | EVAL_AST_SEQ_LOOP_DONE: | |
9d59cdb3 JM |
186 | REM cleanup stack and get return value |
187 | GOSUB MAP_LOOP_DONE | |
30a3d828 JM |
188 | GOTO EVAL_AST_RETURN |
189 | ||
190 | EVAL_AST_RETURN: | |
cc9dbd92 | 191 | REM pop A and E off the stack |
93593012 JM |
192 | GOSUB POP_A |
193 | GOSUB POP_Q:E=Q | |
af621e3a | 194 | END SUB |
30a3d828 | 195 | |
af621e3a JM |
196 | REM EVAL(A, E) -> R |
197 | SUB EVAL | |
cc9dbd92 | 198 | LV=LV+1: REM track basic return stack level |
30a3d828 | 199 | |
cc9dbd92 | 200 | REM push A and E on the stack |
93593012 JM |
201 | Q=E:GOSUB PUSH_Q |
202 | GOSUB PUSH_A | |
30a3d828 | 203 | |
01e8850d JM |
204 | REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0)) |
205 | ||
30a3d828 JM |
206 | EVAL_TCO_RECUR: |
207 | ||
c7330b3d JM |
208 | IF ER<>-2 THEN GOTO EVAL_RETURN |
209 | ||
c756af81 | 210 | REM AZ=A:B=1:GOSUB PR_STR |
cc9dbd92 | 211 | REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" |
30a3d828 | 212 | |
30a3d828 | 213 | GOSUB LIST_Q |
cc9dbd92 | 214 | IF R THEN GOTO APPLY_LIST |
30a3d828 JM |
215 | EVAL_NOT_LIST: |
216 | REM ELSE | |
af621e3a | 217 | CALL EVAL_AST |
30a3d828 JM |
218 | GOTO EVAL_RETURN |
219 | ||
220 | APPLY_LIST: | |
af621e3a | 221 | CALL MACROEXPAND |
30a3d828 JM |
222 | |
223 | GOSUB LIST_Q | |
cc9dbd92 | 224 | IF R<>1 THEN GOTO EVAL_NOT_LIST |
30a3d828 JM |
225 | |
226 | GOSUB EMPTY_Q | |
4202ef7b | 227 | IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN |
30a3d828 | 228 | |
d7a6c2d6 | 229 | A0=Z%(A+2) |
30a3d828 JM |
230 | |
231 | REM get symbol in A$ | |
d7a6c2d6 JM |
232 | IF (Z%(A0)AND 31)<>5 THEN A$="" |
233 | IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) | |
30a3d828 JM |
234 | |
235 | IF A$="def!" THEN GOTO EVAL_DEF | |
236 | IF A$="let*" THEN GOTO EVAL_LET | |
237 | IF A$="quote" THEN GOTO EVAL_QUOTE | |
238 | IF A$="quasiquote" THEN GOTO EVAL_QUASIQUOTE | |
239 | IF A$="defmacro!" THEN GOTO EVAL_DEFMACRO | |
240 | IF A$="macroexpand" THEN GOTO EVAL_MACROEXPAND | |
241 | IF A$="try*" THEN GOTO EVAL_TRY | |
242 | IF A$="do" THEN GOTO EVAL_DO | |
243 | IF A$="if" THEN GOTO EVAL_IF | |
244 | IF A$="fn*" THEN GOTO EVAL_FN | |
245 | GOTO EVAL_INVOKE | |
246 | ||
247 | EVAL_GET_A3: | |
d7a6c2d6 | 248 | A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) |
30a3d828 | 249 | EVAL_GET_A2: |
d7a6c2d6 | 250 | A2=Z%(Z%(Z%(A+1)+1)+2) |
30a3d828 | 251 | EVAL_GET_A1: |
d7a6c2d6 | 252 | A1=Z%(Z%(A+1)+2) |
30a3d828 JM |
253 | RETURN |
254 | ||
255 | EVAL_DEF: | |
256 | REM PRINT "def!" | |
bbab5c5d | 257 | GOSUB EVAL_GET_A2: REM set A1 and A2 |
30a3d828 | 258 | |
93593012 | 259 | Q=A1:GOSUB PUSH_Q |
af621e3a | 260 | A=A2:CALL EVAL: REM eval a2 |
93593012 | 261 | GOSUB POP_Q:A1=Q |
30a3d828 | 262 | |
cc9dbd92 | 263 | IF ER<>-2 THEN GOTO EVAL_RETURN |
30a3d828 JM |
264 | |
265 | REM set a1 in env to a2 | |
c756af81 | 266 | K=A1:C=R:GOSUB ENV_SET |
30a3d828 JM |
267 | GOTO EVAL_RETURN |
268 | ||
269 | EVAL_LET: | |
270 | REM PRINT "let*" | |
bbab5c5d | 271 | GOSUB EVAL_GET_A2: REM set A1 and A2 |
30a3d828 | 272 | |
93593012 JM |
273 | Q=A2:GOSUB PUSH_Q: REM push/save A2 |
274 | Q=E:GOSUB PUSH_Q: REM push env for for later release | |
30a3d828 JM |
275 | |
276 | REM create new environment with outer as current environment | |
c756af81 | 277 | C=E:GOSUB ENV_NEW |
cc9dbd92 | 278 | E=R |
30a3d828 | 279 | EVAL_LET_LOOP: |
d7a6c2d6 | 280 | IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE |
30a3d828 | 281 | |
93593012 | 282 | Q=A1:GOSUB PUSH_Q: REM push A1 |
30a3d828 | 283 | REM eval current A1 odd element |
d7a6c2d6 | 284 | A=Z%(Z%(A1+1)+2):CALL EVAL |
93593012 | 285 | GOSUB POP_Q:A1=Q: REM pop A1 |
30a3d828 | 286 | |
c7330b3d JM |
287 | IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE |
288 | ||
d7a6c2d6 JM |
289 | REM set key/value in the environment |
290 | K=Z%(A1+2):C=R:GOSUB ENV_SET | |
cc9dbd92 | 291 | AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership |
30a3d828 | 292 | |
bbab5c5d | 293 | REM skip to the next pair of A1 elements |
d7a6c2d6 | 294 | A1=Z%(Z%(A1+1)+1) |
30a3d828 JM |
295 | GOTO EVAL_LET_LOOP |
296 | ||
297 | EVAL_LET_LOOP_DONE: | |
f9f1cec9 | 298 | GOSUB POP_Q:AY=Q: REM pop previous env |
30a3d828 JM |
299 | |
300 | REM release previous environment if not the current EVAL env | |
93593012 | 301 | GOSUB PEEK_Q_2 |
f9f1cec9 | 302 | IF AY<>Q THEN GOSUB RELEASE |
30a3d828 | 303 | |
93593012 | 304 | GOSUB POP_Q:A2=Q: REM pop A2 |
bbab5c5d | 305 | A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop |
30a3d828 JM |
306 | |
307 | EVAL_DO: | |
d7a6c2d6 | 308 | A=Z%(A+1): REM rest |
93593012 | 309 | GOSUB PUSH_A: REM push/save A |
30a3d828 | 310 | |
9d59cdb3 JM |
311 | REM this must be EVAL_AST call #2 for EVAL_AST to return early |
312 | REM and for TCO to work | |
af621e3a | 313 | CALL EVAL_AST |
30a3d828 | 314 | |
01e8850d JM |
315 | REM cleanup |
316 | AY=R: REM get eval'd list for release | |
317 | ||
93593012 | 318 | GOSUB POP_A: REM pop/restore original A for LAST |
01e8850d JM |
319 | GOSUB LAST: REM get last element for return |
320 | A=R: REM new recur AST | |
321 | ||
322 | REM cleanup | |
323 | GOSUB RELEASE: REM release eval'd list | |
324 | AY=A:GOSUB RELEASE: REM release LAST value (not sure why) | |
325 | ||
326 | GOTO EVAL_TCO_RECUR: REM TCO loop | |
30a3d828 JM |
327 | |
328 | EVAL_QUOTE: | |
d7a6c2d6 | 329 | R=Z%(Z%(A+1)+2) |
4202ef7b | 330 | GOSUB INC_REF_R |
30a3d828 JM |
331 | GOTO EVAL_RETURN |
332 | ||
333 | EVAL_QUASIQUOTE: | |
d7a6c2d6 | 334 | R=Z%(Z%(A+1)+2) |
af621e3a | 335 | A=R:CALL QUASIQUOTE |
93593012 | 336 | A=R |
30a3d828 | 337 | REM add quasiquote result to pending release queue to free when |
cc9dbd92 | 338 | REM next lower EVAL level returns (LV) |
93593012 | 339 | GOSUB PEND_A_LV |
30a3d828 | 340 | |
93593012 | 341 | GOTO EVAL_TCO_RECUR: REM TCO loop |
30a3d828 JM |
342 | |
343 | EVAL_DEFMACRO: | |
344 | REM PRINT "defmacro!" | |
bbab5c5d | 345 | GOSUB EVAL_GET_A2: REM set A1 and A2 |
30a3d828 | 346 | |
93593012 | 347 | Q=A1:GOSUB PUSH_Q: REM push A1 |
af621e3a | 348 | A=A2:CALL EVAL: REM eval A2 |
93593012 | 349 | GOSUB POP_Q:A1=Q: REM pop A1 |
30a3d828 JM |
350 | |
351 | REM change function to macro | |
d7a6c2d6 | 352 | Z%(R)=Z%(R)+1 |
30a3d828 | 353 | |
bbab5c5d | 354 | REM set A1 in env to A2 |
c756af81 | 355 | K=A1:C=R:GOSUB ENV_SET |
30a3d828 JM |
356 | GOTO EVAL_RETURN |
357 | ||
358 | EVAL_MACROEXPAND: | |
359 | REM PRINT "macroexpand" | |
d7a6c2d6 | 360 | R=Z%(Z%(A+1)+2) |
af621e3a JM |
361 | A=R:CALL MACROEXPAND |
362 | R=A | |
30a3d828 JM |
363 | |
364 | REM since we are returning it unevaluated, inc the ref cnt | |
4202ef7b | 365 | GOSUB INC_REF_R |
30a3d828 JM |
366 | GOTO EVAL_RETURN |
367 | ||
368 | EVAL_TRY: | |
369 | REM PRINT "try*" | |
9e6b2a6d | 370 | GOSUB EVAL_GET_A1: REM set A1 |
30a3d828 | 371 | |
93593012 | 372 | GOSUB PUSH_A: REM push/save A |
af621e3a | 373 | A=A1:CALL EVAL: REM eval A1 |
93593012 | 374 | GOSUB POP_A: REM pop/restore A |
30a3d828 | 375 | |
9e6b2a6d JM |
376 | GOSUB EVAL_GET_A2: REM set A1 and A2 |
377 | ||
378 | REM if there is no error or catch block then return | |
379 | IF ER=-2 OR A2=0 THEN GOTO EVAL_RETURN | |
30a3d828 JM |
380 | |
381 | REM create environment for the catch block eval | |
c756af81 | 382 | C=E:GOSUB ENV_NEW:E=R |
30a3d828 | 383 | |
bbab5c5d | 384 | A=A2:GOSUB EVAL_GET_A2: REM set A1 and A2 from catch block |
30a3d828 | 385 | |
cc9dbd92 | 386 | REM create object for ER=-1 type raw string errors |
4202ef7b | 387 | IF ER=-1 THEN B$=E$:T=4:GOSUB STRING:ER=R:GOSUB INC_REF_R |
30a3d828 JM |
388 | |
389 | REM bind the catch symbol to the error object | |
c756af81 | 390 | K=A1:C=ER:GOSUB ENV_SET |
c7330b3d | 391 | AY=R:GOSUB RELEASE: REM release our use, env took ownership |
30a3d828 JM |
392 | |
393 | REM unset error for catch eval | |
c756af81 | 394 | ER=-2:E$="" |
30a3d828 | 395 | |
af621e3a | 396 | A=A2:CALL EVAL |
30a3d828 JM |
397 | |
398 | GOTO EVAL_RETURN | |
399 | ||
400 | EVAL_IF: | |
bbab5c5d | 401 | GOSUB EVAL_GET_A1: REM set A1 |
93593012 | 402 | GOSUB PUSH_A: REM push/save A |
af621e3a | 403 | A=A1:CALL EVAL |
93593012 | 404 | GOSUB POP_A: REM pop/restore A |
d7a6c2d6 | 405 | IF (R=0) OR (R=2) THEN GOTO EVAL_IF_FALSE |
30a3d828 JM |
406 | |
407 | EVAL_IF_TRUE: | |
cc9dbd92 | 408 | AY=R:GOSUB RELEASE |
bbab5c5d JM |
409 | GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL |
410 | A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop | |
30a3d828 | 411 | EVAL_IF_FALSE: |
cc9dbd92 | 412 | AY=R:GOSUB RELEASE |
bbab5c5d | 413 | REM if no false case (A3), return nil |
037815e0 | 414 | GOSUB COUNT |
4202ef7b | 415 | IF R<4 THEN R=0:GOSUB INC_REF_R:GOTO EVAL_RETURN |
bbab5c5d JM |
416 | GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL |
417 | A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop | |
30a3d828 JM |
418 | |
419 | EVAL_FN: | |
bbab5c5d | 420 | GOSUB EVAL_GET_A2: REM set A1 and A2 |
4202ef7b | 421 | T=10:L=A2:M=A1:N=E:GOSUB ALLOC: REM mal function |
30a3d828 JM |
422 | GOTO EVAL_RETURN |
423 | ||
424 | EVAL_INVOKE: | |
af621e3a | 425 | CALL EVAL_AST |
30a3d828 JM |
426 | |
427 | REM if error, return f/args for release by caller | |
cc9dbd92 | 428 | IF ER<>-2 THEN GOTO EVAL_RETURN |
30a3d828 JM |
429 | |
430 | REM push f/args for release after call | |
93593012 | 431 | GOSUB PUSH_R |
30a3d828 | 432 | |
d7a6c2d6 JM |
433 | AR=Z%(R+1): REM rest |
434 | F=Z%(R+2) | |
30a3d828 | 435 | |
bbab5c5d | 436 | REM if metadata, get the actual object |
4202ef7b JM |
437 | GOSUB TYPE_F |
438 | IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F | |
bbab5c5d | 439 | |
4202ef7b | 440 | ON T-8 GOTO EVAL_DO_FUNCTION,EVAL_DO_MAL_FUNCTION,EVAL_DO_MAL_FUNCTION |
30a3d828 JM |
441 | |
442 | REM if error, pop and return f/args for release by caller | |
93593012 | 443 | GOSUB POP_R |
c756af81 | 444 | ER=-1:E$="apply of non-function":GOTO EVAL_RETURN |
30a3d828 JM |
445 | |
446 | EVAL_DO_FUNCTION: | |
01e8850d | 447 | REM regular function |
d7a6c2d6 | 448 | IF Z%(F+1)<60 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP |
01e8850d | 449 | REM for recur functions (apply, map, swap!), use GOTO |
d7a6c2d6 | 450 | IF Z%(F+1)>60 THEN CALL DO_TCO_FUNCTION |
af621e3a | 451 | EVAL_DO_FUNCTION_SKIP: |
30a3d828 JM |
452 | |
453 | REM pop and release f/args | |
93593012 JM |
454 | GOSUB POP_Q:AY=Q |
455 | GOSUB RELEASE | |
30a3d828 JM |
456 | GOTO EVAL_RETURN |
457 | ||
458 | EVAL_DO_MAL_FUNCTION: | |
f9f1cec9 | 459 | Q=E:GOSUB PUSH_Q: REM save the current environment for release |
30a3d828 | 460 | |
d7a6c2d6 JM |
461 | REM create new environ using env and params stored in function |
462 | C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS | |
30a3d828 JM |
463 | |
464 | REM release previous env if it is not the top one on the | |
bbab5c5d | 465 | REM stack (X%(X-2)) because our new env refers to it and |
30a3d828 | 466 | REM we no longer need to track it (since we are TCO recurring) |
f9f1cec9 | 467 | GOSUB POP_Q:AY=Q |
93593012 | 468 | GOSUB PEEK_Q_2 |
f9f1cec9 | 469 | IF AY<>Q THEN GOSUB RELEASE |
30a3d828 JM |
470 | |
471 | REM claim the AST before releasing the list containing it | |
d7a6c2d6 | 472 | A=Z%(F+1):Z%(A)=Z%(A)+32 |
30a3d828 | 473 | REM add AST to pending release queue to free as soon as EVAL |
cc9dbd92 | 474 | REM actually returns (LV+1) |
93593012 | 475 | LV=LV+1:GOSUB PEND_A_LV:LV=LV-1 |
30a3d828 JM |
476 | |
477 | REM pop and release f/args | |
93593012 JM |
478 | GOSUB POP_Q:AY=Q |
479 | GOSUB RELEASE | |
30a3d828 | 480 | |
cc9dbd92 JM |
481 | REM A set above |
482 | E=R:GOTO EVAL_TCO_RECUR: REM TCO loop | |
30a3d828 JM |
483 | |
484 | EVAL_RETURN: | |
c756af81 | 485 | REM AZ=R: B=1: GOSUB PR_STR |
cc9dbd92 | 486 | REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER) |
30a3d828 JM |
487 | |
488 | REM release environment if not the top one on the stack | |
93593012 JM |
489 | GOSUB PEEK_Q_1 |
490 | IF E<>Q THEN AY=E:GOSUB RELEASE | |
30a3d828 | 491 | |
cc9dbd92 | 492 | LV=LV-1: REM track basic return stack level |
30a3d828 JM |
493 | |
494 | REM release everything we couldn't release earlier | |
495 | GOSUB RELEASE_PEND | |
496 | ||
497 | REM trigger GC | |
c756af81 JM |
498 | #cbm T=FRE(0) |
499 | #qbasic T=0 | |
30a3d828 | 500 | |
cc9dbd92 | 501 | REM pop A and E off the stack |
93593012 JM |
502 | GOSUB POP_A |
503 | GOSUB POP_Q:E=Q | |
30a3d828 | 504 | |
af621e3a | 505 | END SUB |
30a3d828 | 506 | |
7895453b JM |
507 | REM PRINT is inlined in REP |
508 | ||
30a3d828 | 509 | |
cc9dbd92 | 510 | REM RE(A$) -> R |
bbab5c5d | 511 | REM Assume D has repl_env |
30a3d828 JM |
512 | REM caller must release result |
513 | RE: | |
6aaee33e | 514 | R1=-1 |
7895453b | 515 | GOSUB READ_STR: REM inlined MAL_READ |
cc9dbd92 | 516 | R1=R |
0e508fa5 | 517 | IF ER<>-2 THEN GOTO RE_DONE |
30a3d828 | 518 | |
af621e3a | 519 | A=R:E=D:CALL EVAL |
30a3d828 | 520 | |
0e508fa5 | 521 | RE_DONE: |
30a3d828 | 522 | REM Release memory from MAL_READ |
6aaee33e | 523 | AY=R1:GOSUB RELEASE |
30a3d828 JM |
524 | RETURN: REM caller must release result of EVAL |
525 | ||
526 | REM REP(A$) -> R$ | |
bbab5c5d | 527 | REM Assume D has repl_env |
af621e3a | 528 | SUB REP |
6aaee33e | 529 | R2=-1 |
30a3d828 | 530 | |
6aaee33e | 531 | GOSUB RE |
cc9dbd92 JM |
532 | R2=R |
533 | IF ER<>-2 THEN GOTO REP_DONE | |
30a3d828 | 534 | |
7895453b | 535 | AZ=R:B=1:GOSUB PR_STR: REM MAL_PRINT |
30a3d828 JM |
536 | |
537 | REP_DONE: | |
538 | REM Release memory from MAL_READ and EVAL | |
9d59cdb3 | 539 | AY=R2:GOSUB RELEASE |
af621e3a | 540 | END SUB |
30a3d828 JM |
541 | |
542 | REM MAIN program | |
543 | MAIN: | |
544 | GOSUB INIT_MEMORY | |
545 | ||
cc9dbd92 | 546 | LV=0 |
30a3d828 JM |
547 | |
548 | REM create repl_env | |
9d59cdb3 | 549 | C=0:GOSUB ENV_NEW:D=R |
30a3d828 JM |
550 | |
551 | REM core.EXT: defined in Basic | |
bbab5c5d | 552 | E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env |
30a3d828 | 553 | |
bbab5c5d | 554 | ZT=ZI: REM top of memory after base repl_env |
30a3d828 JM |
555 | |
556 | REM core.mal: defined using the language itself | |
4fab6aa5 | 557 | #cbm A$="(def! *host-language* "+CHR$(34)+"C64 BASIC"+CHR$(34)+")" |
01975886 | 558 | #qbasic A$="(def! *host-language* "+CHR$(34)+"QBasic"+CHR$(34)+")" |
cc9dbd92 | 559 | GOSUB RE:AY=R:GOSUB RELEASE |
30a3d828 JM |
560 | |
561 | A$="(def! not (fn* (a) (if a false true)))" | |
cc9dbd92 | 562 | GOSUB RE:AY=R:GOSUB RELEASE |
30a3d828 | 563 | |
0e508fa5 | 564 | A$="(def! load-file (fn* (f) (eval (read-file f))))" |
cc9dbd92 | 565 | GOSUB RE:AY=R:GOSUB RELEASE |
30a3d828 JM |
566 | |
567 | A$="(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs)" | |
568 | A$=A$+" (if (> (count xs) 1) (nth xs 1) (throw "+CHR$(34)+"odd number of" | |
569 | A$=A$+" forms to cond"+CHR$(34)+")) (cons 'cond (rest (rest xs)))))))" | |
cc9dbd92 | 570 | GOSUB RE:AY=R:GOSUB RELEASE |
30a3d828 | 571 | |
14ab099c | 572 | A$="(def! inc (fn* [x] (+ x 1)))" |
4e7d8a1b JM |
573 | GOSUB RE:AY=R:GOSUB RELEASE |
574 | ||
14ab099c NB |
575 | A$="(def! gensym (let* [counter (atom 0)] (fn* [] (symbol (str "+CHR$(34) |
576 | A$=A$+"G__"+CHR$(34)+" (swap! counter inc))))))" | |
4e7d8a1b JM |
577 | GOSUB RE:AY=R:GOSUB RELEASE |
578 | ||
30a3d828 | 579 | A$="(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs)" |
c756af81 JM |
580 | A$=A$+" (let* (c (gensym)) `(let* (~c ~(first xs))" |
581 | A$=A$+" (if ~c ~c (or ~@(rest xs)))))))))" | |
cc9dbd92 | 582 | GOSUB RE:AY=R:GOSUB RELEASE |
30a3d828 JM |
583 | |
584 | REM load the args file | |
585 | A$="(def! -*ARGS*- (load-file "+CHR$(34)+".args.mal"+CHR$(34)+"))" | |
cc9dbd92 | 586 | GOSUB RE:AY=R:GOSUB RELEASE |
30a3d828 | 587 | |
e0bcd3fb JM |
588 | IF ER>-2 THEN GOSUB PRINT_ERROR:END |
589 | ||
30a3d828 JM |
590 | REM set the argument list |
591 | A$="(def! *ARGV* (rest -*ARGS*-))" | |
cc9dbd92 | 592 | GOSUB RE:AY=R:GOSUB RELEASE |
30a3d828 JM |
593 | |
594 | REM get the first argument | |
595 | A$="(first -*ARGS*-)" | |
596 | GOSUB RE | |
597 | ||
30a3d828 | 598 | REM no arguments, start REPL loop |
e0bcd3fb JM |
599 | IF R<16 THEN GOTO REPL |
600 | ||
601 | REM if there is an argument, then run it as a program | |
30a3d828 JM |
602 | |
603 | RUN_PROG: | |
e0bcd3fb JM |
604 | REM free up first arg because we get it again |
605 | AY=R:GOSUB RELEASE | |
30a3d828 JM |
606 | REM run a single mal program and exit |
607 | A$="(load-file (first -*ARGS*-))" | |
608 | GOSUB RE | |
cc9dbd92 | 609 | IF ER<>-2 THEN GOSUB PRINT_ERROR |
01e8850d | 610 | GOTO QUIT |
30a3d828 JM |
611 | |
612 | REPL: | |
613 | REM print the REPL startup header | |
4fab6aa5 JM |
614 | REM save memory by printing this directly |
615 | #cbm PRINT "Mal [C64 BASIC]" | |
4a445e84 | 616 | #qbasic PRINT "Mal [QBasic]" |
30a3d828 JM |
617 | |
618 | REPL_LOOP: | |
619 | A$="user> ":GOSUB READLINE: REM call input parser | |
01975886 | 620 | IF EZ=1 THEN GOTO QUIT |
9d59cdb3 | 621 | IF R$="" THEN GOTO REPL_LOOP |
30a3d828 | 622 | |
af621e3a | 623 | A$=R$:CALL REP: REM call REP |
30a3d828 | 624 | |
cc9dbd92 | 625 | IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP |
30a3d828 JM |
626 | PRINT R$ |
627 | GOTO REPL_LOOP | |
628 | ||
629 | QUIT: | |
d7a6c2d6 | 630 | REM GOSUB PR_MEMORY_SUMMARY_SMALL |
7895453b | 631 | REM GOSUB PR_MEMORY_MAP |
d7a6c2d6 JM |
632 | REM P1=0:P2=ZI:GOSUB PR_MEMORY |
633 | REM P1=D:GOSUB PR_OBJECT | |
634 | REM P1=ZK:GOSUB PR_OBJECT | |
115e430d JM |
635 | #cbm END |
636 | #qbasic SYSTEM | |
30a3d828 JM |
637 | |
638 | PRINT_ERROR: | |
639 | REM if the error is an object, then print and free it | |
c756af81 JM |
640 | IF ER>=0 THEN AZ=ER:B=0:GOSUB PR_STR:E$=R$:AY=ER:GOSUB RELEASE |
641 | PRINT "Error: "+E$ | |
642 | ER=-2:E$="" | |
30a3d828 JM |
643 | RETURN |
644 |