Commit | Line | Data |
---|---|---|
412e7348 JM |
1 | GOTO MAIN |
2 | ||
d7a6c2d6 | 3 | REM $INCLUDE: 'mem.in.bas' |
412e7348 | 4 | REM $INCLUDE: 'types.in.bas' |
93593012 | 5 | REM $INCLUDE: 'readline.in.bas' |
412e7348 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 | ||
9e8f5211 JM |
11 | REM $INCLUDE: 'debug.in.bas' |
12 | ||
cc9dbd92 | 13 | REM READ(A$) -> R |
412e7348 JM |
14 | MAL_READ: |
15 | GOSUB READ_STR | |
16 | RETURN | |
17 | ||
cc9dbd92 | 18 | REM EVAL_AST(A, E) -> R |
af621e3a | 19 | SUB EVAL_AST |
cc9dbd92 | 20 | REM push A and E on the stack |
93593012 JM |
21 | Q=E:GOSUB PUSH_Q |
22 | GOSUB PUSH_A | |
412e7348 | 23 | |
cc9dbd92 | 24 | IF ER<>-2 THEN GOTO EVAL_AST_RETURN |
412e7348 | 25 | |
4202ef7b | 26 | GOSUB TYPE_A |
cc9dbd92 JM |
27 | IF T=5 THEN GOTO EVAL_AST_SYMBOL |
28 | IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ | |
412e7348 JM |
29 | |
30 | REM scalar: deref to actual value and inc ref cnt | |
9d59cdb3 | 31 | R=A |
4202ef7b | 32 | GOSUB INC_REF_R |
412e7348 JM |
33 | GOTO EVAL_AST_RETURN |
34 | ||
35 | EVAL_AST_SYMBOL: | |
af621e3a JM |
36 | K=A:GOTO ENV_GET |
37 | ENV_GET_RETURN: | |
412e7348 JM |
38 | GOTO EVAL_AST_RETURN |
39 | ||
40 | EVAL_AST_SEQ: | |
9d59cdb3 JM |
41 | REM setup the stack for the loop |
42 | GOSUB MAP_LOOP_START | |
412e7348 JM |
43 | |
44 | EVAL_AST_SEQ_LOOP: | |
412e7348 | 45 | REM check if we are done evaluating the source sequence |
d7a6c2d6 | 46 | IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE |
412e7348 | 47 | |
01e8850d | 48 | REM if we are returning to DO, then skip last element |
9d59cdb3 JM |
49 | REM The EVAL_DO call to EVAL_AST must be call #2 for EVAL_AST to |
50 | REM return early and for TCO to work | |
51 | Q=5:GOSUB PEEK_Q_Q | |
d7a6c2d6 | 52 | IF Q=2 AND Z%(Z%(A+1)+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE |
01e8850d | 53 | |
9d59cdb3 JM |
54 | REM call EVAL for each entry |
55 | GOSUB PUSH_A | |
d7a6c2d6 JM |
56 | IF T<>8 THEN A=Z%(A+2) |
57 | IF T=8 THEN A=Z%(A+3) | |
9d59cdb3 JM |
58 | Q=T:GOSUB PUSH_Q: REM push/save type |
59 | CALL EVAL | |
60 | GOSUB POP_Q:T=Q: REM pop/restore type | |
61 | GOSUB POP_A | |
d7a6c2d6 | 62 | M=R |
412e7348 | 63 | |
9d59cdb3 JM |
64 | REM if error, release the unattached element |
65 | REM TODO: is R=0 correct? | |
66 | IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE | |
412e7348 | 67 | |
9d59cdb3 JM |
68 | REM for hash-maps, copy the key (inc ref since we are going to |
69 | REM release it below) | |
d7a6c2d6 | 70 | IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32 |
412e7348 | 71 | |
412e7348 | 72 | |
9d59cdb3 JM |
73 | REM update the return sequence structure |
74 | REM release N (and M if T=8) since seq takes full ownership | |
75 | C=1:GOSUB MAP_LOOP_UPDATE | |
412e7348 JM |
76 | |
77 | REM process the next sequence entry from source list | |
d7a6c2d6 | 78 | A=Z%(A+1) |
412e7348 JM |
79 | |
80 | GOTO EVAL_AST_SEQ_LOOP | |
81 | EVAL_AST_SEQ_LOOP_DONE: | |
9d59cdb3 JM |
82 | REM cleanup stack and get return value |
83 | GOSUB MAP_LOOP_DONE | |
412e7348 JM |
84 | GOTO EVAL_AST_RETURN |
85 | ||
86 | EVAL_AST_RETURN: | |
cc9dbd92 | 87 | REM pop A and E off the stack |
93593012 JM |
88 | GOSUB POP_A |
89 | GOSUB POP_Q:E=Q | |
af621e3a | 90 | END SUB |
412e7348 | 91 | |
af621e3a JM |
92 | REM EVAL(A, E) -> R |
93 | SUB EVAL | |
cc9dbd92 | 94 | LV=LV+1: REM track basic return stack level |
412e7348 | 95 | |
cc9dbd92 | 96 | REM push A and E on the stack |
93593012 JM |
97 | Q=E:GOSUB PUSH_Q |
98 | GOSUB PUSH_A | |
412e7348 | 99 | |
01e8850d JM |
100 | REM PRINT "EVAL A:"+STR$(A)+",X:"+STR$(X)+",LV:"+STR$(LV)+",FRE:"+STR$(FRE(0)) |
101 | ||
412e7348 JM |
102 | EVAL_TCO_RECUR: |
103 | ||
c7330b3d JM |
104 | IF ER<>-2 THEN GOTO EVAL_RETURN |
105 | ||
c756af81 | 106 | REM AZ=A:B=1:GOSUB PR_STR |
cc9dbd92 | 107 | REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]" |
412e7348 | 108 | |
412e7348 | 109 | GOSUB LIST_Q |
cc9dbd92 | 110 | IF R THEN GOTO APPLY_LIST |
412e7348 | 111 | REM ELSE |
af621e3a | 112 | CALL EVAL_AST |
412e7348 JM |
113 | GOTO EVAL_RETURN |
114 | ||
115 | APPLY_LIST: | |
116 | GOSUB EMPTY_Q | |
4202ef7b | 117 | IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN |
412e7348 | 118 | |
d7a6c2d6 | 119 | A0=Z%(A+2) |
412e7348 JM |
120 | |
121 | REM get symbol in A$ | |
d7a6c2d6 JM |
122 | IF (Z%(A0)AND 31)<>5 THEN A$="" |
123 | IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1)) | |
412e7348 JM |
124 | |
125 | IF A$="def!" THEN GOTO EVAL_DEF | |
126 | IF A$="let*" THEN GOTO EVAL_LET | |
127 | IF A$="do" THEN GOTO EVAL_DO | |
128 | IF A$="if" THEN GOTO EVAL_IF | |
129 | IF A$="fn*" THEN GOTO EVAL_FN | |
130 | GOTO EVAL_INVOKE | |
131 | ||
132 | EVAL_GET_A3: | |
d7a6c2d6 | 133 | A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2) |
412e7348 | 134 | EVAL_GET_A2: |
d7a6c2d6 | 135 | A2=Z%(Z%(Z%(A+1)+1)+2) |
412e7348 | 136 | EVAL_GET_A1: |
d7a6c2d6 | 137 | A1=Z%(Z%(A+1)+2) |
412e7348 JM |
138 | RETURN |
139 | ||
140 | EVAL_DEF: | |
141 | REM PRINT "def!" | |
bbab5c5d | 142 | GOSUB EVAL_GET_A2: REM set A1 and A2 |
412e7348 | 143 | |
93593012 | 144 | Q=A1:GOSUB PUSH_Q |
af621e3a | 145 | A=A2:CALL EVAL: REM eval a2 |
93593012 | 146 | GOSUB POP_Q:A1=Q |
412e7348 | 147 | |
cc9dbd92 | 148 | IF ER<>-2 THEN GOTO EVAL_RETURN |
70f29a2b | 149 | |
412e7348 | 150 | REM set a1 in env to a2 |
c756af81 | 151 | K=A1:C=R:GOSUB ENV_SET |
412e7348 JM |
152 | GOTO EVAL_RETURN |
153 | ||
154 | EVAL_LET: | |
155 | REM PRINT "let*" | |
bbab5c5d | 156 | GOSUB EVAL_GET_A2: REM set A1 and A2 |
412e7348 | 157 | |
93593012 JM |
158 | Q=A2:GOSUB PUSH_Q: REM push/save A2 |
159 | Q=E:GOSUB PUSH_Q: REM push env for for later release | |
412e7348 JM |
160 | |
161 | REM create new environment with outer as current environment | |
c756af81 | 162 | C=E:GOSUB ENV_NEW |
cc9dbd92 | 163 | E=R |
412e7348 | 164 | EVAL_LET_LOOP: |
d7a6c2d6 | 165 | IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE |
412e7348 | 166 | |
93593012 | 167 | Q=A1:GOSUB PUSH_Q: REM push A1 |
412e7348 | 168 | REM eval current A1 odd element |
d7a6c2d6 | 169 | A=Z%(Z%(A1+1)+2):CALL EVAL |
93593012 | 170 | GOSUB POP_Q:A1=Q: REM pop A1 |
412e7348 | 171 | |
c7330b3d JM |
172 | IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE |
173 | ||
d7a6c2d6 JM |
174 | REM set key/value in the environment |
175 | K=Z%(A1+2):C=R:GOSUB ENV_SET | |
cc9dbd92 | 176 | AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership |
412e7348 | 177 | |
bbab5c5d | 178 | REM skip to the next pair of A1 elements |
d7a6c2d6 | 179 | A1=Z%(Z%(A1+1)+1) |
412e7348 | 180 | GOTO EVAL_LET_LOOP |
70f29a2b | 181 | |
412e7348 | 182 | EVAL_LET_LOOP_DONE: |
9d59cdb3 | 183 | GOSUB POP_Q:AY=Q: REM pop previous env |
70f29a2b JM |
184 | |
185 | REM release previous environment if not the current EVAL env | |
93593012 | 186 | GOSUB PEEK_Q_2 |
9d59cdb3 | 187 | IF AY<>Q THEN GOSUB RELEASE |
412e7348 | 188 | |
93593012 | 189 | GOSUB POP_Q:A2=Q: REM pop A2 |
bbab5c5d | 190 | A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop |
412e7348 JM |
191 | |
192 | EVAL_DO: | |
d7a6c2d6 | 193 | A=Z%(A+1): REM rest |
93593012 | 194 | GOSUB PUSH_A: REM push/save A |
412e7348 | 195 | |
9d59cdb3 JM |
196 | REM this must be EVAL_AST call #2 for EVAL_AST to return early |
197 | REM and for TCO to work | |
af621e3a | 198 | CALL EVAL_AST |
412e7348 | 199 | |
01e8850d JM |
200 | REM cleanup |
201 | AY=R: REM get eval'd list for release | |
202 | ||
93593012 | 203 | GOSUB POP_A: REM pop/restore original A for LAST |
01e8850d JM |
204 | GOSUB LAST: REM get last element for return |
205 | A=R: REM new recur AST | |
206 | ||
207 | REM cleanup | |
208 | GOSUB RELEASE: REM release eval'd list | |
209 | AY=A:GOSUB RELEASE: REM release LAST value (not sure why) | |
210 | ||
211 | GOTO EVAL_TCO_RECUR: REM TCO loop | |
412e7348 JM |
212 | |
213 | EVAL_IF: | |
bbab5c5d | 214 | GOSUB EVAL_GET_A1: REM set A1 |
93593012 | 215 | GOSUB PUSH_A: REM push/save A |
af621e3a | 216 | A=A1:CALL EVAL |
93593012 | 217 | GOSUB POP_A: REM pop/restore A |
d7a6c2d6 | 218 | IF (R=0) OR (R=2) THEN GOTO EVAL_IF_FALSE |
412e7348 JM |
219 | |
220 | EVAL_IF_TRUE: | |
cc9dbd92 | 221 | AY=R:GOSUB RELEASE |
bbab5c5d JM |
222 | GOSUB EVAL_GET_A2: REM set A1 and A2 after EVAL |
223 | A=A2:GOTO EVAL_TCO_RECUR: REM TCO loop | |
412e7348 | 224 | EVAL_IF_FALSE: |
cc9dbd92 | 225 | AY=R:GOSUB RELEASE |
bbab5c5d | 226 | REM if no false case (A3), return nil |
037815e0 | 227 | GOSUB COUNT |
4202ef7b | 228 | IF R<4 THEN R=0:GOSUB INC_REF_R:GOTO EVAL_RETURN |
bbab5c5d JM |
229 | GOSUB EVAL_GET_A3: REM set A1 - A3 after EVAL |
230 | A=A3:GOTO EVAL_TCO_RECUR: REM TCO loop | |
412e7348 JM |
231 | |
232 | EVAL_FN: | |
bbab5c5d | 233 | GOSUB EVAL_GET_A2: REM set A1 and A2 |
4202ef7b | 234 | T=10:L=A2:M=A1:N=E:GOSUB ALLOC: REM mal function |
412e7348 JM |
235 | GOTO EVAL_RETURN |
236 | ||
237 | EVAL_INVOKE: | |
af621e3a | 238 | CALL EVAL_AST |
412e7348 JM |
239 | |
240 | REM if error, return f/args for release by caller | |
cc9dbd92 | 241 | IF ER<>-2 THEN GOTO EVAL_RETURN |
412e7348 JM |
242 | |
243 | REM push f/args for release after call | |
93593012 | 244 | GOSUB PUSH_R |
412e7348 | 245 | |
d7a6c2d6 JM |
246 | AR=Z%(R+1): REM rest |
247 | F=Z%(R+2) | |
412e7348 | 248 | |
bbab5c5d | 249 | REM if metadata, get the actual object |
4202ef7b JM |
250 | GOSUB TYPE_F |
251 | IF T=14 THEN F=Z%(F+1):GOSUB TYPE_F | |
bbab5c5d | 252 | |
4202ef7b | 253 | ON T-8 GOTO EVAL_DO_FUNCTION,EVAL_DO_MAL_FUNCTION,EVAL_DO_MAL_FUNCTION |
412e7348 JM |
254 | |
255 | REM if error, pop and return f/args for release by caller | |
93593012 | 256 | GOSUB POP_R |
c756af81 | 257 | ER=-1:E$="apply of non-function":GOTO EVAL_RETURN |
412e7348 JM |
258 | |
259 | EVAL_DO_FUNCTION: | |
01e8850d | 260 | REM regular function |
d7a6c2d6 | 261 | IF Z%(F+1)<60 THEN GOSUB DO_FUNCTION:GOTO EVAL_DO_FUNCTION_SKIP |
01e8850d | 262 | REM for recur functions (apply, map, swap!), use GOTO |
d7a6c2d6 | 263 | IF Z%(F+1)>60 THEN CALL DO_TCO_FUNCTION |
af621e3a | 264 | EVAL_DO_FUNCTION_SKIP: |
412e7348 JM |
265 | |
266 | REM pop and release f/args | |
93593012 JM |
267 | GOSUB POP_Q:AY=Q |
268 | GOSUB RELEASE | |
412e7348 JM |
269 | GOTO EVAL_RETURN |
270 | ||
271 | EVAL_DO_MAL_FUNCTION: | |
9d59cdb3 | 272 | Q=E:GOSUB PUSH_Q: REM save the current environment for release |
412e7348 | 273 | |
d7a6c2d6 JM |
274 | REM create new environ using env and params stored in function |
275 | C=Z%(F+3):A=Z%(F+2):B=AR:GOSUB ENV_NEW_BINDS | |
412e7348 JM |
276 | |
277 | REM release previous env if it is not the top one on the | |
bbab5c5d | 278 | REM stack (X%(X-2)) because our new env refers to it and |
412e7348 | 279 | REM we no longer need to track it (since we are TCO recurring) |
9d59cdb3 | 280 | GOSUB POP_Q:AY=Q |
93593012 | 281 | GOSUB PEEK_Q_2 |
9d59cdb3 | 282 | IF AY<>Q THEN GOSUB RELEASE |
412e7348 JM |
283 | |
284 | REM claim the AST before releasing the list containing it | |
d7a6c2d6 | 285 | A=Z%(F+1):Z%(A)=Z%(A)+32 |
9e8f5211 | 286 | REM add AST to pending release queue to free as soon as EVAL |
cc9dbd92 | 287 | REM actually returns (LV+1) |
93593012 | 288 | LV=LV+1:GOSUB PEND_A_LV:LV=LV-1 |
412e7348 JM |
289 | |
290 | REM pop and release f/args | |
93593012 JM |
291 | GOSUB POP_Q:AY=Q |
292 | GOSUB RELEASE | |
412e7348 | 293 | |
cc9dbd92 JM |
294 | REM A set above |
295 | E=R:GOTO EVAL_TCO_RECUR: REM TCO loop | |
412e7348 JM |
296 | |
297 | EVAL_RETURN: | |
c756af81 | 298 | REM AZ=R: B=1: GOSUB PR_STR |
cc9dbd92 | 299 | REM PRINT "EVAL_RETURN R: ["+R$+"] ("+STR$(R)+"), LV:"+STR$(LV)+",ER:"+STR$(ER) |
9e8f5211 | 300 | |
412e7348 | 301 | REM release environment if not the top one on the stack |
93593012 JM |
302 | GOSUB PEEK_Q_1 |
303 | IF E<>Q THEN AY=E:GOSUB RELEASE | |
412e7348 | 304 | |
cc9dbd92 | 305 | LV=LV-1: REM track basic return stack level |
9e8f5211 | 306 | |
412e7348 JM |
307 | REM release everything we couldn't release earlier |
308 | GOSUB RELEASE_PEND | |
309 | ||
412e7348 | 310 | REM trigger GC |
c756af81 JM |
311 | #cbm T=FRE(0) |
312 | #qbasic T=0 | |
412e7348 | 313 | |
cc9dbd92 | 314 | REM pop A and E off the stack |
93593012 JM |
315 | GOSUB POP_A |
316 | GOSUB POP_Q:E=Q | |
412e7348 | 317 | |
af621e3a | 318 | END SUB |
412e7348 | 319 | |
cc9dbd92 | 320 | REM PRINT(A) -> R$ |
412e7348 | 321 | MAL_PRINT: |
c756af81 | 322 | AZ=A:B=1:GOSUB PR_STR |
412e7348 JM |
323 | RETURN |
324 | ||
cc9dbd92 | 325 | REM RE(A$) -> R |
bbab5c5d | 326 | REM Assume D has repl_env |
85d70fb7 JM |
327 | REM caller must release result |
328 | RE: | |
4202ef7b | 329 | R1=-1 |
85d70fb7 | 330 | GOSUB MAL_READ |
cc9dbd92 | 331 | R1=R |
0e508fa5 | 332 | IF ER<>-2 THEN GOTO RE_DONE |
85d70fb7 | 333 | |
af621e3a | 334 | A=R:E=D:CALL EVAL |
85d70fb7 | 335 | |
0e508fa5 | 336 | RE_DONE: |
85d70fb7 | 337 | REM Release memory from MAL_READ |
4202ef7b | 338 | AY=R1:GOSUB RELEASE |
85d70fb7 JM |
339 | RETURN: REM caller must release result of EVAL |
340 | ||
412e7348 | 341 | REM REP(A$) -> R$ |
bbab5c5d | 342 | REM Assume D has repl_env |
af621e3a | 343 | SUB REP |
4202ef7b | 344 | R2=-1 |
412e7348 | 345 | |
4202ef7b | 346 | GOSUB RE |
cc9dbd92 JM |
347 | R2=R |
348 | IF ER<>-2 THEN GOTO REP_DONE | |
412e7348 | 349 | |
cc9dbd92 | 350 | A=R:GOSUB MAL_PRINT |
412e7348 JM |
351 | |
352 | REP_DONE: | |
353 | REM Release memory from MAL_READ and EVAL | |
9d59cdb3 | 354 | AY=R2:GOSUB RELEASE |
af621e3a | 355 | END SUB |
412e7348 JM |
356 | |
357 | REM MAIN program | |
358 | MAIN: | |
359 | GOSUB INIT_MEMORY | |
360 | ||
cc9dbd92 | 361 | LV=0 |
412e7348 JM |
362 | |
363 | REM create repl_env | |
9d59cdb3 | 364 | C=0:GOSUB ENV_NEW:D=R |
412e7348 JM |
365 | |
366 | REM core.EXT: defined in Basic | |
bbab5c5d | 367 | E=D:GOSUB INIT_CORE_NS: REM set core functions in repl_env |
412e7348 | 368 | |
bbab5c5d | 369 | ZT=ZI: REM top of memory after base repl_env |
412e7348 JM |
370 | |
371 | REM core.mal: defined using the language itself | |
60ef223c | 372 | A$="(def! not (fn* (a) (if a false true)))" |
cc9dbd92 | 373 | GOSUB RE:AY=R:GOSUB RELEASE |
412e7348 | 374 | |
85d70fb7 | 375 | REPL_LOOP: |
60ef223c | 376 | A$="user> ":GOSUB READLINE: REM call input parser |
01975886 | 377 | IF EZ=1 THEN GOTO QUIT |
9d59cdb3 | 378 | IF R$="" THEN GOTO REPL_LOOP |
412e7348 | 379 | |
af621e3a | 380 | A$=R$:CALL REP: REM call REP |
412e7348 | 381 | |
cc9dbd92 | 382 | IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP |
412e7348 | 383 | PRINT R$ |
85d70fb7 | 384 | GOTO REPL_LOOP |
412e7348 | 385 | |
85d70fb7 | 386 | QUIT: |
9d59cdb3 | 387 | REM GOSUB PR_MEMORY_SUMMARY_SMALL |
115e430d JM |
388 | #cbm END |
389 | #qbasic SYSTEM | |
412e7348 | 390 | |
85d70fb7 | 391 | PRINT_ERROR: |
c756af81 JM |
392 | PRINT "Error: "+E$ |
393 | ER=-2:E$="" | |
85d70fb7 JM |
394 | RETURN |
395 |