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