impls/basic/step3_env.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
  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   LV=LV+1
  20
  21   REM push A and E on the stack
  22   Q=E:GOSUB PUSH_Q
  23   GOSUB PUSH_A
  24
  25   IF ER<>-2 THEN GOTO EVAL_AST_RETURN
  26
  27   GOSUB TYPE_A
  28   IF T=5 THEN GOTO EVAL_AST_SYMBOL
  29   IF T>=6 AND T<=8 THEN GOTO EVAL_AST_SEQ
  30
  31   REM scalar: deref to actual value and inc ref cnt
  32   R=A
  33   GOSUB INC_REF_R
  34   GOTO EVAL_AST_RETURN
  35
  36   EVAL_AST_SYMBOL:
  37     K=A:GOTO ENV_GET
  38     ENV_GET_RETURN:
  39     GOTO EVAL_AST_RETURN
  40
  41   EVAL_AST_SEQ:
  42     REM setup the stack for the loop
  43     GOSUB MAP_LOOP_START
  44
  45     EVAL_AST_SEQ_LOOP:
  46       REM check if we are done evaluating the source sequence
  47       IF Z%(A+1)=0 THEN GOTO EVAL_AST_SEQ_LOOP_DONE
  48
  49       REM call EVAL for each entry
  50       GOSUB PUSH_A
  51       IF T<>8 THEN A=Z%(A+2)
  52       IF T=8 THEN A=Z%(A+3)
  53       Q=T:GOSUB PUSH_Q: REM push/save type
  54       CALL EVAL
  55       GOSUB POP_Q:T=Q: REM pop/restore type
  56       GOSUB POP_A
  57       M=R
  58
  59       REM if error, release the unattached element
  60       REM TODO: is R=0 correct?
  61       IF ER<>-2 THEN AY=R:GOSUB RELEASE:R=0:GOTO EVAL_AST_SEQ_LOOP_DONE
  62
  63       REM for hash-maps, copy the key (inc ref since we are going to
  64       REM release it below)
  65       IF T=8 THEN N=M:M=Z%(A+2):Z%(M)=Z%(M)+32
  66
  67
  68       REM update the return sequence structure
  69       REM release N (and M if T=8) since seq takes full ownership
  70       C=1:GOSUB MAP_LOOP_UPDATE
  71
  72       REM process the next sequence entry from source list
  73       A=Z%(A+1)
  74
  75       GOTO EVAL_AST_SEQ_LOOP
  76     EVAL_AST_SEQ_LOOP_DONE:
  77       REM cleanup stack and get return value
  78       GOSUB MAP_LOOP_DONE
  79       GOTO EVAL_AST_RETURN
  80
  81   EVAL_AST_RETURN:
  82     REM pop A and E off the stack
  83     GOSUB POP_A
  84     GOSUB POP_Q:E=Q
  85
  86     LV=LV-1
  87 END SUB
  88
  89 REM EVAL(A, E) -> R
  90 SUB EVAL
  91   LV=LV+1: REM track basic return stack level
  92
  93   REM push A and E on the stack
  94   Q=E:GOSUB PUSH_Q
  95   GOSUB PUSH_A
  96
  97   IF ER<>-2 THEN GOTO EVAL_RETURN
  98
  99   REM AZ=A:B=1:GOSUB PR_STR
 100   REM PRINT "EVAL: "+R$+" [A:"+STR$(A)+", LV:"+STR$(LV)+"]"
 101
 102   GOSUB LIST_Q
 103   IF R THEN GOTO APPLY_LIST
 104   REM ELSE
 105     CALL EVAL_AST
 106     GOTO EVAL_RETURN
 107
 108   APPLY_LIST:
 109     GOSUB EMPTY_Q
 110     IF R THEN R=A:GOSUB INC_REF_R:GOTO EVAL_RETURN
 111
 112     A0=Z%(A+2)
 113
 114     REM get symbol in A$
 115     IF (Z%(A0)AND 31)<>5 THEN A$=""
 116     IF (Z%(A0)AND 31)=5 THEN A$=S$(Z%(A0+1))
 117
 118     IF A$="def!" THEN GOTO EVAL_DEF
 119     IF A$="let*" THEN GOTO EVAL_LET
 120     GOTO EVAL_INVOKE
 121
 122     EVAL_GET_A3:
 123       A3=Z%(Z%(Z%(Z%(A+1)+1)+1)+2)
 124     EVAL_GET_A2:
 125       A2=Z%(Z%(Z%(A+1)+1)+2)
 126     EVAL_GET_A1:
 127       A1=Z%(Z%(A+1)+2)
 128       RETURN
 129
 130     EVAL_DEF:
 131       REM PRINT "def!"
 132       GOSUB EVAL_GET_A2: REM set A1 and A2
 133
 134       Q=A1:GOSUB PUSH_Q
 135       A=A2:CALL EVAL: REM eval a2
 136       GOSUB POP_Q:A1=Q
 137
 138       IF ER<>-2 THEN GOTO EVAL_RETURN
 139
 140       REM set a1 in env to a2
 141       K=A1:C=R:GOSUB ENV_SET
 142       GOTO EVAL_RETURN
 143
 144     EVAL_LET:
 145       REM PRINT "let*"
 146       GOSUB EVAL_GET_A2: REM set A1 and A2
 147
 148       Q=A2:GOSUB PUSH_Q: REM push/save A2
 149       REM create new environment with outer as current environment
 150       C=E:GOSUB ENV_NEW
 151       E=R
 152       EVAL_LET_LOOP:
 153         IF Z%(A1+1)=0 THEN GOTO EVAL_LET_LOOP_DONE
 154
 155         Q=A1:GOSUB PUSH_Q: REM push A1
 156         REM eval current A1 odd element
 157         A=Z%(Z%(A1+1)+2):CALL EVAL
 158         GOSUB POP_Q:A1=Q: REM pop A1
 159
 160         IF ER<>-2 THEN GOTO EVAL_LET_LOOP_DONE
 161
 162         REM set key/value in the environment
 163         K=Z%(A1+2):C=R:GOSUB ENV_SET
 164         AY=R:GOSUB RELEASE: REM release our use, ENV_SET took ownership
 165
 166         REM skip to the next pair of A1 elements
 167         A1=Z%(Z%(A1+1)+1)
 168         GOTO EVAL_LET_LOOP
 169
 170       EVAL_LET_LOOP_DONE:
 171         GOSUB POP_Q:A2=Q: REM pop A2
 172         A=A2:CALL EVAL: REM eval A2 using let_env
 173         GOTO EVAL_RETURN
 174     EVAL_INVOKE:
 175       CALL EVAL_AST
 176       W=R
 177
 178       REM if error, return f/args for release by caller
 179       IF ER<>-2 THEN GOTO EVAL_RETURN
 180
 181       AR=Z%(R+1): REM rest
 182       F=Z%(R+2)
 183
 184       GOSUB TYPE_F
 185       IF T<>9 THEN R=-1:ER=-1:E$="apply of non-function":GOTO EVAL_INVOKE_DONE
 186       GOSUB DO_FUNCTION
 187       EVAL_INVOKE_DONE:
 188       AY=W:GOSUB RELEASE
 189       GOTO EVAL_RETURN
 190
 191   EVAL_RETURN:
 192     REM release environment if not the top one on the stack
 193     GOSUB PEEK_Q_1
 194     IF E<>Q THEN AY=E:GOSUB RELEASE
 195
 196     LV=LV-1: REM track basic return stack level
 197
 198     REM trigger GC
 199     #cbm T=FRE(0)
 200     #qbasic T=0
 201
 202     REM pop A and E off the stack
 203     GOSUB POP_A
 204     GOSUB POP_Q:E=Q
 205
 206 END SUB
 207
 208 REM DO_FUNCTION(F, AR)
 209 DO_FUNCTION:
 210   REM Get the function number
 211   G=Z%(F+1)
 212
 213   REM Get argument values
 214   A=Z%(Z%(AR+2)+1)
 215   B=Z%(Z%(Z%(AR+1)+2)+1)
 216
 217   REM Switch on the function number
 218   IF G=1 THEN GOTO DO_ADD
 219   IF G=2 THEN GOTO DO_SUB
 220   IF G=3 THEN GOTO DO_MULT
 221   IF G=4 THEN GOTO DO_DIV
 222   ER=-1:E$="unknown function"+STR$(G):RETURN
 223
 224   DO_ADD:
 225     T=2:L=A+B:GOSUB ALLOC
 226     GOTO DO_FUNCTION_DONE
 227   DO_SUB:
 228     T=2:L=A-B:GOSUB ALLOC
 229     GOTO DO_FUNCTION_DONE
 230   DO_MULT:
 231     T=2:L=A*B:GOSUB ALLOC
 232     GOTO DO_FUNCTION_DONE
 233   DO_DIV:
 234     T=2:L=A/B:GOSUB ALLOC
 235     GOTO DO_FUNCTION_DONE
 236
 237   DO_FUNCTION_DONE:
 238     RETURN
 239
 240 REM PRINT(A) -> R$
 241 MAL_PRINT:
 242   AZ=A:B=1:GOSUB PR_STR
 243   RETURN
 244
 245 REM REP(A$) -> R$
 246 REM Assume D has repl_env
 247 SUB REP
 248   R1=-1:R2=-1
 249   GOSUB MAL_READ
 250   R1=R
 251   IF ER<>-2 THEN GOTO REP_DONE
 252
 253   A=R:E=D:CALL EVAL
 254   R2=R
 255   IF ER<>-2 THEN GOTO REP_DONE
 256
 257   A=R:GOSUB MAL_PRINT
 258
 259   REP_DONE:
 260     REM Release memory from MAL_READ and EVAL
 261     AY=R2:GOSUB RELEASE
 262     AY=R1:GOSUB RELEASE
 263 END SUB
 264
 265 REM MAIN program
 266 MAIN:
 267   GOSUB INIT_MEMORY
 268
 269   LV=0
 270
 271   REM create repl_env
 272   C=0:GOSUB ENV_NEW:D=R
 273
 274   E=D
 275   REM + function
 276   T=9:L=1:GOSUB ALLOC: REM native function
 277   B$="+":C=R:GOSUB ENV_SET_S
 278
 279   REM - function
 280   T=9:L=2:GOSUB ALLOC: REM native function
 281   B$="-":C=R:GOSUB ENV_SET_S
 282
 283   REM * function
 284   T=9:L=3:GOSUB ALLOC: REM native function
 285   B$="*":C=R:GOSUB ENV_SET_S
 286
 287   REM / function
 288   T=9:L=4:GOSUB ALLOC: REM native function
 289   B$="/":C=R:GOSUB ENV_SET_S
 290
 291   ZT=ZI: REM top of memory after base repl_env
 292
 293   REPL_LOOP:
 294     A$="user> ":GOSUB READLINE: REM call input parser
 295     IF EZ=1 THEN GOTO QUIT
 296     IF R$="" THEN GOTO REPL_LOOP
 297
 298     A$=R$:CALL REP: REM call REP
 299
 300     IF ER<>-2 THEN GOSUB PRINT_ERROR:GOTO REPL_LOOP
 301     PRINT R$
 302     GOTO REPL_LOOP
 303
 304   QUIT:
 305     REM GOSUB PR_MEMORY_SUMMARY_SMALL
 306     #cbm END
 307     #qbasic SYSTEM
 308
 309   PRINT_ERROR:
 310     PRINT "Error: "+E$
 311     ER=-2:E$=""
 312     RETURN
 313