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 7 constant primitive-type
  17 : istype? ( obj type -- obj bool )
  18     over = ;
  19
  20 \ ------ Cons cell memory ------ {{{
  21
  22 1000 constant N
  23 create car-cells N allot
  24 create car-type-cells N allot
  25 create cdr-cells N allot
  26 create cdr-type-cells N allot
  27
  28 variable nextfree
  29 0 nextfree !
  30
  31 : cons ( car-obj cdr-obj -- pair-obj )
  32     cdr-type-cells nextfree @ + !
  33     cdr-cells nextfree @ + !
  34     car-type-cells nextfree @ + !
  35     car-cells nextfree @ + !
  36
  37     nextfree @ pair-type
  38
  39     1 nextfree +!
  40 ;
  41
  42 : car ( pair-obj -- car-obj )
  43     drop
  44     dup car-cells + @ swap
  45     car-type-cells + @
  46 ;
  47
  48 : cdr ( pair-obj -- car-obj )
  49     drop
  50     dup cdr-cells + @ swap
  51     cdr-type-cells + @
  52 ;
  53
  54 : set-car! ( obj pair-obj -- )
  55     drop dup
  56     rot swap  car-type-cells + !
  57     car-cells + !
  58 ;
  59
  60 : set-cdr! ( obj pair-obj -- )
  61     drop dup
  62     rot swap  cdr-type-cells + !
  63     cdr-cells + !
  64 ;
  65
  66 : caar car car ;
  67 : cadr cdr car ;
  68 : cdar car cdr ;
  69 : cddr cdr cdr ;
  70
  71 : nil 0 nil-type ;
  72 : nil? nil-type istype? ;
  73
  74 : objvar create nil swap , , ;
  75
  76 : value@ ( objvar -- val ) @ ;
  77 : type@ ( objvar -- type ) 1+ @ ;
  78 : value! ( newval objvar -- ) ! ;
  79 : type! ( newtype objvar -- ) 1+ ! ;
  80 : setobj ( newobj objvar -- ) dup rot swap 1+ ! ! ;
  81 : fetchobj ( objvar -- obj ) dup @ swap 1+ @ ;
  82
  83 : objeq? ( obj obj -- bool )
  84     rot = -rot = and ;
  85
  86 : 2rot ( a1 a2 b1 b2 c1 c2 -- b1 b2 c1 c2 a1 a2 )
  87     >R >R ( a1 a2 b1 b2 )
  88     2swap ( b1 b2 a1 a2 )
  89     R> R> ( b1 b2 a1 a2 c1 c2 )
  90     2swap
  91 ;
  92
  93 : -2rot ( a1 a2 b1 b2 c1 c2 -- c1 c2 a1 a2 b1 b2 )
  94     2swap ( a1 a2 c1 c2 b1 b2 )
  95     >R >R ( a1 a2 c1 c2 )
  96     2swap ( c1 c2 a1 a2 )
  97     R> R>
  98 ;
  99
 100 \ }}}
 101
 102 \ ---- Pre-defined symbols ---- {{{
 103
 104 objvar symbol-table
 105
 106 : (create-symbol) ( addr n -- symbol-obj )
 107     dup 0= if
 108         2drop nil
 109     else
 110         2dup drop @ character-type 2swap
 111         swap 1+ swap 1-
 112         recurse
 113
 114         cons
 115     then
 116 ;
 117
 118 : create-symbol ( -- )
 119     bl word
 120     count
 121
 122     (create-symbol)
 123     drop symbol-type
 124
 125     2dup
 126
 127     symbol-table fetchobj
 128     cons
 129     symbol-table setobj
 130
 131     create swap , ,
 132     does> dup @ swap 1+ @
 133 ;
 134
 135 create-symbol quote     quote-symbol
 136 create-symbol define    define-symbol
 137 create-symbol set!      set!-symbol
 138 create-symbol ok        ok-symbol
 139 create-symbol if        if-symbol
 140
 141 \ }}}
 142
 143 \ ---- Environments ---- {{{
 144
 145 : enclosing-env ( env -- env )
 146     cdr ;
 147
 148 : first-frame ( env -- frame )
 149     car ;
 150
 151 : make-frame ( vars vals -- frame )
 152     cons ;
 153
 154 : frame-vars ( frame -- vars )
 155     car ;
 156
 157 : frame-vals ( frame -- vals )
 158     cdr ;
 159
 160 : add-binding ( var val frame -- )
 161     2swap 2over frame-vals cons
 162     2over set-cdr!
 163     2swap 2over frame-vars cons
 164     2swap set-car!
 165 ;
 166
 167 : extend-env ( vars vals env -- env )
 168     >R >R
 169     make-frame
 170     R> R>
 171     cons
 172 ;
 173
 174 objvar vars
 175 objvar vals
 176
 177 : get-vars-vals-frame ( var frame -- bool )
 178     2dup frame-vars vars setobj
 179     frame-vals vals setobj
 180
 181     begin
 182         vars fetchobj nil objeq? false =
 183     while
 184         2dup vars fetchobj car objeq? if
 185             2drop true
 186             exit
 187         then
 188
 189         vars fetchobj cdr vars setobj
 190         vals fetchobj cdr vals setobj
 191     repeat
 192
 193     2drop false
 194 ;
 195
 196 : get-vars-vals ( var env -- vars? vals? bool )
 197
 198     begin
 199         2dup nil objeq? false =
 200     while
 201         2over 2over first-frame
 202         get-vars-vals-frame if
 203             2drop 2drop
 204             vars fetchobj vals fetchobj true
 205             exit
 206         then
 207
 208         enclosing-env
 209     repeat
 210
 211     2drop 2drop
 212     false
 213 ;
 214
 215 hide vars
 216 hide vals
 217
 218 : lookup-var ( var env -- val )
 219     get-vars-vals if
 220         2swap 2drop car
 221     else
 222         bold fg red ." Tried to read unbound variable." reset-term cr abort
 223     then
 224 ;
 225
 226 : set-var ( var val env -- )
 227     >R >R 2swap R> R> ( val var env )
 228     get-vars-vals if
 229         2swap 2drop ( val vals )
 230         set-car!
 231     else
 232         bold fg red ." Tried to set unbound variable." reset-term cr abort
 233     then
 234 ;
 235
 236 objvar env
 237
 238 : define-var ( var val env -- )
 239     env setobj
 240
 241     2over env fetchobj ( var val var env )
 242     get-vars-vals if
 243         2swap 2drop ( var val vals )
 244         set-car!
 245         2drop
 246     else
 247         env fetchobj
 248         first-frame ( var val frame )
 249         add-binding
 250     then
 251 ;
 252
 253 hide env
 254
 255 objvar global-env
 256 nil nil nil extend-env
 257 global-env setobj
 258
 259 \ }}}
 260
 261 \ ---- Primitives ---- {{{
 262
 263 : make-primitive ( cfa -- )
 264     bl word
 265     count
 266
 267     (create-symbol)
 268     drop symbol-type
 269
 270     2dup
 271
 272     symbol-table fetchobj
 273     cons
 274     symbol-table setobj
 275
 276     rot primitive-type ( var prim )
 277     global-env fetchobj define-var
 278 ;
 279
 280 : add-prim ( args -- )
 281     nil objeq? if
 282         0 number-type
 283     else
 284         2dup cdr recurse drop
 285         -rot car drop
 286         + number-type
 287     then
 288 ;
 289
 290 ' add-prim make-primitive +
 291
 292 \ }}}
 293
 294 \ ---- Read ---- {{{
 295
 296 defer read
 297
 298 variable parse-idx
 299 variable stored-parse-idx
 300 create parse-str 161 allot
 301 variable parse-str-span
 302
 303 create parse-idx-stack 10 allot
 304 variable parse-idx-sp
 305 parse-idx-stack parse-idx-sp !
 306
 307 : push-parse-idx
 308     parse-idx @ parse-idx-sp @ !
 309     1 parse-idx-sp +!
 310 ;
 311
 312 : pop-parse-idx
 313     parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
 314
 315     1 parse-idx-sp -!
 316
 317     parse-idx-sp @ @ parse-idx ! ;
 318
 319
 320 : append-newline
 321     '\n' parse-str parse-str-span @ + !
 322     1 parse-str-span +! ;
 323
 324 : empty-parse-str
 325     0 parse-str-span !
 326     0 parse-idx ! ;
 327
 328 : getline
 329     parse-str 160 expect cr
 330     span @ parse-str-span !
 331     append-newline
 332     0 parse-idx ! ;
 333
 334 : inc-parse-idx
 335     1 parse-idx +! ;
 336
 337 : dec-parse-idx
 338     1 parse-idx -! ;
 339
 340 : charavailable? ( -- bool )
 341     parse-str-span @ parse-idx @ > ;
 342
 343 : nextchar ( -- char )
 344     charavailable? false = if getline then
 345     parse-str parse-idx @ + @ ;
 346
 347 : whitespace? ( -- bool )
 348     nextchar BL =
 349     nextchar '\n' = or ;
 350
 351 : eof? ( -- bool )
 352     nextchar 4 = ;
 353
 354 : delim? ( -- bool )
 355     whitespace?
 356     nextchar [char] ( = or
 357     nextchar [char] ) = or
 358 ;
 359
 360 : eatspaces
 361     begin
 362         whitespace?
 363     while
 364         inc-parse-idx
 365     repeat
 366 ;
 367
 368 : digit? ( -- bool )
 369     nextchar [char] 0 >=
 370     nextchar [char] 9 <=
 371     and ;
 372
 373 : minus? ( -- bool )
 374     nextchar [char] - = ;
 375
 376 : number? ( -- bool )
 377     digit? minus? or false = if
 378         false
 379         exit
 380     then
 381
 382     push-parse-idx
 383     inc-parse-idx
 384
 385     begin digit? while
 386         inc-parse-idx
 387     repeat
 388
 389     delim? if
 390         pop-parse-idx
 391         true
 392     else
 393         pop-parse-idx
 394         false
 395     then
 396 ;
 397
 398 : boolean? ( -- bool )
 399     nextchar [char] # <> if false exit then
 400
 401     push-parse-idx
 402     inc-parse-idx
 403
 404     nextchar [char] t <>
 405     nextchar [char] f <>
 406     and if pop-parse-idx false exit then
 407
 408     inc-parse-idx
 409     delim? if
 410         pop-parse-idx
 411         true
 412     else
 413         pop-parse-idx
 414         false
 415     then
 416 ;
 417
 418 : str-equiv? ( str -- bool )
 419
 420     push-parse-idx
 421
 422     true -rot
 423
 424     swap dup rot + swap
 425
 426     do
 427         i @ nextchar <> if
 428             drop false
 429             leave
 430         then
 431
 432         inc-parse-idx
 433     loop
 434
 435     delim? false = if drop false then
 436
 437     pop-parse-idx
 438 ;
 439
 440 : character? ( -- bool )
 441     nextchar [char] # <> if false exit then
 442
 443     push-parse-idx
 444     inc-parse-idx
 445
 446     nextchar [char] \ <> if pop-parse-idx false exit then
 447
 448     inc-parse-idx
 449
 450     S" newline" str-equiv? if pop-parse-idx true exit then
 451     S" space" str-equiv? if pop-parse-idx true exit then
 452     S" tab" str-equiv? if pop-parse-idx true exit then
 453
 454     charavailable? false = if pop-parse-idx false exit then
 455
 456     pop-parse-idx true
 457 ;
 458
 459 : pair? ( -- bool )
 460     nextchar [char] ( = ;
 461
 462 : string? ( -- bool )
 463     nextchar [char] " = ;
 464
 465 : readnum ( -- num-atom )
 466     minus? dup if
 467         inc-parse-idx
 468     then
 469
 470     0
 471
 472     begin digit? while
 473         10 * nextchar [char] 0 - +
 474         inc-parse-idx
 475     repeat
 476
 477     swap if negate then
 478
 479     number-type
 480 ;
 481
 482 : readbool ( -- bool-atom )
 483     inc-parse-idx
 484
 485     nextchar [char] f = if
 486         false
 487     else
 488         true
 489     then
 490
 491     inc-parse-idx
 492
 493     boolean-type
 494 ;
 495
 496 : readchar ( -- char-atom )
 497     inc-parse-idx
 498     inc-parse-idx
 499
 500     S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
 501     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
 502     S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
 503
 504     nextchar character-type
 505
 506     inc-parse-idx
 507 ;
 508
 509 : readstring ( -- charlist )
 510     nextchar [char] " = if
 511         inc-parse-idx
 512
 513         delim? false = if
 514             bold fg red
 515             ." No delimiter following right double quote. Aborting." cr
 516             reset-term abort
 517         then
 518
 519         dec-parse-idx
 520
 521         0 nil-type exit
 522     then
 523
 524     nextchar [char] \ = if
 525         inc-parse-idx
 526         nextchar case
 527             [char] n of '\n' endof
 528             [char] " of [char] " endof
 529             [char] \
 530         endcase
 531     else
 532         nextchar
 533     then
 534     inc-parse-idx character-type
 535
 536     recurse
 537
 538     cons
 539 ;
 540
 541 : readsymbol ( -- charlist )
 542     delim? if nil exit then
 543
 544     nextchar inc-parse-idx character-type
 545
 546     recurse
 547
 548     cons
 549 ;
 550
 551 : charlist-equiv ( charlist charlist -- bool )
 552
 553     2over 2over
 554
 555     \ One or both nil
 556     nil? -rot 2drop
 557     if
 558         nil? -rot 2drop
 559         if
 560             2drop 2drop true exit
 561         else
 562             2drop 2drop false exit
 563         then
 564     else
 565         nil? -rot 2drop
 566         if
 567             2drop 2drop false exit
 568         then
 569     then
 570
 571     2over 2over
 572
 573     \ Neither nil
 574     car drop -rot car drop = if
 575             cdr 2swap cdr recurse
 576         else
 577             2drop 2drop false
 578     then
 579 ;
 580
 581 : charlist>symbol ( charlist -- symbol-obj )
 582
 583     symbol-table fetchobj
 584
 585     begin
 586         nil? false =
 587     while
 588         2over 2over
 589         car drop pair-type
 590         charlist-equiv if
 591             2swap 2drop
 592             car
 593             exit
 594         else
 595             cdr
 596         then
 597     repeat
 598
 599     2drop
 600     drop symbol-type 2dup
 601     symbol-table fetchobj cons
 602     symbol-table setobj
 603 ;
 604
 605 : readpair ( -- pairobj )
 606     eatspaces
 607
 608     \ Empty lists
 609     nextchar [char] ) = if
 610         inc-parse-idx
 611
 612         delim? false = if
 613             bold fg red
 614             ." No delimiter following right paren. Aborting." cr
 615             reset-term abort
 616         then
 617
 618         dec-parse-idx
 619
 620         0 nil-type exit
 621     then
 622
 623     \ Read first pair element
 624     read
 625
 626     \ Pairs
 627     eatspaces
 628     nextchar [char] . = if
 629         inc-parse-idx
 630
 631         delim? false = if
 632             bold fg red
 633             ." No delimiter following '.'. Aborting." cr
 634             reset-term abort
 635         then
 636
 637         eatspaces read
 638     else
 639         recurse
 640     then
 641
 642     eatspaces
 643
 644     cons
 645 ;
 646
 647 \ Parse a scheme expression
 648 :noname ( -- obj )
 649
 650     eatspaces
 651
 652     number? if
 653         readnum
 654         exit
 655     then
 656
 657     boolean? if
 658         readbool
 659         exit
 660     then
 661
 662     character? if
 663         readchar
 664         exit
 665     then
 666
 667     string? if
 668         inc-parse-idx
 669
 670         readstring
 671         drop string-type
 672
 673         nextchar [char] " <> if
 674             bold red ." Missing closing double-quote." reset-term cr
 675             abort
 676         then
 677
 678         inc-parse-idx
 679
 680         exit
 681     then
 682
 683     pair? if
 684         inc-parse-idx
 685
 686         eatspaces
 687
 688         readpair
 689
 690         eatspaces
 691
 692         nextchar [char] ) <> if
 693             bold red ." Missing closing paren." reset-term cr
 694             abort
 695         then
 696
 697         inc-parse-idx
 698
 699         exit
 700     then
 701
 702     nextchar [char] ' = if
 703         inc-parse-idx
 704         quote-symbol recurse nil cons cons exit
 705     then
 706
 707     eof? if
 708         bold fg blue ." Moriturus te saluto." reset-term ."  ok" cr
 709         quit
 710     then
 711
 712     \ Anything else is parsed as a symbol
 713     readsymbol charlist>symbol
 714
 715 ; is read
 716
 717 \ }}}
 718
 719 \ ---- Eval ---- {{{
 720
 721 defer eval
 722
 723 : self-evaluating? ( obj -- obj bool )
 724     boolean-type istype? if true exit then
 725     number-type istype? if true exit then
 726     character-type istype? if true exit then
 727     string-type istype? if true exit then
 728     nil-type istype? if true exit then
 729
 730     false
 731 ;
 732
 733 : tagged-list? ( obj tag-obj -- obj bool )
 734     2over
 735     pair-type istype? false = if
 736         2drop 2drop false
 737     else
 738         car objeq?
 739     then ;
 740
 741 : quote? ( obj -- obj bool )
 742     quote-symbol tagged-list?  ;
 743
 744 : quote-body ( quote-obj -- quote-body-obj )
 745     cadr ;
 746
 747 : variable? ( obj -- obj bool )
 748     symbol-type istype? ;
 749
 750 : definition? ( obj -- obj bool )
 751     define-symbol tagged-list? ;
 752
 753 : definition-var ( obj -- var )
 754     cdr car ;
 755
 756 : definition-val ( obj -- val )
 757     cdr cdr car ;
 758
 759 : assignment? ( obj -- obj bool )
 760     set!-symbol tagged-list? ;
 761
 762 : assignment-var ( obj -- var )
 763     cdr car ;
 764
 765 : assignment-val ( obj -- val )
 766     cdr cdr car ;
 767
 768 : eval-definition ( obj env -- res )
 769     2swap
 770     2over 2over ( env obj env obj )
 771     definition-val 2swap ( env obj valexp env )
 772     eval  ( env obj val )
 773
 774     2swap definition-var 2swap ( env var val )
 775
 776     2rot ( var val env )
 777     define-var
 778
 779     ok-symbol
 780 ;
 781
 782 : eval-assignment ( obj env -- res )
 783     2swap
 784     2over 2over ( env obj env obj )
 785     assignment-val 2swap ( env obj valexp env )
 786     eval  ( env obj val )
 787
 788     2swap assignment-var 2swap ( env var val )
 789
 790     2rot ( var val env )
 791     set-var
 792
 793     ok-symbol
 794 ;
 795
 796 : if? ( obj -- obj bool )
 797     if-symbol tagged-list? ;
 798
 799 : if-predicate ( ifobj -- pred )
 800     cdr car ;
 801
 802 : if-consequent ( ifobj -- conseq )
 803     cdr cdr car ;
 804
 805 : if-alternative ( ifobj -- alt|false )
 806     cdr cdr cdr
 807     2dup nil objeq? if
 808         2drop false
 809     else
 810         car
 811     then ;
 812
 813 : false? ( boolobj -- boolean )
 814     boolean-type istype? if
 815         false boolean-type objeq?
 816     else
 817         2drop false
 818     then
 819 ;
 820
 821 : true? ( boolobj -- bool )
 822     false? invert ;
 823
 824 : applicaion? ( obj -- obj bool)
 825     pair-type istype? ;
 826
 827 : operator ( obj -- operator )
 828     car ;
 829
 830 : operands ( obj -- operands )
 831     cdr ;
 832
 833 : nooperands? ( operands -- bool )
 834     nil objeq? ;
 835
 836 : first-operand ( operands -- operand )
 837     car ;
 838
 839 : rest-operands ( operands -- other-operands )
 840     cdr ;
 841
 842 : list-of-vals ( args env -- vals )
 843     2swap
 844
 845     2dup nooperands? if
 846         2swap 2drop
 847     else
 848         2over 2over first-operand 2swap eval
 849         -2rot rest-operands 2swap recurse
 850         cons
 851     then
 852 ;
 853
 854 :noname ( obj env -- result )
 855     2swap
 856
 857     self-evaluating? if
 858         2swap 2drop
 859         exit
 860     then
 861
 862     quote? if
 863         quote-body
 864         2swap 2drop
 865         exit
 866     then
 867
 868     variable? if
 869         2swap lookup-var
 870         exit
 871     then
 872
 873     definition? if
 874         2swap eval-definition
 875         exit
 876     then
 877
 878     assignment? if
 879         2swap eval-assignment
 880         exit
 881     then
 882
 883     if? if
 884         2over 2over
 885         if-predicate
 886         2swap eval
 887
 888         true? if
 889             if-consequent
 890         else
 891             if-alternative
 892         then
 893
 894         2swap ['] eval goto
 895     then
 896
 897     application? if
 898         2over 2over
 899         operator 2swap eval
 900
 901         primitive-type istype? false = if
 902             bold fg red ." Object not applicable. Aboring." reset-term cr
 903             abort
 904         then
 905
 906         -2rot
 907         operands 2swap list-of-vals
 908
 909         2swap drop execute
 910         exit
 911     then
 912
 913     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
 914     abort
 915 ; is eval
 916
 917 \ }}}
 918
 919 \ ---- Print ---- {{{
 920
 921 defer print
 922
 923 : printnum ( numobj -- ) drop 0 .R ;
 924
 925 : printbool ( numobj -- )
 926     drop if
 927         ." #t"
 928     else
 929         ." #f"
 930     then
 931 ;
 932
 933 : printchar ( charobj -- )
 934     drop
 935     case
 936         9 of ." #\tab" endof
 937         bl of ." #\space" endof
 938         '\n' of ." #\newline" endof
 939
 940         dup ." #\" emit
 941     endcase
 942 ;
 943
 944 : (printstring) ( stringobj -- )
 945     nil-type istype? if 2drop exit then
 946
 947     2dup car drop dup
 948     case
 949         '\n' of ." \n" drop endof
 950         [char] \ of ." \\" drop endof
 951         [char] " of [char] \ emit [char] " emit drop endof
 952         emit
 953     endcase
 954
 955     cdr recurse
 956 ;
 957 : printstring ( stringobj -- )
 958     [char] " emit
 959     (printstring)
 960     [char] " emit ;
 961
 962 : printsymbol ( symbolobj -- )
 963     nil-type istype? if 2drop exit then
 964
 965     2dup car drop emit
 966     cdr recurse
 967 ;
 968
 969 : printnil ( nilobj -- )
 970     2drop ." ()" ;
 971
 972 : printpair ( pairobj -- )
 973     2dup
 974     car print
 975     cdr
 976     nil-type istype? if 2drop exit then
 977     pair-type istype? if space recurse exit then
 978     ."  . " print
 979 ;
 980
 981 : printprim ( primobj -- )
 982     2drop ." <primitive procedure>" ;
 983
 984 :noname ( obj -- )
 985     number-type istype? if printnum exit then
 986     boolean-type istype? if printbool exit then
 987     character-type istype? if printchar exit then
 988     string-type istype? if printstring exit then
 989     symbol-type istype? if printsymbol exit then
 990     nil-type istype? if printnil exit then
 991     pair-type istype? if ." (" printpair ." )" exit then
 992     primitive-type istype? if printprim exit then
 993
 994     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
 995     abort
 996 ; is print
 997
 998 \ }}}
 999
1000 \ ---- REPL ----
1001
1002 : repl
1003     cr ." Welcome to scheme.forth.jl!" cr
1004        ." Use Ctrl-D to exit." cr
1005
1006     empty-parse-str
1007
1008     begin
1009         cr bold fg green ." > " reset-term
1010         read
1011         global-env fetchobj eval
1012         fg cyan ." ; " print reset-term
1013     again
1014 ;
1015
1016 forth definitions
1017
1018 \ vim:fdm=marker