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     2dup nil objeq? if
 282         2drop
 283         0 number-type
 284     else
 285         2dup cdr recurse drop
 286         -rot car drop
 287         + number-type
 288     then
 289 ;
 290
 291 ' add-prim make-primitive +
 292
 293 \ }}}
 294
 295 \ ---- Read ---- {{{
 296
 297 defer read
 298
 299 variable parse-idx
 300 variable stored-parse-idx
 301 create parse-str 161 allot
 302 variable parse-str-span
 303
 304 create parse-idx-stack 10 allot
 305 variable parse-idx-sp
 306 parse-idx-stack parse-idx-sp !
 307
 308 : push-parse-idx
 309     parse-idx @ parse-idx-sp @ !
 310     1 parse-idx-sp +!
 311 ;
 312
 313 : pop-parse-idx
 314     parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
 315
 316     1 parse-idx-sp -!
 317
 318     parse-idx-sp @ @ parse-idx ! ;
 319
 320
 321 : append-newline
 322     '\n' parse-str parse-str-span @ + !
 323     1 parse-str-span +! ;
 324
 325 : empty-parse-str
 326     0 parse-str-span !
 327     0 parse-idx ! ;
 328
 329 : getline
 330     parse-str 160 expect cr
 331     span @ parse-str-span !
 332     append-newline
 333     0 parse-idx ! ;
 334
 335 : inc-parse-idx
 336     1 parse-idx +! ;
 337
 338 : dec-parse-idx
 339     1 parse-idx -! ;
 340
 341 : charavailable? ( -- bool )
 342     parse-str-span @ parse-idx @ > ;
 343
 344 : nextchar ( -- char )
 345     charavailable? false = if getline then
 346     parse-str parse-idx @ + @ ;
 347
 348 : whitespace? ( -- bool )
 349     nextchar BL =
 350     nextchar '\n' = or ;
 351
 352 : eof? ( -- bool )
 353     nextchar 4 = ;
 354
 355 : delim? ( -- bool )
 356     whitespace?
 357     nextchar [char] ( = or
 358     nextchar [char] ) = or
 359 ;
 360
 361 : eatspaces
 362     begin
 363         whitespace?
 364     while
 365         inc-parse-idx
 366     repeat
 367 ;
 368
 369 : digit? ( -- bool )
 370     nextchar [char] 0 >=
 371     nextchar [char] 9 <=
 372     and ;
 373
 374 : minus? ( -- bool )
 375     nextchar [char] - = ;
 376
 377 : number? ( -- bool )
 378     digit? minus? or false = if
 379         false
 380         exit
 381     then
 382
 383     push-parse-idx
 384     inc-parse-idx
 385
 386     begin digit? while
 387         inc-parse-idx
 388     repeat
 389
 390     delim? if
 391         pop-parse-idx
 392         true
 393     else
 394         pop-parse-idx
 395         false
 396     then
 397 ;
 398
 399 : boolean? ( -- bool )
 400     nextchar [char] # <> if false exit then
 401
 402     push-parse-idx
 403     inc-parse-idx
 404
 405     nextchar [char] t <>
 406     nextchar [char] f <>
 407     and if pop-parse-idx false exit then
 408
 409     inc-parse-idx
 410     delim? if
 411         pop-parse-idx
 412         true
 413     else
 414         pop-parse-idx
 415         false
 416     then
 417 ;
 418
 419 : str-equiv? ( str -- bool )
 420
 421     push-parse-idx
 422
 423     true -rot
 424
 425     swap dup rot + swap
 426
 427     do
 428         i @ nextchar <> if
 429             drop false
 430             leave
 431         then
 432
 433         inc-parse-idx
 434     loop
 435
 436     delim? false = if drop false then
 437
 438     pop-parse-idx
 439 ;
 440
 441 : character? ( -- bool )
 442     nextchar [char] # <> if false exit then
 443
 444     push-parse-idx
 445     inc-parse-idx
 446
 447     nextchar [char] \ <> if pop-parse-idx false exit then
 448
 449     inc-parse-idx
 450
 451     S" newline" str-equiv? if pop-parse-idx true exit then
 452     S" space" str-equiv? if pop-parse-idx true exit then
 453     S" tab" str-equiv? if pop-parse-idx true exit then
 454
 455     charavailable? false = if pop-parse-idx false exit then
 456
 457     pop-parse-idx true
 458 ;
 459
 460 : pair? ( -- bool )
 461     nextchar [char] ( = ;
 462
 463 : string? ( -- bool )
 464     nextchar [char] " = ;
 465
 466 : readnum ( -- num-atom )
 467     minus? dup if
 468         inc-parse-idx
 469     then
 470
 471     0
 472
 473     begin digit? while
 474         10 * nextchar [char] 0 - +
 475         inc-parse-idx
 476     repeat
 477
 478     swap if negate then
 479
 480     number-type
 481 ;
 482
 483 : readbool ( -- bool-atom )
 484     inc-parse-idx
 485
 486     nextchar [char] f = if
 487         false
 488     else
 489         true
 490     then
 491
 492     inc-parse-idx
 493
 494     boolean-type
 495 ;
 496
 497 : readchar ( -- char-atom )
 498     inc-parse-idx
 499     inc-parse-idx
 500
 501     S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
 502     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
 503     S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
 504
 505     nextchar character-type
 506
 507     inc-parse-idx
 508 ;
 509
 510 : readstring ( -- charlist )
 511     nextchar [char] " = if
 512         inc-parse-idx
 513
 514         delim? false = if
 515             bold fg red
 516             ." No delimiter following right double quote. Aborting." cr
 517             reset-term abort
 518         then
 519
 520         dec-parse-idx
 521
 522         0 nil-type exit
 523     then
 524
 525     nextchar [char] \ = if
 526         inc-parse-idx
 527         nextchar case
 528             [char] n of '\n' endof
 529             [char] " of [char] " endof
 530             [char] \
 531         endcase
 532     else
 533         nextchar
 534     then
 535     inc-parse-idx character-type
 536
 537     recurse
 538
 539     cons
 540 ;
 541
 542 : readsymbol ( -- charlist )
 543     delim? if nil exit then
 544
 545     nextchar inc-parse-idx character-type
 546
 547     recurse
 548
 549     cons
 550 ;
 551
 552 : charlist-equiv ( charlist charlist -- bool )
 553
 554     2over 2over
 555
 556     \ One or both nil
 557     nil? -rot 2drop
 558     if
 559         nil? -rot 2drop
 560         if
 561             2drop 2drop true exit
 562         else
 563             2drop 2drop false exit
 564         then
 565     else
 566         nil? -rot 2drop
 567         if
 568             2drop 2drop false exit
 569         then
 570     then
 571
 572     2over 2over
 573
 574     \ Neither nil
 575     car drop -rot car drop = if
 576             cdr 2swap cdr recurse
 577         else
 578             2drop 2drop false
 579     then
 580 ;
 581
 582 : charlist>symbol ( charlist -- symbol-obj )
 583
 584     symbol-table fetchobj
 585
 586     begin
 587         nil? false =
 588     while
 589         2over 2over
 590         car drop pair-type
 591         charlist-equiv if
 592             2swap 2drop
 593             car
 594             exit
 595         else
 596             cdr
 597         then
 598     repeat
 599
 600     2drop
 601     drop symbol-type 2dup
 602     symbol-table fetchobj cons
 603     symbol-table setobj
 604 ;
 605
 606 : readpair ( -- pairobj )
 607     eatspaces
 608
 609     \ Empty lists
 610     nextchar [char] ) = if
 611         inc-parse-idx
 612
 613         delim? false = if
 614             bold fg red
 615             ." No delimiter following right paren. Aborting." cr
 616             reset-term abort
 617         then
 618
 619         dec-parse-idx
 620
 621         0 nil-type exit
 622     then
 623
 624     \ Read first pair element
 625     read
 626
 627     \ Pairs
 628     eatspaces
 629     nextchar [char] . = if
 630         inc-parse-idx
 631
 632         delim? false = if
 633             bold fg red
 634             ." No delimiter following '.'. Aborting." cr
 635             reset-term abort
 636         then
 637
 638         eatspaces read
 639     else
 640         recurse
 641     then
 642
 643     eatspaces
 644
 645     cons
 646 ;
 647
 648 \ Parse a scheme expression
 649 :noname ( -- obj )
 650
 651     eatspaces
 652
 653     number? if
 654         readnum
 655         exit
 656     then
 657
 658     boolean? if
 659         readbool
 660         exit
 661     then
 662
 663     character? if
 664         readchar
 665         exit
 666     then
 667
 668     string? if
 669         inc-parse-idx
 670
 671         readstring
 672         drop string-type
 673
 674         nextchar [char] " <> if
 675             bold red ." Missing closing double-quote." reset-term cr
 676             abort
 677         then
 678
 679         inc-parse-idx
 680
 681         exit
 682     then
 683
 684     pair? if
 685         inc-parse-idx
 686
 687         eatspaces
 688
 689         readpair
 690
 691         eatspaces
 692
 693         nextchar [char] ) <> if
 694             bold red ." Missing closing paren." reset-term cr
 695             abort
 696         then
 697
 698         inc-parse-idx
 699
 700         exit
 701     then
 702
 703     nextchar [char] ' = if
 704         inc-parse-idx
 705         quote-symbol recurse nil cons cons exit
 706     then
 707
 708     eof? if
 709         bold fg blue ." Moriturus te saluto." reset-term ."  ok" cr
 710         quit
 711     then
 712
 713     \ Anything else is parsed as a symbol
 714     readsymbol charlist>symbol
 715
 716 ; is read
 717
 718 \ }}}
 719
 720 \ ---- Eval ---- {{{
 721
 722 defer eval
 723
 724 : self-evaluating? ( obj -- obj bool )
 725     boolean-type istype? if true exit then
 726     number-type istype? if true exit then
 727     character-type istype? if true exit then
 728     string-type istype? if true exit then
 729     nil-type istype? if true exit then
 730
 731     false
 732 ;
 733
 734 : tagged-list? ( obj tag-obj -- obj bool )
 735     2over
 736     pair-type istype? false = if
 737         2drop 2drop false
 738     else
 739         car objeq?
 740     then ;
 741
 742 : quote? ( obj -- obj bool )
 743     quote-symbol tagged-list?  ;
 744
 745 : quote-body ( quote-obj -- quote-body-obj )
 746     cadr ;
 747
 748 : variable? ( obj -- obj bool )
 749     symbol-type istype? ;
 750
 751 : definition? ( obj -- obj bool )
 752     define-symbol tagged-list? ;
 753
 754 : definition-var ( obj -- var )
 755     cdr car ;
 756
 757 : definition-val ( obj -- val )
 758     cdr cdr car ;
 759
 760 : assignment? ( obj -- obj bool )
 761     set!-symbol tagged-list? ;
 762
 763 : assignment-var ( obj -- var )
 764     cdr car ;
 765
 766 : assignment-val ( obj -- val )
 767     cdr cdr car ;
 768
 769 : eval-definition ( obj env -- res )
 770     2swap
 771     2over 2over ( env obj env obj )
 772     definition-val 2swap ( env obj valexp env )
 773     eval  ( env obj val )
 774
 775     2swap definition-var 2swap ( env var val )
 776
 777     2rot ( var val env )
 778     define-var
 779
 780     ok-symbol
 781 ;
 782
 783 : eval-assignment ( obj env -- res )
 784     2swap
 785     2over 2over ( env obj env obj )
 786     assignment-val 2swap ( env obj valexp env )
 787     eval  ( env obj val )
 788
 789     2swap assignment-var 2swap ( env var val )
 790
 791     2rot ( var val env )
 792     set-var
 793
 794     ok-symbol
 795 ;
 796
 797 : if? ( obj -- obj bool )
 798     if-symbol tagged-list? ;
 799
 800 : if-predicate ( ifobj -- pred )
 801     cdr car ;
 802
 803 : if-consequent ( ifobj -- conseq )
 804     cdr cdr car ;
 805
 806 : if-alternative ( ifobj -- alt|false )
 807     cdr cdr cdr
 808     2dup nil objeq? if
 809         2drop false
 810     else
 811         car
 812     then ;
 813
 814 : false? ( boolobj -- boolean )
 815     boolean-type istype? if
 816         false boolean-type objeq?
 817     else
 818         2drop false
 819     then
 820 ;
 821
 822 : true? ( boolobj -- bool )
 823     false? invert ;
 824
 825 : application? ( obj -- obj bool)
 826     pair-type istype? ;
 827
 828 : operator ( obj -- operator )
 829     car ;
 830
 831 : operands ( obj -- operands )
 832     cdr ;
 833
 834 : nooperands? ( operands -- bool )
 835     nil objeq? ;
 836
 837 : first-operand ( operands -- operand )
 838     car ;
 839
 840 : rest-operands ( operands -- other-operands )
 841     cdr ;
 842
 843 : list-of-vals ( args env -- vals )
 844     2swap
 845
 846     2dup nooperands? if
 847         2swap 2drop
 848     else
 849         2over 2over first-operand 2swap eval
 850         -2rot rest-operands 2swap recurse
 851         cons
 852     then
 853 ;
 854
 855 :noname ( obj env -- result )
 856     2swap
 857
 858     self-evaluating? if
 859         2swap 2drop
 860         exit
 861     then
 862
 863     quote? if
 864         quote-body
 865         2swap 2drop
 866         exit
 867     then
 868
 869     variable? if
 870         2swap lookup-var
 871         exit
 872     then
 873
 874     definition? if
 875         2swap eval-definition
 876         exit
 877     then
 878
 879     assignment? if
 880         2swap eval-assignment
 881         exit
 882     then
 883
 884     if? if
 885         2over 2over
 886         if-predicate
 887         2swap eval
 888
 889         true? if
 890             if-consequent
 891         else
 892             if-alternative
 893         then
 894
 895         2swap ['] eval goto
 896     then
 897
 898     application? if
 899         2over 2over
 900         operator 2swap eval
 901
 902         primitive-type istype? false = if
 903             bold fg red ." Object not applicable. Aboring." reset-term cr
 904             abort
 905         then
 906
 907         -2rot
 908         operands 2swap list-of-vals
 909
 910         2swap drop execute
 911         exit
 912     then
 913
 914     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
 915     abort
 916 ; is eval
 917
 918 \ }}}
 919
 920 \ ---- Print ---- {{{
 921
 922 defer print
 923
 924 : printnum ( numobj -- ) drop 0 .R ;
 925
 926 : printbool ( numobj -- )
 927     drop if
 928         ." #t"
 929     else
 930         ." #f"
 931     then
 932 ;
 933
 934 : printchar ( charobj -- )
 935     drop
 936     case
 937         9 of ." #\tab" endof
 938         bl of ." #\space" endof
 939         '\n' of ." #\newline" endof
 940
 941         dup ." #\" emit
 942     endcase
 943 ;
 944
 945 : (printstring) ( stringobj -- )
 946     nil-type istype? if 2drop exit then
 947
 948     2dup car drop dup
 949     case
 950         '\n' of ." \n" drop endof
 951         [char] \ of ." \\" drop endof
 952         [char] " of [char] \ emit [char] " emit drop endof
 953         emit
 954     endcase
 955
 956     cdr recurse
 957 ;
 958 : printstring ( stringobj -- )
 959     [char] " emit
 960     (printstring)
 961     [char] " emit ;
 962
 963 : printsymbol ( symbolobj -- )
 964     nil-type istype? if 2drop exit then
 965
 966     2dup car drop emit
 967     cdr recurse
 968 ;
 969
 970 : printnil ( nilobj -- )
 971     2drop ." ()" ;
 972
 973 : printpair ( pairobj -- )
 974     2dup
 975     car print
 976     cdr
 977     nil-type istype? if 2drop exit then
 978     pair-type istype? if space recurse exit then
 979     ."  . " print
 980 ;
 981
 982 : printprim ( primobj -- )
 983     2drop ." <primitive procedure>" ;
 984
 985 :noname ( obj -- )
 986     number-type istype? if printnum exit then
 987     boolean-type istype? if printbool exit then
 988     character-type istype? if printchar exit then
 989     string-type istype? if printstring exit then
 990     symbol-type istype? if printsymbol exit then
 991     nil-type istype? if printnil exit then
 992     pair-type istype? if ." (" printpair ." )" exit then
 993     primitive-type istype? if printprim exit then
 994
 995     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
 996     abort
 997 ; is print
 998
 999 \ }}}
1000
1001 \ ---- REPL ----
1002
1003 : repl
1004     cr ." Welcome to scheme.forth.jl!" cr
1005        ." Use Ctrl-D to exit." cr
1006
1007     empty-parse-str
1008
1009     begin
1010         cr bold fg green ." > " reset-term
1011         read
1012         global-env fetchobj eval
1013         fg cyan ." ; " print reset-term
1014     again
1015 ;
1016
1017 forth definitions
1018
1019 \ vim:fdm=marker