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
  20   REM IF FF%=1 THEN DO_EQUAL_Q
  21
  22   DO_11:
  23   ON FF%-10 GOTO DO_PR_STR,DO_STR,DO_PRN,DO_PRINTLN,DO_READLINE,DO_READ_STRING,DO_SLURP
  24   REM IF FF%=11 THEN DO_PR_STR
  25   REM IF FF%=12 THEN DO_STR
  26   REM IF FF%=13 THEN DO_PRN
  27   REM IF FF%=14 THEN DO_PRINTLN
  28   REM IF FF%=15 THEN DO_READLINE
  29   REM IF FF%=16 THEN DO_READ_STRING
  30   REM IF FF%=17 THEN DO_SLURP
  31
  32   DO_18:
  33   ON FF%-17 GOTO DO_LT,DO_LTE,DO_GT,DO_GTE,DO_ADD,DO_SUB,DO_MULT,DO_DIV,DO_TIME_MS
  34   REM IF FF%=18 THEN DO_LT
  35   REM IF FF%=19 THEN DO_LTE
  36   REM IF FF%=20 THEN DO_GT
  37   REM IF FF%=21 THEN DO_GTE
  38   REM IF FF%=22 THEN DO_ADD
  39   REM IF FF%=23 THEN DO_SUB
  40   REM IF FF%=24 THEN DO_MULT
  41   REM IF FF%=25 THEN DO_DIV
  42   REM IF FF%=26 THEN DO_TIME_MS
  43
  44   DO_27:
  45   ON FF%-26 GOTO DO_LIST,DO_LIST_Q
  46   REM IF FF%=27 THEN DO_LIST
  47   REM IF FF%=28 THEN DO_LIST_Q
  48
  49   DO_39:
  50   ON FF%-39 GOTO DO_CONS,DO_CONCAT,DO_NTH,DO_FIRST,DO_REST,DO_EMPTY_Q,DO_COUNT
  51   REM IF FF%=40 THEN DO_CONS
  52   REM IF FF%=41 THEN DO_CONCAT
  53   REM IF FF%=42 THEN DO_NTH
  54   REM IF FF%=43 THEN DO_FIRST
  55   REM IF FF%=44 THEN DO_REST
  56   REM IF FF%=45 THEN DO_EMPTY_Q
  57   REM IF FF%=46 THEN DO_COUNT
  58
  59   DO_53:
  60   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
  61   REM IF FF%=53 THEN DO_ATOM
  62   REM IF FF%=54 THEN DO_ATOM_Q
  63   REM IF FF%=55 THEN DO_DEREF
  64   REM IF FF%=56 THEN DO_RESET_BANG
  65   REM IF FF%=57 THEN DO_SWAP_BANG
  66
  67   REM IF FF%=58 THEN DO_PR_MEMORY
  68   REM IF FF%=59 THEN DO_PR_MEMORY_SUMMARY
  69   REM IF FF%=60 THEN DO_EVAL
  70
  71   DO_EQUAL_Q:
  72     A%=AA%:B%=AB%:GOSUB EQUAL_Q
  73     R%=R%+1
  74     RETURN
  75
  76   DO_PR_STR:
  77     AZ%=AR%:PR%=1:SE$=" ":GOSUB PR_STR_SEQ
  78     AS$=R$:T%=4+16:GOSUB STRING
  79     RETURN
  80   DO_STR:
  81     AZ%=AR%:PR%=0:SE$="":GOSUB PR_STR_SEQ
  82     AS$=R$:T%=4+16:GOSUB STRING
  83     RETURN
  84   DO_PRN:
  85     AZ%=AR%:PR%=1:SE$=" ":GOSUB PR_STR_SEQ
  86     PRINT R$
  87     R%=0
  88     RETURN
  89   DO_PRINTLN:
  90     AZ%=AR%:PR%=0:SE$=" ":GOSUB PR_STR_SEQ
  91     PRINT R$
  92     R%=0
  93     RETURN
  94   DO_READLINE:
  95     RETURN
  96   DO_READ_STRING:
  97     A$=ZS$(Z%(AA%,1))
  98     GOSUB READ_STR
  99     RETURN
 100   DO_SLURP:
 101     R$=""
 102     REM OPEN 1,8,2,ZS$(Z%(AA%,1))+",SEQ,R"
 103     REM OPEN 1,8,2,ZS$(Z%(AA%,1))
 104     OPEN 1,8,0,ZS$(Z%(AA%,1))
 105     DO_SLURP_LOOP:
 106       A$=""
 107       GET#1,A$
 108       IF ASC(A$)=10 THEN R$=R$+CHR$(13)
 109       IF (ASC(A$)<>10) AND (A$<>"") THEN R$=R$+A$
 110       IF (ST AND 64) THEN GOTO DO_SLURP_DONE
 111       IF (ST AND 255) THEN ER%=-1:ER%="File read error "+STR$(ST):RETURN
 112       GOTO DO_SLURP_LOOP
 113     DO_SLURP_DONE:
 114       CLOSE 1
 115       AS$=R$:T%=4+16:GOSUB STRING
 116       RETURN
 117
 118   DO_LT:
 119     R%=1
 120     IF Z%(AA%,1)<Z%(AB%,1) THEN R%=2
 121     RETURN
 122   DO_LTE:
 123     R%=1
 124     IF Z%(AA%,1)<=Z%(AB%,1) THEN R%=2
 125     RETURN
 126   DO_GT:
 127     R%=1
 128     IF Z%(AA%,1)>Z%(AB%,1) THEN R%=2
 129     RETURN
 130   DO_GTE:
 131     R%=1
 132     IF Z%(AA%,1)>=Z%(AB%,1) THEN R%=2
 133     RETURN
 134
 135   DO_ADD:
 136     SZ%=1:GOSUB ALLOC
 137     Z%(R%,0)=2+16
 138     Z%(R%,1)=Z%(AA%,1)+Z%(AB%,1)
 139     RETURN
 140   DO_SUB:
 141     SZ%=1:GOSUB ALLOC
 142     Z%(R%,0)=2+16
 143     Z%(R%,1)=Z%(AA%,1)-Z%(AB%,1)
 144     RETURN
 145   DO_MULT:
 146     SZ%=1:GOSUB ALLOC
 147     Z%(R%,0)=2+16
 148     Z%(R%,1)=Z%(AA%,1)*Z%(AB%,1)
 149     RETURN
 150   DO_DIV:
 151     SZ%=1:GOSUB ALLOC
 152     Z%(R%,0)=2+16
 153     Z%(R%,1)=Z%(AA%,1)/Z%(AB%,1)
 154     RETURN
 155   DO_TIME_MS:
 156     R%=0
 157     RETURN
 158
 159   DO_LIST:
 160     R%=AR%
 161     Z%(R%,0)=Z%(R%,0)+16
 162     RETURN
 163   DO_LIST_Q:
 164     A%=AA%:GOSUB LIST_Q
 165     R%=R%+1: REM map to mal false/true
 166     RETURN
 167
 168   DO_CONS:
 169     A%=AA%:B%=AB%:GOSUB CONS
 170     RETURN
 171   DO_CONCAT:
 172     REM if empty arguments, return empty list
 173     IF Z%(AR%,1)=0 THEN R%=3:Z%(R%,0)=Z%(R%,0)+16:RETURN
 174
 175     REM single argument
 176     IF Z%(Z%(AR%,1),1)<>0 THEN GOTO DO_CONCAT_MULT
 177       REM if single argument and it's a list, return it
 178       IF (Z%(AA%,0)AND15)=6 THEN R%=AA%:Z%(R%,0)=Z%(R%,0)+16:RETURN
 179       REM otherwise, copy first element to turn it into a list
 180       B%=AA%+1:GOSUB DEREF_B: REM value to copy
 181       SZ%=2:GOSUB ALLOC
 182       Z%(R%,0)=6+16:Z%(R%,1)=Z%(AA%,1)
 183       Z%(R%+1,0)=14:Z%(R%+1,1)=B%
 184       REM inc ref count of trailing list part and of copied value
 185       Z%(Z%(AA%,1),0)=Z%(Z%(AA%,1),0)+16
 186       Z%(B%,0)=Z%(B%,0)+16
 187       RETURN
 188
 189     REM multiple arguments
 190     DO_CONCAT_MULT:
 191       CZ%=ZL%: REM save current stack position
 192       REM push arguments onto the stack
 193       DO_CONCAT_STACK:
 194         R%=AR%+1:GOSUB DEREF_R
 195         ZL%=ZL%+1:ZZ%(ZL%)=R%: REM push sequence
 196         AR%=Z%(AR%,1)
 197         IF Z%(AR%,1)<>0 THEN GOTO DO_CONCAT_STACK
 198
 199     REM pop last argument as our seq to prepend to
 200     AB%=ZZ%(ZL%):ZL%=ZL%-1
 201     REM last arg/seq is not copied so we need to inc ref to it
 202     Z%(AB%,0)=Z%(AB%,0)+16
 203     DO_CONCAT_LOOP:
 204       IF ZL%=CZ% THEN R%=AB%:RETURN
 205       AA%=ZZ%(ZL%):ZL%=ZL%-1: REM pop off next seq to prepend
 206       IF Z%(AA%,1)=0 THEN GOTO DO_CONCAT_LOOP: REM skip empty seqs
 207       A%=AA%:B%=0:C%=-1:GOSUB SLICE
 208
 209       REM release the terminator of new list (we skip over it)
 210       AY%=Z%(R6%,1):GOSUB RELEASE
 211       REM attach new list element before terminator (last actual
 212       REM element to the next sequence
 213       Z%(R6%,1)=AB%
 214
 215       AB%=R%
 216       GOTO DO_CONCAT_LOOP
 217   DO_NTH:
 218     B%=Z%(AB%,1)
 219     A%=AA%:GOSUB COUNT
 220     IF R%<=B% THEN R%=0:ER%=1:ER$="nth: index out of range":RETURN
 221     DO_NTH_LOOP:
 222       IF B%=0 THEN GOTO DO_NTH_DONE
 223       B%=B%-1
 224       AA%=Z%(AA%,1)
 225       GOTO DO_NTH_LOOP
 226     DO_NTH_DONE:
 227       R%=Z%(AA%+1,1)
 228       Z%(R%,0)=Z%(R%,0)+16
 229       RETURN
 230   DO_FIRST:
 231     IF Z%(AA%,1)=0 THEN R%=0
 232     IF Z%(AA%,1)<>0 THEN R%=AA%+1:GOSUB DEREF_R
 233     IF R%<>0 THEN Z%(R%,0)=Z%(R%,0)+16
 234     RETURN
 235   DO_REST:
 236     IF Z%(AA%,1)=0 THEN R%=AA%
 237     IF Z%(AA%,1)<>0 THEN R%=Z%(AA%,1)
 238     Z%(R%,0)=Z%(R%,0)+16
 239     RETURN
 240   DO_EMPTY_Q:
 241     R%=1
 242     IF Z%(AA%,1)=0 THEN R%=2
 243     RETURN
 244   DO_COUNT:
 245     A%=AA%:GOSUB COUNT:R4%=R%
 246     SZ%=1:GOSUB ALLOC
 247     Z%(R%,0)=2+16
 248     Z%(R%,1)=R4%
 249     RETURN
 250
 251   DO_ATOM:
 252     SZ%=1:GOSUB ALLOC
 253     Z%(AA%,0)=Z%(AA%,0)+16: REM inc ref cnt of contained value
 254     Z%(R%,0)=12+16
 255     Z%(R%,1)=AA%
 256     RETURN
 257   DO_ATOM_Q:
 258     R%=1
 259     IF (Z%(AA%,0)AND15)=12 THEN R%=2
 260     RETURN
 261   DO_DEREF:
 262     R%=Z%(AA%,1):GOSUB DEREF_R
 263     Z%(R%,0)=Z%(R%,0)+16
 264     RETURN
 265   DO_RESET_BANG:
 266     R%=AB%
 267     REM release current value
 268     AY%=Z%(AA%,1):GOSUB RELEASE
 269     REM inc ref by 2 for atom ownership and since we are returning it
 270     Z%(R%,0)=Z%(R%,0)+32
 271     REM update value
 272     Z%(AA%,1)=R%
 273     RETURN
 274   DO_SWAP_BANG:
 275     F%=AB%
 276
 277     REM add atom to front of the args list
 278     A%=Z%(AA%,1):B%=Z%(Z%(AR%,1),1):GOSUB CONS
 279     AR%=R%
 280
 281     REM push args for release after
 282     ZL%=ZL%+1:ZZ%(ZL%)=AR%
 283
 284     REM push atom
 285     ZL%=ZL%+1:ZZ%(ZL%)=AA%
 286
 287     GOSUB APPLY
 288
 289     REM pop atom
 290     AA%=ZZ%(ZL%):ZL%=ZL%-1
 291
 292     REM pop and release args
 293     AY%=ZZ%(ZL%):ZL%=ZL%-1:GOSUB RELEASE
 294
 295     REM use reset to update the value
 296     AB%=R%:GOSUB DO_RESET_BANG
 297
 298     REM but decrease ref cnt of return by 1 (not sure why)
 299     AY%=R%:GOSUB RELEASE
 300
 301     RETURN
 302
 303   DO_PR_MEMORY:
 304     P1%=ZT%:P2%=-1:GOSUB PR_MEMORY
 305     RETURN
 306   DO_PR_MEMORY_SUMMARY:
 307     GOSUB PR_MEMORY_SUMMARY
 308     RETURN
 309
 310   DO_EVAL:
 311     A%=AA%:E%=RE%:GOSUB EVAL
 312     RETURN
 313
 314 INIT_CORE_SET_FUNCTION:
 315   GOSUB NATIVE_FUNCTION
 316   V%=R%:GOSUB ENV_SET_S
 317   RETURN
 318
 319 REM INIT_CORE_NS(E%)
 320 INIT_CORE_NS:
 321   REM create the environment mapping
 322   REM must match DO_FUNCTION mappings
 323
 324   K$="=":A%=1:GOSUB INIT_CORE_SET_FUNCTION
 325
 326   K$="pr-str":A%=11:GOSUB INIT_CORE_SET_FUNCTION
 327   K$="str":A%=12:GOSUB INIT_CORE_SET_FUNCTION
 328   K$="prn":A%=13:GOSUB INIT_CORE_SET_FUNCTION
 329   K$="println":A%=14:GOSUB INIT_CORE_SET_FUNCTION
 330   K$="readline":A%=15:GOSUB INIT_CORE_SET_FUNCTION
 331   K$="read-string":A%=16:GOSUB INIT_CORE_SET_FUNCTION
 332   K$="slurp":A%=17:GOSUB INIT_CORE_SET_FUNCTION
 333
 334   K$="<":A%=18:GOSUB INIT_CORE_SET_FUNCTION
 335   K$="<=":A%=19:GOSUB INIT_CORE_SET_FUNCTION
 336   K$=">":A%=20:GOSUB INIT_CORE_SET_FUNCTION
 337   K$=">=":A%=21:GOSUB INIT_CORE_SET_FUNCTION
 338   K$="+":A%=22:GOSUB INIT_CORE_SET_FUNCTION
 339   K$="-":A%=23:GOSUB INIT_CORE_SET_FUNCTION
 340   K$="*":A%=24:GOSUB INIT_CORE_SET_FUNCTION
 341   K$="/":A%=25:GOSUB INIT_CORE_SET_FUNCTION
 342   K$="time-ms":A%=26:GOSUB INIT_CORE_SET_FUNCTION
 343
 344   K$="list":A%=27:GOSUB INIT_CORE_SET_FUNCTION
 345   K$="list?":A%=28:GOSUB INIT_CORE_SET_FUNCTION
 346
 347   K$="cons":A%=40:GOSUB INIT_CORE_SET_FUNCTION
 348   K$="concat":A%=41:GOSUB INIT_CORE_SET_FUNCTION
 349   K$="nth":A%=42:GOSUB INIT_CORE_SET_FUNCTION
 350   K$="first":A%=43:GOSUB INIT_CORE_SET_FUNCTION
 351   K$="rest":A%=44:GOSUB INIT_CORE_SET_FUNCTION
 352   K$="empty?":A%=45:GOSUB INIT_CORE_SET_FUNCTION
 353   K$="count":A%=46:GOSUB INIT_CORE_SET_FUNCTION
 354
 355   K$="atom":A%=53:GOSUB INIT_CORE_SET_FUNCTION
 356   K$="atom?":A%=54:GOSUB INIT_CORE_SET_FUNCTION
 357   K$="deref":A%=55:GOSUB INIT_CORE_SET_FUNCTION
 358   K$="reset!":A%=56:GOSUB INIT_CORE_SET_FUNCTION
 359   K$="swap!":A%=57:GOSUB INIT_CORE_SET_FUNCTION
 360
 361   K$="pr-memory":A%=58:GOSUB INIT_CORE_SET_FUNCTION
 362   K$="pr-memory-summary":A%=59:GOSUB INIT_CORE_SET_FUNCTION
 363   K$="eval":A%=60:GOSUB INIT_CORE_SET_FUNCTION
 364
 365   RETURN