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             true exit
 357         else
 358             false exit
 359         then
 360     else
 361         nil? -rot 2drop
 362         if
 363             false exit
 364         then
 365     then
 366
 367     2over 2over
 368
 369     \ Neither nil
 370     car 2swap car rot = -rot = and if
 371             cdr 2swap cdr recurse
 372         else
 373             2drop 2drop false
 374     then
 375 ;
 376
 377 : (symbol-in-table?) ( charlist symbol-table -- charlist symbol-obj )
 378
 379     begin
 380         nil? false =
 381     while
 382         2over 2over
 383         car
 384         charlist-equiv if
 385     repeat
 386 ;
 387
 388 : symbol-in-table? ( charlist -- charlist bool )
 389     symbol-table (symbol-in-table?) ;
 390
 391 defer read
 392
 393 : readpair ( -- obj )
 394     eatspaces
 395
 396     \ Empty lists
 397     nextchar [char] ) = if
 398         inc-parse-idx
 399
 400         delim? false = if
 401             bold fg red
 402             ." No delimiter following right paren. Aborting." cr
 403             reset-term abort
 404         then
 405
 406         dec-parse-idx
 407
 408         0 nil-type exit
 409     then
 410
 411     \ Read first pair element
 412     read
 413
 414     \ Pairs
 415     eatspaces
 416     nextchar [char] . = if
 417         inc-parse-idx
 418
 419         delim? false = if
 420             bold fg red
 421             ." No delimiter following '.'. Aborting." cr
 422             reset-term abort
 423         then
 424
 425         eatspaces read
 426     else
 427         recurse
 428     then
 429
 430     eatspaces
 431
 432     cons
 433 ;
 434
 435 \ Parse a scheme expression
 436 :noname ( -- obj )
 437
 438     eatspaces
 439
 440     number? if
 441         readnum
 442         exit
 443     then
 444
 445     boolean? if
 446         readbool
 447         exit
 448     then
 449
 450     character? if
 451         readchar
 452         exit
 453     then
 454
 455     string? if
 456         inc-parse-idx
 457         readstring
 458         drop string-type
 459
 460         nextchar [char] " <> if
 461             bold red ." Missing closing double-quote." reset-term cr
 462             abort
 463         then
 464
 465         inc-parse-idx
 466         exit
 467     then
 468
 469     symbol? if
 470         readsymbol
 471         drop symbol-type
 472         2dup
 473         symbol-table fetch
 474         cons
 475         symbol-table set
 476         exit
 477     then
 478
 479     pair? if
 480         inc-parse-idx
 481
 482         eatspaces
 483
 484         readpair
 485
 486         eatspaces
 487
 488         nextchar [char] ) <> if
 489             bold red ." Missing closing paren." reset-term cr
 490             abort
 491         then
 492
 493         inc-parse-idx
 494
 495         exit
 496     then
 497
 498     eof? if
 499         bold fg blue ." Moriturus te saluto." reset-term ."  ok" cr
 500         quit
 501     then
 502
 503     bold fg red ." Error parsing string starting at character '"
 504     nextchar emit
 505     ." '. Aborting." reset-term cr
 506     abort
 507
 508 ; is read
 509
 510 \ ---- Eval ----
 511
 512 : self-evaluating? ( obj -- obj bool )
 513     true \ everything self-evaluating for now
 514 ;
 515
 516 : eval
 517     self-evaluating? if
 518         exit
 519     then
 520
 521     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
 522     abort
 523 ;
 524
 525 \ ---- Print ----
 526
 527 : printnum ( numobj -- ) drop 0 .R ;
 528
 529 : printbool ( numobj -- )
 530     drop if
 531         ." #t"
 532     else
 533         ." #f"
 534     then
 535 ;
 536
 537 : printchar ( charobj -- )
 538     drop
 539     case
 540         9 of ." #\tab" endof
 541         bl of ." #\space" endof
 542         '\n' of ." #\newline" endof
 543
 544         dup ." #\" emit
 545     endcase
 546 ;
 547
 548 : (printstring) ( stringobj -- )
 549     nil-type istype? if 2drop exit then
 550
 551     2dup car drop dup
 552     case
 553         '\n' of ." \n" drop endof
 554         [char] \ of ." \\" drop endof
 555         [char] " of [char] \ emit [char] " emit drop endof
 556         emit
 557     endcase
 558
 559     cdr recurse
 560 ;
 561 : printstring ( stringobj -- )
 562     [char] " emit
 563     (printstring)
 564     [char] " emit ;
 565
 566 : printsymbol ( symbolobj -- )
 567     nil-type istype? if 2drop exit then
 568
 569     2dup car drop emit
 570     cdr recurse
 571 ;
 572
 573 : printnil ( nilobj -- )
 574     2drop ." ()" ;
 575
 576 defer print
 577 : printpair ( pairobj -- )
 578     2dup
 579     car print
 580     cdr
 581     nil-type istype? if 2drop exit then
 582     pair-type istype? if space recurse exit then
 583     ."  . " print
 584 ;
 585
 586 :noname ( obj -- )
 587     number-type istype? if printnum exit then
 588     boolean-type istype? if printbool exit then
 589     character-type istype? if printchar exit then
 590     string-type istype? if printstring exit then
 591     symbol-type istype? if printsymbol exit then
 592     nil-type istype? if printnil exit then
 593     pair-type istype? if ." (" printpair ." )" exit then
 594
 595     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
 596     abort
 597 ; is print
 598
 599 \ ---- REPL ----
 600
 601 : repl
 602     cr ." Welcome to scheme.forth.jl!" cr
 603        ." Use Ctrl-D to exit." cr
 604
 605     empty-parse-str
 606
 607     begin
 608         cr bold fg green ." > " reset-term
 609         read
 610         eval
 611         fg cyan ." ; " print reset-term
 612     again
 613 ;
 614
 615 forth definitions