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