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