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