basic/step5_tco.in.bas

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