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 \ }}}
  86
  87 \ ---- Pre-defined symbols ---- {{{
  88
  89 objvar symbol-table
  90
  91 : (create-symbol) ( addr n -- symbol-obj )
  92     dup 0= if
  93         2drop nil
  94     else
  95         2dup drop @ character-type 2swap
  96         swap 1+ swap 1-
  97         recurse
  98
  99         cons
 100     then
 101 ;
 102
 103 : create-symbol ( -- )
 104     bl word
 105     count
 106
 107     (create-symbol)
 108     drop symbol-type
 109
 110     2dup
 111
 112     symbol-table fetchobj
 113     cons
 114     symbol-table setobj
 115
 116     create swap , ,
 117     does> dup @ swap 1+ @
 118 ;
 119
 120 create-symbol quote     quote-symbol
 121 create-symbol define    define-symbol
 122 create-symbol set!      set!-symbol
 123 create-symbol ok        ok-symbol
 124
 125 \ }}}
 126
 127 \ ---- Environments ---- {{{
 128
 129 : enclosing-env ( env -- env )
 130     cdr ;
 131
 132 : first-frame ( env -- frame )
 133     car ;
 134
 135 : make-frame ( vars vals -- frame )
 136     cons ;
 137
 138 : frame-vars ( frame -- vars )
 139     car ;
 140
 141 : frame-vals ( frame -- vals )
 142     cdr ;
 143
 144 : add-binding ( var val frame -- )
 145     2swap 2over frame-vals cons
 146     2over set-cdr!
 147     2swap 2over frame-vars cons
 148     2swap set-car!
 149 ;
 150
 151 : extend-env ( vars vals env -- env )
 152     >R >R
 153     make-frame
 154     R> R>
 155     cons
 156 ;
 157
 158 objvar vars
 159 objvar vals
 160
 161 : get-vars-vals-frame ( var frame -- bool )
 162     2dup frame-vars vars setobj
 163     frame-vals vals setobj
 164
 165     begin
 166         vars fetchobj nil objeq? false =
 167     while
 168         2dup vars fetchobj car objeq? if
 169             2drop true
 170             exit
 171         then
 172
 173         vars fetchobj cdr vars setobj
 174         vals fetchobj cdr vals setobj
 175     repeat
 176
 177     2drop false
 178 ;
 179
 180 : get-vars-vals ( var env -- vars? vals? bool )
 181
 182     begin
 183         2dup nil objeq? false =
 184     while
 185         2over 2over first-frame
 186         get-vars-vals-frame if
 187             2drop 2drop
 188             vars fetchobj vals fetchobj true
 189             exit
 190         then
 191
 192         enclosing-env
 193     repeat
 194
 195     2drop 2drop
 196     false
 197 ;
 198
 199 hide vars
 200 hide vals
 201
 202 : lookup-var ( var env -- val )
 203     get-vars-vals if
 204         2swap 2drop car
 205     else
 206         bold fg red ." Tried to read unbound variable." reset-term cr abort
 207     then
 208 ;
 209
 210 : set-var ( var val env -- )
 211     >R >R 2swap R> R> ( val var env )
 212     get-vars-vals if
 213         2swap 2drop ( val vals )
 214         set-car!
 215     else
 216         bold fg red ." Tried to set unbound variable." reset-term cr abort
 217     then
 218 ;
 219
 220 objvar env
 221
 222 : define-var ( var val env -- )
 223     env setobj
 224
 225     2over env fetchobj ( var val var env )
 226     get-vars-vals if
 227         2swap 2drop ( var val vals )
 228         set-car!
 229         2drop
 230     else
 231         env fetchobj
 232         first-frame ( var val frame )
 233         add-binding
 234     then
 235 ;
 236
 237 hide env
 238
 239 objvar global-env
 240 nil nil nil extend-env
 241 global-env setobj
 242
 243 \ }}}
 244
 245 \ ---- Read ---- {{{
 246
 247 variable parse-idx
 248 variable stored-parse-idx
 249 create parse-str 161 allot
 250 variable parse-str-span
 251
 252 create parse-idx-stack 10 allot
 253 variable parse-idx-sp
 254 parse-idx-stack parse-idx-sp !
 255
 256 : push-parse-idx
 257     parse-idx @ parse-idx-sp @ !
 258     1 parse-idx-sp +!
 259 ;
 260
 261 : pop-parse-idx
 262     parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
 263
 264     1 parse-idx-sp -!
 265
 266     parse-idx-sp @ @ parse-idx ! ;
 267
 268
 269 : append-newline
 270     '\n' parse-str parse-str-span @ + !
 271     1 parse-str-span +! ;
 272
 273 : empty-parse-str
 274     0 parse-str-span !
 275     0 parse-idx ! ;
 276
 277 : getline
 278     parse-str 160 expect cr
 279     span @ parse-str-span !
 280     append-newline
 281     0 parse-idx ! ;
 282
 283 : inc-parse-idx
 284     1 parse-idx +! ;
 285
 286 : dec-parse-idx
 287     1 parse-idx -! ;
 288
 289 : charavailable? ( -- bool )
 290     parse-str-span @ parse-idx @ > ;
 291
 292 : nextchar ( -- char )
 293     charavailable? false = if getline then
 294     parse-str parse-idx @ + @ ;
 295
 296 : whitespace? ( -- bool )
 297     nextchar BL =
 298     nextchar '\n' = or ;
 299
 300 : eof? ( -- bool )
 301     nextchar 4 = ;
 302
 303 : delim? ( -- bool )
 304     whitespace?
 305     nextchar [char] ( = or
 306     nextchar [char] ) = or
 307 ;
 308
 309 : eatspaces
 310     begin
 311         whitespace?
 312     while
 313         inc-parse-idx
 314     repeat
 315 ;
 316
 317 : digit? ( -- bool )
 318     nextchar [char] 0 >=
 319     nextchar [char] 9 <=
 320     and ;
 321
 322 : minus? ( -- bool )
 323     nextchar [char] - = ;
 324
 325 : number? ( -- bool )
 326     digit? minus? or false = if
 327         false
 328         exit
 329     then
 330
 331     push-parse-idx
 332     inc-parse-idx
 333
 334     begin digit? while
 335         inc-parse-idx
 336     repeat
 337
 338     delim? if
 339         pop-parse-idx
 340         true
 341     else
 342         pop-parse-idx
 343         false
 344     then
 345 ;
 346
 347 : boolean? ( -- bool )
 348     nextchar [char] # <> if false exit then
 349
 350     push-parse-idx
 351     inc-parse-idx
 352
 353     nextchar [char] t <>
 354     nextchar [char] f <>
 355     and if pop-parse-idx false exit then
 356
 357     inc-parse-idx
 358     delim? if
 359         pop-parse-idx
 360         true
 361     else
 362         pop-parse-idx
 363         false
 364     then
 365 ;
 366
 367 : str-equiv? ( str -- bool )
 368
 369     push-parse-idx
 370
 371     true -rot
 372
 373     swap dup rot + swap
 374
 375     do
 376         i @ nextchar <> if
 377             drop false
 378             leave
 379         then
 380
 381         inc-parse-idx
 382     loop
 383
 384     delim? false = if drop false then
 385
 386     pop-parse-idx
 387 ;
 388
 389 : character? ( -- bool )
 390     nextchar [char] # <> if false exit then
 391
 392     push-parse-idx
 393     inc-parse-idx
 394
 395     nextchar [char] \ <> if pop-parse-idx false exit then
 396
 397     inc-parse-idx
 398
 399     S" newline" str-equiv? if pop-parse-idx true exit then
 400     S" space" str-equiv? if pop-parse-idx true exit then
 401     S" tab" str-equiv? if pop-parse-idx true exit then
 402
 403     charavailable? false = if pop-parse-idx false exit then
 404
 405     pop-parse-idx true
 406 ;
 407
 408 : pair? ( -- bool )
 409     nextchar [char] ( = ;
 410
 411 : string? ( -- bool )
 412     nextchar [char] " = ;
 413
 414 : readnum ( -- num-atom )
 415     minus? dup if
 416         inc-parse-idx
 417     then
 418
 419     0
 420
 421     begin digit? while
 422         10 * nextchar [char] 0 - +
 423         inc-parse-idx
 424     repeat
 425
 426     swap if negate then
 427
 428     number-type
 429 ;
 430
 431 : readbool ( -- bool-atom )
 432     inc-parse-idx
 433
 434     nextchar [char] f = if
 435         false
 436     else
 437         true
 438     then
 439
 440     inc-parse-idx
 441
 442     boolean-type
 443 ;
 444
 445 : readchar ( -- char-atom )
 446     inc-parse-idx
 447     inc-parse-idx
 448
 449     S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
 450     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
 451     S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
 452
 453     nextchar character-type
 454
 455     inc-parse-idx
 456 ;
 457
 458 : readstring ( -- charlist )
 459     nextchar [char] " = if
 460         inc-parse-idx
 461
 462         delim? false = if
 463             bold fg red
 464             ." No delimiter following right double quote. Aborting." cr
 465             reset-term abort
 466         then
 467
 468         dec-parse-idx
 469
 470         0 nil-type exit
 471     then
 472
 473     nextchar [char] \ = if
 474         inc-parse-idx
 475         nextchar case
 476             [char] n of '\n' endof
 477             [char] " of [char] " endof
 478             [char] \
 479         endcase
 480     else
 481         nextchar
 482     then
 483     inc-parse-idx character-type
 484
 485     recurse
 486
 487     cons
 488 ;
 489
 490 : readsymbol ( -- charlist )
 491     delim? if nil exit then
 492
 493     nextchar inc-parse-idx character-type
 494
 495     recurse
 496
 497     cons
 498 ;
 499
 500 : charlist-equiv ( charlist charlist -- bool )
 501
 502     2over 2over
 503
 504     \ One or both nil
 505     nil? -rot 2drop
 506     if
 507         nil? -rot 2drop
 508         if
 509             2drop 2drop true exit
 510         else
 511             2drop 2drop false exit
 512         then
 513     else
 514         nil? -rot 2drop
 515         if
 516             2drop 2drop false exit
 517         then
 518     then
 519
 520     2over 2over
 521
 522     \ Neither nil
 523     car drop -rot car drop = if
 524             cdr 2swap cdr recurse
 525         else
 526             2drop 2drop false
 527     then
 528 ;
 529
 530 : charlist>symbol ( charlist -- symbol-obj )
 531
 532     symbol-table fetchobj
 533
 534     begin
 535         nil? false =
 536     while
 537         2over 2over
 538         car drop pair-type
 539         charlist-equiv if
 540             2swap 2drop
 541             car
 542             exit
 543         else
 544             cdr
 545         then
 546     repeat
 547
 548     2drop
 549     drop symbol-type 2dup
 550     symbol-table fetchobj cons
 551     symbol-table setobj
 552 ;
 553
 554 defer read
 555
 556 : readpair ( -- pairobj )
 557     eatspaces
 558
 559     \ Empty lists
 560     nextchar [char] ) = if
 561         inc-parse-idx
 562
 563         delim? false = if
 564             bold fg red
 565             ." No delimiter following right paren. Aborting." cr
 566             reset-term abort
 567         then
 568
 569         dec-parse-idx
 570
 571         0 nil-type exit
 572     then
 573
 574     \ Read first pair element
 575     read
 576
 577     \ Pairs
 578     eatspaces
 579     nextchar [char] . = if
 580         inc-parse-idx
 581
 582         delim? false = if
 583             bold fg red
 584             ." No delimiter following '.'. Aborting." cr
 585             reset-term abort
 586         then
 587
 588         eatspaces read
 589     else
 590         recurse
 591     then
 592
 593     eatspaces
 594
 595     cons
 596 ;
 597
 598 \ Parse a scheme expression
 599 :noname ( -- obj )
 600
 601     eatspaces
 602
 603     number? if
 604         readnum
 605         exit
 606     then
 607
 608     boolean? if
 609         readbool
 610         exit
 611     then
 612
 613     character? if
 614         readchar
 615         exit
 616     then
 617
 618     string? if
 619         inc-parse-idx
 620
 621         readstring
 622         drop string-type
 623
 624         nextchar [char] " <> if
 625             bold red ." Missing closing double-quote." reset-term cr
 626             abort
 627         then
 628
 629         inc-parse-idx
 630
 631         exit
 632     then
 633
 634     pair? if
 635         inc-parse-idx
 636
 637         eatspaces
 638
 639         readpair
 640
 641         eatspaces
 642
 643         nextchar [char] ) <> if
 644             bold red ." Missing closing paren." reset-term cr
 645             abort
 646         then
 647
 648         inc-parse-idx
 649
 650         exit
 651     then
 652
 653     nextchar [char] ' = if
 654         inc-parse-idx
 655         quote-symbol recurse nil cons cons exit
 656     then
 657
 658     eof? if
 659         bold fg blue ." Moriturus te saluto." reset-term ."  ok" cr
 660         quit
 661     then
 662
 663     \ Anything else is parsed as a symbol
 664     readsymbol charlist>symbol
 665
 666 ; is read
 667
 668 \ }}}
 669
 670 \ ---- Eval ---- {{{
 671
 672 : self-evaluating? ( obj -- obj bool )
 673     boolean-type istype? if true exit then
 674     number-type istype? if true exit then
 675     character-type istype? if true exit then
 676     string-type istype? if true exit then
 677     nil-type istype? if true exit then
 678
 679     false
 680 ;
 681
 682 : tagged-list? ( obj tag-obj -- obj bool )
 683     2over
 684     pair-type istype? false = if
 685         2drop 2drop false
 686     else
 687         car objeq?
 688     then ;
 689
 690 : quote? ( obj -- obj bool )
 691     quote-symbol tagged-list?  ;
 692
 693 : quote-body ( quote-obj -- quote-body-obj )
 694     cadr ;
 695
 696 : variable? ( obj -- obj bool )
 697     symbol-type istype? ;
 698
 699 : definition? ( obj -- obj bool )
 700     define-symbol tagged-list? ;
 701
 702 : definition-var ( obj -- var )
 703     cdr car ;
 704
 705 : definition-val ( obj -- val )
 706     cdr cdr car ;
 707
 708 : assignment? ( obj -- obj bool )
 709     set!-symbol tagged-list? ;
 710
 711 : assignment-var ( obj -- var )
 712     cdr car ;
 713
 714 : assignment-val ( obj -- val )
 715     cdr cdr car ;
 716
 717 defer eval
 718
 719 : eval-definition ( obj env -- res )
 720     2swap
 721     2over 2over ( env obj env obj )
 722     definition-val 2swap ( env obj valexp env )
 723     eval  ( env obj val )
 724
 725     2swap definition-var 2swap ( env var val )
 726
 727     >R >R 2swap R> R> 2swap ( var val env )
 728     define-var
 729
 730     ok-symbol
 731 ;
 732
 733 : eval-assignment ( obj env -- res )
 734     2swap
 735     2over 2over ( env obj env obj )
 736     assignment-val 2swap ( env obj valexp env )
 737     eval  ( env obj val )
 738
 739     2swap assignment-var 2swap ( env var val )
 740
 741     >R >R 2swap R> R> 2swap ( var val env )
 742     set-var
 743
 744     ok-symbol
 745 ;
 746
 747 :noname ( obj env -- result )
 748     2swap
 749
 750     self-evaluating? if
 751         2swap 2drop
 752         exit
 753     then
 754
 755     quote? if
 756         quote-body
 757         2swap 2drop
 758         exit
 759     then
 760
 761     variable? if
 762         2swap lookup-var
 763         exit
 764     then
 765
 766     definition? if
 767         2swap eval-definition
 768         exit
 769     then
 770
 771     assignment? if
 772         2swap eval-assignment
 773         exit
 774     then
 775
 776     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
 777     abort
 778 ; is eval
 779
 780 \ }}}
 781
 782 \ ---- Print ---- {{{
 783
 784 : printnum ( numobj -- ) drop 0 .R ;
 785
 786 : printbool ( numobj -- )
 787     drop if
 788         ." #t"
 789     else
 790         ." #f"
 791     then
 792 ;
 793
 794 : printchar ( charobj -- )
 795     drop
 796     case
 797         9 of ." #\tab" endof
 798         bl of ." #\space" endof
 799         '\n' of ." #\newline" endof
 800
 801         dup ." #\" emit
 802     endcase
 803 ;
 804
 805 : (printstring) ( stringobj -- )
 806     nil-type istype? if 2drop exit then
 807
 808     2dup car drop dup
 809     case
 810         '\n' of ." \n" drop endof
 811         [char] \ of ." \\" drop endof
 812         [char] " of [char] \ emit [char] " emit drop endof
 813         emit
 814     endcase
 815
 816     cdr recurse
 817 ;
 818 : printstring ( stringobj -- )
 819     [char] " emit
 820     (printstring)
 821     [char] " emit ;
 822
 823 : printsymbol ( symbolobj -- )
 824     nil-type istype? if 2drop exit then
 825
 826     2dup car drop emit
 827     cdr recurse
 828 ;
 829
 830 : printnil ( nilobj -- )
 831     2drop ." ()" ;
 832
 833 defer print
 834 : printpair ( pairobj -- )
 835     2dup
 836     car print
 837     cdr
 838     nil-type istype? if 2drop exit then
 839     pair-type istype? if space recurse exit then
 840     ."  . " print
 841 ;
 842
 843 :noname ( obj -- )
 844     number-type istype? if printnum exit then
 845     boolean-type istype? if printbool exit then
 846     character-type istype? if printchar exit then
 847     string-type istype? if printstring exit then
 848     symbol-type istype? if printsymbol exit then
 849     nil-type istype? if printnil exit then
 850     pair-type istype? if ." (" printpair ." )" exit then
 851
 852     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
 853     abort
 854 ; is print
 855
 856 \ }}}
 857
 858 \ ---- REPL ----
 859
 860 : repl
 861     cr ." Welcome to scheme.forth.jl!" cr
 862        ." Use Ctrl-D to exit." cr
 863
 864     empty-parse-str
 865
 866     begin
 867         cr bold fg green ." > " reset-term
 868         read
 869         global-env fetchobj eval
 870         fg cyan ." ; " print reset-term
 871     again
 872 ;
 873
 874 forth definitions
 875
 876 \ vim:fdm=marker