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