basic/step5_tco.in.bas

   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 P1=ZT: P2=-1: GOSUB PR_MEMORY
 415     GOSUB PR_MEMORY_SUMMARY
 416     END
 417
 418   PRINT_ERROR:
 419     PRINT "Error: "+ER$
 420     ER=-2:ER$=""
 421     RETURN
 422