scheme.4th

   1 vocabulary scheme
   2 scheme definitions
   3
   4 include term-colours.4th
   5 include defer-is.4th
   6
   7 \ ------ Types ------
   8
   9 0 constant number-type
  10 1 constant boolean-type
  11 2 constant character-type
  12 3 constant string-type
  13 4 constant nil-type
  14 5 constant pair-type
  15 6 constant symbol-type
  16 : istype? ( obj -- obj b )
  17     over = ;
  18
  19 \ ------ Memory ------
  20
  21 100 constant N
  22 create car-cells N allot
  23 create car-type-cells N allot
  24 create cdr-cells N allot
  25 create cdr-type-cells N allot
  26
  27 variable nextfree
  28 0 nextfree !
  29
  30 : cons ( car-obj cdr-obj -- pair-obj )
  31     cdr-type-cells nextfree @ + !
  32     cdr-cells nextfree @ + !
  33     car-type-cells nextfree @ + !
  34     car-cells nextfree @ + !
  35
  36     nextfree @ pair-type
  37
  38     1 nextfree +!
  39 ;
  40
  41 : car ( pair-obj -- car-obj )
  42     drop
  43     dup car-cells + @ swap
  44     car-type-cells + @
  45 ;
  46
  47 : cdr ( pair-obj -- car-obj )
  48     drop
  49     dup cdr-cells + @ swap
  50     cdr-type-cells + @
  51 ;
  52
  53 : nil 0 nil-type ;
  54
  55 : objvar create 0 , 0 , ;
  56
  57 : value@ ( objvar -- val ) @ ;
  58 : type@ ( objvar -- type ) 1+ @ ;
  59 : value! ( newval objvar -- ) ! ;
  60 : type! ( newtype objvar -- ) 1+ ! ;
  61 : setobj ( newobj objvar -- ) dup rot swap 1+ ! ! ;
  62 : fetchobj ( objvar -- obj ) dup @ swap 1+ @ ;
  63
  64 objvar symbol-table
  65 nil symbol-table setobj
  66
  67 \ ---- Read ----
  68
  69 variable parse-idx
  70 variable stored-parse-idx
  71 create parse-str 161 allot
  72 variable parse-str-span
  73
  74 create parse-idx-stack 10 allot
  75 variable parse-idx-sp
  76 parse-idx-stack parse-idx-sp !
  77
  78 : push-parse-idx
  79     parse-idx @ parse-idx-sp @ !
  80     1 parse-idx-sp +!
  81 ;
  82
  83 : pop-parse-idx
  84     parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
  85
  86     1 parse-idx-sp -!
  87
  88     parse-idx-sp @ @ parse-idx ! ;
  89
  90
  91 : append-newline
  92     '\n' parse-str parse-str-span @ + !
  93     1 parse-str-span +! ;
  94
  95 : empty-parse-str
  96     0 parse-str-span !
  97     0 parse-idx ! ;
  98
  99 : getline
 100     parse-str 160 expect cr
 101     span @ parse-str-span !
 102     append-newline
 103     0 parse-idx ! ;
 104
 105 : inc-parse-idx
 106     1 parse-idx +! ;
 107
 108 : dec-parse-idx
 109     1 parse-idx -! ;
 110
 111 : charavailable? ( -- bool )
 112     parse-str-span @ parse-idx @ > ;
 113
 114 : nextchar ( -- char )
 115     charavailable? false = if getline then
 116     parse-str parse-idx @ + @ ;
 117
 118 : whitespace? ( -- bool )
 119     nextchar BL =
 120     nextchar '\n' = or ;
 121
 122 : eof? ( -- bool )
 123     nextchar 4 = ;
 124
 125 : delim? ( -- bool )
 126     whitespace?
 127     nextchar [char] ( = or
 128     nextchar [char] ) = or
 129 ;
 130
 131 : eatspaces
 132     begin
 133         whitespace?
 134     while
 135         inc-parse-idx
 136     repeat
 137 ;
 138
 139 : digit? ( -- bool )
 140     nextchar [char] 0 >=
 141     nextchar [char] 9 <=
 142     and ;
 143
 144 : minus? ( -- bool )
 145     nextchar [char] - = ;
 146
 147 : number? ( -- bool )
 148     digit? minus? or false = if
 149         false
 150         exit
 151     then
 152
 153     push-parse-idx
 154     inc-parse-idx
 155
 156     begin digit? while
 157         inc-parse-idx
 158     repeat
 159
 160     delim? if
 161         pop-parse-idx
 162         true
 163     else
 164         pop-parse-idx
 165         false
 166     then
 167 ;
 168
 169 : boolean? ( -- bool )
 170     nextchar [char] # <> if false exit then
 171
 172     push-parse-idx
 173     inc-parse-idx
 174
 175     nextchar [char] t <>
 176     nextchar [char] f <>
 177     and if pop-parse-idx false exit then
 178
 179     inc-parse-idx
 180     delim? if
 181         pop-parse-idx
 182         true
 183     else
 184         pop-parse-idx
 185         false
 186     then
 187 ;
 188
 189 : str-equiv? ( str -- bool )
 190
 191     push-parse-idx
 192
 193     true -rot
 194
 195     swap dup rot + swap
 196
 197     do
 198         i @ nextchar <> if
 199             drop false
 200             leave
 201         then
 202
 203         inc-parse-idx
 204     loop
 205
 206     delim? false = if drop false then
 207
 208     pop-parse-idx
 209 ;
 210
 211 : character? ( -- bool )
 212     nextchar [char] # <> if false exit then
 213
 214     push-parse-idx
 215     inc-parse-idx
 216
 217     nextchar [char] \ <> if pop-parse-idx false exit then
 218
 219     inc-parse-idx
 220
 221     S" newline" str-equiv? if pop-parse-idx true exit then
 222     S" space" str-equiv? if pop-parse-idx true exit then
 223     S" tab" str-equiv? if pop-parse-idx true exit then
 224
 225     charavailable? false = if pop-parse-idx false exit then
 226
 227     pop-parse-idx true
 228 ;
 229
 230 : pair? ( -- bool )
 231     nextchar [char] ( = ;
 232
 233 : string? ( -- bool )
 234     nextchar [char] " = ;
 235
 236 : initial? ( -- bool )
 237     nextchar [char] A >= nextchar [char] Z <= and if true exit then
 238     nextchar [char] a >= nextchar [char] z <= and if true exit then
 239     nextchar [char] * = if true exit then
 240     nextchar [char] / = if true exit then
 241     nextchar [char] > = if true exit then
 242     nextchar [char] < = if true exit then
 243     nextchar [char] = = if true exit then
 244     nextchar [char] ? = if true exit then
 245     nextchar [char] ! = if true exit then
 246     false
 247 ;
 248
 249 : symbol? ( -- bool )
 250     initial? if true exit then
 251     nextchar [char] + =
 252     nextchar [char] - = or if
 253         inc-parse-idx
 254         delim? if dec-parse-idx true exit then
 255         dec-parse-idx
 256     then
 257     false
 258 ;
 259
 260 : readnum ( -- num-atom )
 261     minus? dup if
 262         inc-parse-idx
 263     then
 264
 265     0
 266
 267     begin digit? while
 268         10 * nextchar [char] 0 - +
 269         inc-parse-idx
 270     repeat
 271
 272     swap if negate then
 273
 274     number-type
 275 ;
 276
 277 : readbool ( -- bool-atom )
 278     inc-parse-idx
 279
 280     nextchar [char] f = if
 281         false
 282     else
 283         true
 284     then
 285
 286     inc-parse-idx
 287
 288     boolean-type
 289 ;
 290
 291 : readchar ( -- char-atom )
 292     inc-parse-idx
 293     inc-parse-idx
 294
 295     S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
 296     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
 297     S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
 298
 299     nextchar character-type
 300
 301     inc-parse-idx
 302 ;
 303
 304 : readstring ( -- charlist )
 305     nextchar [char] " = if
 306         inc-parse-idx
 307
 308         delim? false = if
 309             bold fg red
 310             ." No delimiter following right double quote. Aborting." cr
 311             reset-term abort
 312         then
 313
 314         dec-parse-idx
 315
 316         0 nil-type exit
 317     then
 318
 319     nextchar [char] \ = if
 320         inc-parse-idx
 321         nextchar case
 322             [char] n of '\n' endof
 323             [char] " of [char] " endof
 324             [char] \
 325         endcase
 326     else
 327         nextchar
 328     then
 329     inc-parse-idx character-type
 330
 331     recurse
 332
 333     cons
 334 ;
 335
 336 : readsymbol ( -- charlist )
 337     delim? if nil exit then
 338
 339     nextchar inc-parse-idx character-type
 340
 341     recurse
 342
 343     cons
 344 ;
 345
 346 defer read
 347
 348 : readpair ( -- obj )
 349     eatspaces
 350
 351     \ Empty lists
 352     nextchar [char] ) = if
 353         inc-parse-idx
 354
 355         delim? false = if
 356             bold fg red
 357             ." No delimiter following right paren. Aborting." cr
 358             reset-term abort
 359         then
 360
 361         dec-parse-idx
 362
 363         0 nil-type exit
 364     then
 365
 366     \ Read first pair element
 367     read
 368
 369     \ Pairs
 370     eatspaces
 371     nextchar [char] . = if
 372         inc-parse-idx
 373
 374         delim? false = if
 375             bold fg red
 376             ." No delimiter following '.'. Aborting." cr
 377             reset-term abort
 378         then
 379
 380         eatspaces read
 381     else
 382         recurse
 383     then
 384
 385     eatspaces
 386
 387     cons
 388 ;
 389
 390 \ Parse a scheme expression
 391 :noname ( -- obj )
 392
 393     eatspaces
 394
 395     number? if
 396         readnum
 397         exit
 398     then
 399
 400     boolean? if
 401         readbool
 402         exit
 403     then
 404
 405     character? if
 406         readchar
 407         exit
 408     then
 409
 410     string? if
 411         inc-parse-idx
 412         readstring
 413         drop string-type
 414
 415         nextchar [char] " <> if
 416             bold red ." Missing closing double-quote." reset-term cr
 417             abort
 418         then
 419
 420         inc-parse-idx
 421         exit
 422     then
 423
 424     symbol? if
 425         readsymbol
 426         drop symbol-type
 427         2dup
 428         symbol-table fetch
 429         cons
 430         symbol-table set
 431         exit
 432     then
 433
 434     pair? if
 435         inc-parse-idx
 436
 437         eatspaces
 438
 439         readpair
 440
 441         eatspaces
 442
 443         nextchar [char] ) <> if
 444             bold red ." Missing closing paren." reset-term cr
 445             abort
 446         then
 447
 448         inc-parse-idx
 449
 450         exit
 451     then
 452
 453     eof? if
 454         bold fg blue ." Moriturus te saluto." reset-term ."  ok" cr
 455         quit
 456     then
 457
 458     bold fg red ." Error parsing string starting at character '"
 459     nextchar emit
 460     ." '. Aborting." reset-term cr
 461     abort
 462
 463 ; is read
 464
 465 \ ---- Eval ----
 466
 467 : self-evaluating? ( obj -- obj bool )
 468     true \ everything self-evaluating for now
 469 ;
 470
 471 : eval
 472     self-evaluating? if
 473         exit
 474     then
 475
 476     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
 477     abort
 478 ;
 479
 480 \ ---- Print ----
 481
 482 : printnum ( numobj -- ) drop 0 .R ;
 483
 484 : printbool ( numobj -- )
 485     drop if
 486         ." #t"
 487     else
 488         ." #f"
 489     then
 490 ;
 491
 492 : printchar ( charobj -- )
 493     drop
 494     case
 495         9 of ." #\tab" endof
 496         bl of ." #\space" endof
 497         '\n' of ." #\newline" endof
 498
 499         dup ." #\" emit
 500     endcase
 501 ;
 502
 503 : (printstring) ( stringobj -- )
 504     nil-type istype? if 2drop exit then
 505
 506     2dup car drop dup
 507     case
 508         '\n' of ." \n" drop endof
 509         [char] \ of ." \\" drop endof
 510         [char] " of [char] \ emit [char] " emit drop endof
 511         emit
 512     endcase
 513
 514     cdr recurse
 515 ;
 516 : printstring ( stringobj -- )
 517     [char] " emit
 518     (printstring)
 519     [char] " emit ;
 520
 521 : printsymbol ( symbolobj -- )
 522     nil-type istype? if 2drop exit then
 523
 524     2dup car drop emit
 525     cdr recurse
 526 ;
 527
 528 : printnil ( nilobj -- )
 529     2drop ." ()" ;
 530
 531 defer print
 532 : printpair ( pairobj -- )
 533     2dup
 534     car print
 535     cdr
 536     nil-type istype? if 2drop exit then
 537     pair-type istype? if space recurse exit then
 538     ."  . " print
 539 ;
 540
 541 :noname ( obj -- )
 542     number-type istype? if printnum exit then
 543     boolean-type istype? if printbool exit then
 544     character-type istype? if printchar exit then
 545     string-type istype? if printstring exit then
 546     symbol-type istype? if printsymbol exit then
 547     nil-type istype? if printnil exit then
 548     pair-type istype? if ." (" printpair ." )" exit then
 549
 550     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
 551     abort
 552 ; is print
 553
 554 \ ---- REPL ----
 555
 556 : repl
 557     cr ." Welcome to scheme.forth.jl!" cr
 558        ." Use Ctrl-D to exit." cr
 559
 560     empty-parse-str
 561
 562     begin
 563         cr bold fg green ." > " reset-term
 564         read
 565         eval
 566         fg cyan ." ; " print reset-term
 567     again
 568 ;
 569
 570 forth definitions