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