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$=ZS$(Z%(AA%,1))
  84     GOSUB READ_STR
  85     RETURN
  86   DO_READLINE:
  87     A$=ZS$(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,ZS$(Z%(AA%,1))+",SEQ,R"
  95     REM OPEN 1,8,2,ZS$(Z%(AA%,1))
  96     OPEN 1,8,0,ZS$(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%=ZL%: REM save current stack position
 202       REM push arguments onto the stack
 203       DO_CONCAT_STACK:
 204         R%=AR%+1:GOSUB DEREF_R
 205         ZL%=ZL%+1:ZZ%(ZL%)=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%=ZZ%(ZL%):ZL%=ZL%-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 ZL%=CZ% THEN R%=AB%:RETURN
 215       AA%=ZZ%(ZL%):ZL%=ZL%-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     ZL%=ZL%+1:ZZ%(ZL%)=R%: REM push/save new args for release
 277     AR%=R%:GOSUB APPLY
 278     AY%=ZZ%(ZL%):ZL%=ZL%-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     ZL%=ZL%+4:ZZ%(ZL%-3)=R%:ZZ%(ZL%-2)=0:ZZ%(ZL%-1)=F%:ZZ%(ZL%)=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 ZZ%(ZL%-2)<>0 THEN Z%(ZZ%(ZL%-2),1)=R%
 296       REM update previous reference to current
 297       ZZ%(ZL%-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       ZL%=ZL%+1:ZZ%(ZL%)=R%
 314
 315       AR%=R%:GOSUB APPLY
 316
 317       REM pop apply args are release them
 318       AY%=ZZ%(ZL%):ZL%=ZL%-1:GOSUB RELEASE
 319
 320       REM set the result value
 321       Z%(ZZ%(ZL%-2)+1,1)=R%
 322
 323       REM restore F%
 324       F%=ZZ%(ZL%-1)
 325
 326       REM update AB% to next source element
 327       ZZ%(ZL%)=Z%(ZZ%(ZL%),1)
 328       AB%=ZZ%(ZL%)
 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%=ZZ%(ZL%-3)
 338       REM pop everything off stack
 339       ZL%=ZL%-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     ZL%=ZL%+1:ZZ%(ZL%)=AR%
 374
 375     REM push atom
 376     ZL%=ZL%+1:ZZ%(ZL%)=AA%
 377
 378     GOSUB APPLY
 379
 380     REM pop atom
 381     AA%=ZZ%(ZL%):ZL%=ZL%-1
 382
 383     REM pop and release args
 384     AY%=ZZ%(ZL%):ZL%=ZL%-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