basic/core.in.bas

   1
   2 REM DO_FUNCTION(F, AR)
   3 DO_FUNCTION:
   4   REM Get the function number
   5   FF=Z%(F,1)
   6
   7   REM Get argument values
   8   R=AR+1:GOSUB DEREF_R:AA=R
   9   R=Z%(AR,1)+1:GOSUB DEREF_R:AB=R
  10
  11   REM Switch on the function number
  12   IF FF>=61 THEN ER=-1:ER$="unknown function"+STR$(FF):RETURN
  13   IF FF>=53 THEN DO_53
  14   IF FF>=39 THEN DO_39
  15   IF FF>=27 THEN DO_27
  16   IF FF>=18 THEN DO_18
  17   IF FF>=11 THEN DO_11
  18
  19   ON FF GOTO DO_EQUAL_Q,DO_THROW,DO_NIL_Q,DO_TRUE_Q,DO_FALSE_Q,DO_STRING_Q,DO_SYMBOL,DO_SYMBOL_Q
  20   DO_11:
  21   ON FF-10 GOTO DO_PR_STR,DO_STR,DO_PRN,DO_PRINTLN,DO_READ_STRING,DO_READLINE,DO_SLURP
  22   DO_18:
  23   ON FF-17 GOTO DO_LT,DO_LTE,DO_GT,DO_GTE,DO_ADD,DO_SUB,DO_MULT,DO_DIV,DO_TIME_MS
  24   DO_27:
  25   ON FF-26 GOTO DO_LIST,DO_LIST_Q,DO_VECTOR,DO_VECTOR_Q,DO_HASH_MAP,DO_MAP_Q
  26   DO_39:
  27   ON FF-38 GOTO DO_SEQUENTIAL_Q,DO_CONS,DO_CONCAT,DO_NTH,DO_FIRST,DO_REST,DO_EMPTY_Q,DO_COUNT,DO_APPLY,DO_MAP
  28   DO_53:
  29   ON FF-52 GOTO DO_ATOM,DO_ATOM_Q,DO_DEREF,DO_RESET_BANG,DO_SWAP_BANG,DO_PR_MEMORY,DO_PR_MEMORY_SUMMARY,DO_EVAL
  30
  31   DO_EQUAL_Q:
  32     A=AA:B=AB:GOSUB EQUAL_Q
  33     R=R+1
  34     RETURN
  35   DO_THROW:
  36     ER=AA
  37     Z%(ER,0)=Z%(ER,0)+16
  38     R=0
  39     RETURN
  40   DO_NIL_Q:
  41     R=1
  42     IF AA=0 THEN R=2
  43     RETURN
  44   DO_TRUE_Q:
  45     R=1
  46     IF AA=2 THEN R=2
  47     RETURN
  48   DO_FALSE_Q:
  49     R=1
  50     IF AA=1 THEN R=2
  51     RETURN
  52   DO_STRING_Q:
  53     R=1
  54     IF (Z%(AA,0)AND15)=4 THEN R=2
  55     RETURN
  56   DO_SYMBOL:
  57     R=0
  58     RETURN
  59   DO_SYMBOL_Q:
  60     R=1
  61     IF (Z%(AA,0)AND15)=5 THEN R=2
  62     RETURN
  63
  64   DO_PR_STR:
  65     AZ=AR:PR=1:SE$=" ":GOSUB PR_STR_SEQ
  66     AS$=R$:T=4+16:GOSUB STRING
  67     RETURN
  68   DO_STR:
  69     AZ=AR:PR=0:SE$="":GOSUB PR_STR_SEQ
  70     AS$=R$:T=4+16:GOSUB STRING
  71     RETURN
  72   DO_PRN:
  73     AZ=AR:PR=1:SE$=" ":GOSUB PR_STR_SEQ
  74     PRINT R$
  75     R=0
  76     RETURN
  77   DO_PRINTLN:
  78     AZ=AR:PR=0:SE$=" ":GOSUB PR_STR_SEQ
  79     PRINT R$
  80     R=0
  81     RETURN
  82   DO_READ_STRING:
  83     A$=S$(Z%(AA,1))
  84     GOSUB READ_STR
  85     RETURN
  86   DO_READLINE:
  87     A$=S$(Z%(AA,1)):GOSUB READLINE
  88     IF EOF=1 THEN EOF=0:R=0:RETURN
  89     AS$=R$:T=4:GOSUB STRING
  90     Z%(R,0)=Z%(R,0)+16
  91     RETURN
  92   DO_SLURP:
  93     R$=""
  94     REM OPEN 1,8,2,S$(Z%(AA,1))+",SEQ,R"
  95     REM OPEN 1,8,2,S$(Z%(AA,1))
  96     OPEN 1,8,0,S$(Z%(AA,1))
  97     DO_SLURP_LOOP:
  98       A$=""
  99       GET#1,A$
 100       IF ASC(A$)=10 THEN R$=R$+CHR$(13)
 101       IF (ASC(A$)<>10) AND (A$<>"") THEN R$=R$+A$
 102       IF (ST AND 64) THEN GOTO DO_SLURP_DONE
 103       IF (ST AND 255) THEN ER=-1:ER$="File read error "+STR$(ST):RETURN
 104       GOTO DO_SLURP_LOOP
 105     DO_SLURP_DONE:
 106       CLOSE 1
 107       AS$=R$:T=4+16:GOSUB STRING
 108       RETURN
 109
 110   DO_LT:
 111     R=1
 112     IF Z%(AA,1)<Z%(AB,1) THEN R=2
 113     RETURN
 114   DO_LTE:
 115     R=1
 116     IF Z%(AA,1)<=Z%(AB,1) THEN R=2
 117     RETURN
 118   DO_GT:
 119     R=1
 120     IF Z%(AA,1)>Z%(AB,1) THEN R=2
 121     RETURN
 122   DO_GTE:
 123     R=1
 124     IF Z%(AA,1)>=Z%(AB,1) THEN R=2
 125     RETURN
 126
 127   DO_ADD:
 128     SZ=1:GOSUB ALLOC
 129     Z%(R,0)=2+16
 130     Z%(R,1)=Z%(AA,1)+Z%(AB,1)
 131     RETURN
 132   DO_SUB:
 133     SZ=1:GOSUB ALLOC
 134     Z%(R,0)=2+16
 135     Z%(R,1)=Z%(AA,1)-Z%(AB,1)
 136     RETURN
 137   DO_MULT:
 138     SZ=1:GOSUB ALLOC
 139     Z%(R,0)=2+16
 140     Z%(R,1)=Z%(AA,1)*Z%(AB,1)
 141     RETURN
 142   DO_DIV:
 143     SZ=1:GOSUB ALLOC
 144     Z%(R,0)=2+16
 145     Z%(R,1)=Z%(AA,1)/Z%(AB,1)
 146     RETURN
 147   DO_TIME_MS:
 148     R=0
 149     RETURN
 150
 151   DO_LIST:
 152     R=AR
 153     Z%(R,0)=Z%(R,0)+16
 154     RETURN
 155   DO_LIST_Q:
 156     A=AA:GOSUB LIST_Q
 157     R=R+1: REM map to mal false/true
 158     RETURN
 159   DO_VECTOR:
 160     R=0
 161     RETURN
 162   DO_VECTOR_Q:
 163     R=1
 164     IF (Z%(AA,0)AND15)=7 THEN R=2
 165     RETURN
 166   DO_HASH_MAP:
 167     R=0
 168     RETURN
 169   DO_MAP_Q:
 170     R=1
 171     IF (Z%(AA,0)AND15)=8 THEN R=2
 172     RETURN
 173
 174   DO_SEQUENTIAL_Q:
 175     R=1
 176     IF (Z%(AA,0)AND15)=6 OR (Z%(AA,0)AND15)=7 THEN R=2
 177     RETURN
 178   DO_CONS:
 179     A=AA:B=AB:GOSUB CONS
 180     RETURN
 181   DO_CONCAT:
 182     REM if empty arguments, return empty list
 183     IF Z%(AR,1)=0 THEN R=3:Z%(R,0)=Z%(R,0)+16:RETURN
 184
 185     REM single argument
 186     IF Z%(Z%(AR,1),1)<>0 THEN GOTO DO_CONCAT_MULT
 187       REM if single argument and it's a list, return it
 188       IF (Z%(AA,0)AND15)=6 THEN R=AA:Z%(R,0)=Z%(R,0)+16:RETURN
 189       REM otherwise, copy first element to turn it into a list
 190       B=AA+1:GOSUB DEREF_B: REM value to copy
 191       SZ=2:GOSUB ALLOC
 192       Z%(R,0)=6+16:Z%(R,1)=Z%(AA,1)
 193       Z%(R+1,0)=14:Z%(R+1,1)=B
 194       REM inc ref count of trailing list part and of copied value
 195       Z%(Z%(AA,1),0)=Z%(Z%(AA,1),0)+16
 196       Z%(B,0)=Z%(B,0)+16
 197       RETURN
 198
 199     REM multiple arguments
 200     DO_CONCAT_MULT:
 201       CZ%=X: REM save current stack position
 202       REM push arguments onto the stack
 203       DO_CONCAT_STACK:
 204         R=AR+1:GOSUB DEREF_R
 205         X=X+1:S%(X)=R: REM push sequence
 206         AR=Z%(AR,1)
 207         IF Z%(AR,1)<>0 THEN GOTO DO_CONCAT_STACK
 208
 209     REM pop last argument as our seq to prepend to
 210     AB=S%(X):X=X-1
 211     REM last arg/seq is not copied so we need to inc ref to it
 212     Z%(AB,0)=Z%(AB,0)+16
 213     DO_CONCAT_LOOP:
 214       IF X=CZ% THEN R=AB:RETURN
 215       AA=S%(X):X=X-1: REM pop off next seq to prepend
 216       IF Z%(AA,1)=0 THEN GOTO DO_CONCAT_LOOP: REM skip empty seqs
 217       A=AA:B=0:C=-1:GOSUB SLICE
 218
 219       REM release the terminator of new list (we skip over it)
 220       AY=Z%(R6,1):GOSUB RELEASE
 221       REM attach new list element before terminator (last actual
 222       REM element to the next sequence
 223       Z%(R6,1)=AB
 224
 225       AB=R
 226       GOTO DO_CONCAT_LOOP
 227   DO_NTH:
 228     B=Z%(AB,1)
 229     A=AA:GOSUB COUNT
 230     IF R<=B THEN R=0:ER=-1:ER$="nth: index out of range":RETURN
 231     DO_NTH_LOOP:
 232       IF B=0 THEN GOTO DO_NTH_DONE
 233       B=B-1
 234       AA=Z%(AA,1)
 235       GOTO DO_NTH_LOOP
 236     DO_NTH_DONE:
 237       R=Z%(AA+1,1)
 238       Z%(R,0)=Z%(R,0)+16
 239       RETURN
 240   DO_FIRST:
 241     IF Z%(AA,1)=0 THEN R=0
 242     IF Z%(AA,1)<>0 THEN R=AA+1:GOSUB DEREF_R
 243     IF R<>0 THEN Z%(R,0)=Z%(R,0)+16
 244     RETURN
 245   DO_REST:
 246     IF Z%(AA,1)=0 THEN R=AA
 247     IF Z%(AA,1)<>0 THEN R=Z%(AA,1)
 248     Z%(R,0)=Z%(R,0)+16
 249     RETURN
 250   DO_EMPTY_Q:
 251     R=1
 252     IF Z%(AA,1)=0 THEN R=2
 253     RETURN
 254   DO_COUNT:
 255     A=AA:GOSUB COUNT:R4=R
 256     SZ=1:GOSUB ALLOC
 257     Z%(R,0)=2+16
 258     Z%(R,1)=R4
 259     RETURN
 260   DO_APPLY:
 261     F=AA
 262     AR=Z%(AR,1)
 263     A=AR:GOSUB COUNT:R4=R
 264
 265     REM no intermediate args, just call APPLY directly
 266     IF R4<=1 THEN AR=Z%(AR+1,1):GOSUB APPLY:RETURN
 267
 268     REM prepend intermediate args to final args element
 269     A=AR:B=0:C=R4-1:GOSUB SLICE
 270     REM release the terminator of new list (we skip over it)
 271     AY=Z%(R6,1):GOSUB RELEASE
 272     REM attach end of slice to final args element
 273     Z%(R6,1)=Z%(A+1,1)
 274     Z%(Z%(A+1,1),0)=Z%(Z%(A+1,1),0)+16
 275
 276     X=X+1:S%(X)=R: REM push/save new args for release
 277     AR=R:GOSUB APPLY
 278     AY=S%(X):X=X-1:GOSUB RELEASE: REM pop/release new args
 279     RETURN
 280   DO_MAP:
 281     F=AA
 282
 283     REM first result list element
 284     SZ=2:GOSUB ALLOC
 285
 286     REM push future return val, prior entry, F and AB
 287     X=X+4:S%(X-3)=R:S%(X-2)=0:S%(X-1)=F:S%(X)=AB
 288
 289     DO_MAP_LOOP:
 290       REM set base values
 291       Z%(R,0)=6+16:Z%(R,1)=0
 292       Z%(R+1,0)=14:Z%(R+1,1)=0
 293
 294       REM set previous to current if not the first element
 295       IF S%(X-2)<>0 THEN Z%(S%(X-2),1)=R
 296       REM update previous reference to current
 297       S%(X-2)=R
 298
 299       IF Z%(AB,1)=0 THEN GOTO DO_MAP_DONE
 300
 301       REM create argument list for apply call
 302       SZ=2:GOSUB ALLOC
 303       Z%(R,0)=6+16:Z%(R,1)=0
 304       Z%(R+1,0)=14:Z%(R+1,1)=0
 305       AR=R: REM save end of list temporarily
 306       SZ=2:GOSUB ALLOC
 307       Z%(R,0)=6+16:Z%(R,1)=AR
 308       REM inc ref cnt of referred argument
 309       A=Z%(AB+1,1): Z%(A,0)=Z%(A,0)+16
 310       Z%(R+1,0)=14:Z%(R+1,1)=A
 311
 312       REM push argument list
 313       X=X+1:S%(X)=R
 314
 315       AR=R:GOSUB APPLY
 316
 317       REM pop apply args are release them
 318       AY=S%(X):X=X-1:GOSUB RELEASE
 319
 320       REM set the result value
 321       Z%(S%(X-2)+1,1)=R
 322
 323       REM restore F
 324       F=S%(X-1)
 325
 326       REM update AB to next source element
 327       S%(X)=Z%(S%(X),1)
 328       AB=S%(X)
 329
 330       REM allocate next element
 331       SZ=2:GOSUB ALLOC
 332
 333       GOTO DO_MAP_LOOP
 334
 335     DO_MAP_DONE:
 336       REM get return val
 337       R=S%(X-3)
 338       REM pop everything off stack
 339       X=X-4
 340       RETURN
 341
 342   DO_ATOM:
 343     SZ=1:GOSUB ALLOC
 344     Z%(AA,0)=Z%(AA,0)+16: REM inc ref cnt of contained value
 345     Z%(R,0)=12+16
 346     Z%(R,1)=AA
 347     RETURN
 348   DO_ATOM_Q:
 349     R=1
 350     IF (Z%(AA,0)AND15)=12 THEN R=2
 351     RETURN
 352   DO_DEREF:
 353     R=Z%(AA,1):GOSUB DEREF_R
 354     Z%(R,0)=Z%(R,0)+16
 355     RETURN
 356   DO_RESET_BANG:
 357     R=AB
 358     REM release current value
 359     AY=Z%(AA,1):GOSUB RELEASE
 360     REM inc ref by 2 for atom ownership and since we are returning it
 361     Z%(R,0)=Z%(R,0)+32
 362     REM update value
 363     Z%(AA,1)=R
 364     RETURN
 365   DO_SWAP_BANG:
 366     F=AB
 367
 368     REM add atom to front of the args list
 369     A=Z%(AA,1):B=Z%(Z%(AR,1),1):GOSUB CONS
 370     AR=R
 371
 372     REM push args for release after
 373     X=X+1:S%(X)=AR
 374
 375     REM push atom
 376     X=X+1:S%(X)=AA
 377
 378     GOSUB APPLY
 379
 380     REM pop atom
 381     AA=S%(X):X=X-1
 382
 383     REM pop and release args
 384     AY=S%(X):X=X-1:GOSUB RELEASE
 385
 386     REM use reset to update the value
 387     AB=R:GOSUB DO_RESET_BANG
 388
 389     REM but decrease ref cnt of return by 1 (not sure why)
 390     AY=R:GOSUB RELEASE
 391
 392     RETURN
 393
 394   DO_PR_MEMORY:
 395     P1%=ZT%:P2%=-1:GOSUB PR_MEMORY
 396     RETURN
 397   DO_PR_MEMORY_SUMMARY:
 398     GOSUB PR_MEMORY_SUMMARY
 399     RETURN
 400
 401   DO_EVAL:
 402     A=AA:E=RE%:GOSUB EVAL
 403     RETURN
 404
 405 INIT_CORE_SET_FUNCTION:
 406   GOSUB NATIVE_FUNCTION
 407   V=R:GOSUB ENV_SET_S
 408   RETURN
 409
 410 REM INIT_CORE_NS(E)
 411 INIT_CORE_NS:
 412   REM create the environment mapping
 413   REM must match DO_FUNCTION mappings
 414
 415   K$="=":A=1:GOSUB INIT_CORE_SET_FUNCTION
 416   K$="throw":A=2:GOSUB INIT_CORE_SET_FUNCTION
 417   K$="nil?":A=3:GOSUB INIT_CORE_SET_FUNCTION
 418   K$="true?":A=4:GOSUB INIT_CORE_SET_FUNCTION
 419   K$="false?":A=5:GOSUB INIT_CORE_SET_FUNCTION
 420   K$="string?":A=6:GOSUB INIT_CORE_SET_FUNCTION
 421   K$="symbol":A=7:GOSUB INIT_CORE_SET_FUNCTION
 422   K$="symbol?":A=8:GOSUB INIT_CORE_SET_FUNCTION
 423
 424   K$="pr-str":A=11:GOSUB INIT_CORE_SET_FUNCTION
 425   K$="str":A=12:GOSUB INIT_CORE_SET_FUNCTION
 426   K$="prn":A=13:GOSUB INIT_CORE_SET_FUNCTION
 427   K$="println":A=14:GOSUB INIT_CORE_SET_FUNCTION
 428   K$="read-string":A=15:GOSUB INIT_CORE_SET_FUNCTION
 429   K$="readline":A=16:GOSUB INIT_CORE_SET_FUNCTION
 430   K$="slurp":A=17:GOSUB INIT_CORE_SET_FUNCTION
 431
 432   K$="<":A=18:GOSUB INIT_CORE_SET_FUNCTION
 433   K$="<=":A=19:GOSUB INIT_CORE_SET_FUNCTION
 434   K$=">":A=20:GOSUB INIT_CORE_SET_FUNCTION
 435   K$=">=":A=21:GOSUB INIT_CORE_SET_FUNCTION
 436   K$="+":A=22:GOSUB INIT_CORE_SET_FUNCTION
 437   K$="-":A=23:GOSUB INIT_CORE_SET_FUNCTION
 438   K$="*":A=24:GOSUB INIT_CORE_SET_FUNCTION
 439   K$="/":A=25:GOSUB INIT_CORE_SET_FUNCTION
 440   K$="time-ms":A=26:GOSUB INIT_CORE_SET_FUNCTION
 441
 442   K$="list":A=27:GOSUB INIT_CORE_SET_FUNCTION
 443   K$="list?":A=28:GOSUB INIT_CORE_SET_FUNCTION
 444   K$="vector":A=29:GOSUB INIT_CORE_SET_FUNCTION
 445   K$="vector?":A=30:GOSUB INIT_CORE_SET_FUNCTION
 446   K$="hash-map":A=31:GOSUB INIT_CORE_SET_FUNCTION
 447   K$="map?":A=32:GOSUB INIT_CORE_SET_FUNCTION
 448
 449   K$="sequential?":A=39:GOSUB INIT_CORE_SET_FUNCTION
 450   K$="cons":A=40:GOSUB INIT_CORE_SET_FUNCTION
 451   K$="concat":A=41:GOSUB INIT_CORE_SET_FUNCTION
 452   K$="nth":A=42:GOSUB INIT_CORE_SET_FUNCTION
 453   K$="first":A=43:GOSUB INIT_CORE_SET_FUNCTION
 454   K$="rest":A=44:GOSUB INIT_CORE_SET_FUNCTION
 455   K$="empty?":A=45:GOSUB INIT_CORE_SET_FUNCTION
 456   K$="count":A=46:GOSUB INIT_CORE_SET_FUNCTION
 457   K$="apply":A=47:GOSUB INIT_CORE_SET_FUNCTION
 458   K$="map":A=48:GOSUB INIT_CORE_SET_FUNCTION
 459
 460   K$="atom":A=53:GOSUB INIT_CORE_SET_FUNCTION
 461   K$="atom?":A=54:GOSUB INIT_CORE_SET_FUNCTION
 462   K$="deref":A=55:GOSUB INIT_CORE_SET_FUNCTION
 463   K$="reset!":A=56:GOSUB INIT_CORE_SET_FUNCTION
 464   K$="swap!":A=57:GOSUB INIT_CORE_SET_FUNCTION
 465
 466   K$="pr-memory":A=58:GOSUB INIT_CORE_SET_FUNCTION
 467   K$="pr-memory-summary":A=59:GOSUB INIT_CORE_SET_FUNCTION
 468   K$="eval":A=60:GOSUB INIT_CORE_SET_FUNCTION
 469
 470   RETURN