scheme.4th

   1 vocabulary scheme
   2 scheme definitions
   3
   4 include term-colours.4th
   5 include defer-is.4th
   6 include float.4th
   7
   8 include debugging.4th
   9
  10 defer read
  11 defer eval
  12 defer print
  13
  14 \ ------ Types ------
  15
  16 variable nexttype
  17 0 nexttype !
  18 : make-type
  19     create nexttype @ ,
  20     1 nexttype +!
  21     does> @ ;
  22
  23 make-type fixnum-type
  24 make-type realnum-type
  25 make-type boolean-type
  26 make-type character-type
  27 make-type string-type
  28 make-type nil-type
  29 make-type pair-type
  30 make-type symbol-type
  31 make-type primitive-proc-type
  32 make-type compound-proc-type
  33 : istype? ( obj type -- obj bool )
  34     over = ;
  35
  36 \ ------ Cons cell memory ------ {{{
  37
  38 1000 constant scheme-memsize
  39 create car-cells scheme-memsize allot
  40 create car-type-cells scheme-memsize allot
  41 create cdr-cells scheme-memsize allot
  42 create cdr-type-cells scheme-memsize allot
  43
  44 create nextfrees scheme-memsize allot
  45 :noname
  46     scheme-memsize 0 do
  47         i 1+ nextfrees i + !
  48     loop
  49 ; execute
  50
  51 variable nextfree
  52 0 nextfree !
  53
  54 : inc-nextfree
  55     nextfrees nextfree @ + @
  56
  57     dup scheme-memsize < if
  58         nextfree !
  59     else
  60         bold fg red
  61         ." Out of memory! Aborting."
  62         reset-term abort
  63     then
  64 ;
  65
  66 : cons ( car-obj cdr-obj -- pair-obj )
  67     cdr-type-cells nextfree @ + !
  68     cdr-cells nextfree @ + !
  69     car-type-cells nextfree @ + !
  70     car-cells nextfree @ + !
  71
  72     nextfree @ pair-type
  73     inc-nextfree
  74 ;
  75
  76 : car ( pair-obj -- car-obj )
  77     drop
  78     dup car-cells + @ swap
  79     car-type-cells + @
  80 ;
  81
  82 : cdr ( pair-obj -- car-obj )
  83     drop
  84     dup cdr-cells + @ swap
  85     cdr-type-cells + @
  86 ;
  87
  88 : set-car! ( obj pair-obj -- )
  89     drop dup
  90     rot swap  car-type-cells + !
  91     car-cells + !
  92 ;
  93
  94 : set-cdr! ( obj pair-obj -- )
  95     drop dup
  96     rot swap  cdr-type-cells + !
  97     cdr-cells + !
  98 ;
  99
 100 : caar car car ;
 101 : cadr cdr car ;
 102 : cdar car cdr ;
 103 : cddr cdr cdr ;
 104
 105 : nil 0 nil-type ;
 106 : nil? nil-type istype? ;
 107
 108 : objvar create nil swap , , ;
 109
 110 : value@ ( objvar -- val ) @ ;
 111 : type@ ( objvar -- type ) 1+ @ ;
 112 : value! ( newval objvar -- ) ! ;
 113 : type! ( newtype objvar -- ) 1+ ! ;
 114 : obj! ( newobj objvar -- ) dup rot swap 1+ ! ! ;
 115 : obj@ ( objvar -- obj ) dup @ swap 1+ @ ;
 116
 117 : objeq? ( obj obj -- bool )
 118     rot = -rot = and ;
 119
 120 : 2rot ( a1 a2 b1 b2 c1 c2 -- b1 b2 c1 c2 a1 a2 )
 121     >R >R ( a1 a2 b1 b2 )
 122     2swap ( b1 b2 a1 a2 )
 123     R> R> ( b1 b2 a1 a2 c1 c2 )
 124     2swap
 125 ;
 126
 127 : -2rot ( a1 a2 b1 b2 c1 c2 -- c1 c2 a1 a2 b1 b2 )
 128     2swap ( a1 a2 c1 c2 b1 b2 )
 129     >R >R ( a1 a2 c1 c2 )
 130     2swap ( c1 c2 a1 a2 )
 131     R> R>
 132 ;
 133
 134 \ }}}
 135
 136 \ ---- Garbage Collection ---- {{{
 137
 138 variable gc-enabled
 139 false gc-enabled !
 140
 141 : enable-gc
 142     true gc-enabled ! ;
 143
 144 : disable-gc
 145     false gc-enabled ! ;
 146
 147 : gc-enabled?
 148     gc-enabled @ ;
 149
 150 : pairlike? ( obj -- obj bool )
 151     pair-type istype? if true exit then
 152     string-type istype? if true exit then
 153     symbol-type istype? if true exit then
 154     compound-proc-type istype? if true exit then
 155
 156     false
 157 ;
 158
 159 : pairlike-marked? ( obj -- obj bool )
 160     over nextfrees + @ 0=
 161 ;
 162
 163 : mark-pairlike ( obj -- obj )
 164         over nextfrees + 0 swap !
 165 ;
 166
 167 : gc-unmark ( -- )
 168     scheme-memsize 0 do
 169         1 nextfrees i + !
 170     loop
 171 ;
 172
 173 defer gc-mark-trace
 174 : gc-mark-obj ( obj -- )
 175
 176     gc-mark-trace
 177
 178     pairlike? invert if 2drop exit then
 179     pairlike-marked? if 2drop exit then
 180
 181     mark-pairlike
 182
 183     drop pair-type 2dup
 184
 185     car recurse
 186     cdr recurse
 187 ;
 188
 189 : gc-sweep
 190     scheme-memsize nextfree !
 191     0 scheme-memsize 1- do
 192         nextfrees i + @ 0<> if
 193             nextfree @ nextfrees i + !
 194             i nextfree !
 195         then
 196     -1 +loop
 197 ;
 198
 199 \ }}}
 200
 201 \ ---- Pre-defined symbols ---- {{{
 202
 203 objvar symbol-table
 204
 205 : duplicate-charlist ( charlist -- copy )
 206     2dup nil objeq? false = if
 207         2dup car 2swap cdr recurse cons
 208     then ;
 209
 210 : charlist-equiv ( charlist charlist -- bool )
 211
 212     2over 2over
 213
 214     \ One or both nil
 215     nil? -rot 2drop
 216     if
 217         nil? -rot 2drop
 218         if
 219             2drop 2drop true exit
 220         else
 221             2drop 2drop false exit
 222         then
 223     else
 224         nil? -rot 2drop
 225         if
 226             2drop 2drop false exit
 227         then
 228     then
 229
 230     2over 2over
 231
 232     \ Neither nil
 233     car drop -rot car drop = if
 234             cdr 2swap cdr recurse
 235         else
 236             2drop 2drop false
 237     then
 238 ;
 239
 240 : charlist>symbol ( charlist -- symbol-obj )
 241
 242     symbol-table obj@
 243
 244     begin
 245         nil? false =
 246     while
 247         2over 2over
 248         car drop pair-type
 249         charlist-equiv if
 250             2swap 2drop
 251             car
 252             exit
 253         else
 254             cdr
 255         then
 256     repeat
 257
 258     2drop
 259     drop symbol-type 2dup
 260     symbol-table obj@ cons
 261     symbol-table obj!
 262 ;
 263
 264
 265 : (create-symbol) ( addr n -- symbol-obj )
 266     dup 0= if
 267         2drop nil
 268     else
 269         2dup drop @ character-type 2swap
 270         swap 1+ swap 1-
 271         recurse
 272
 273         cons
 274     then
 275 ;
 276
 277 : create-symbol ( -- )
 278     bl word
 279     count
 280
 281     (create-symbol)
 282     drop symbol-type
 283
 284     2dup
 285
 286     symbol-table obj@
 287     cons
 288     symbol-table obj!
 289
 290     create swap , ,
 291     does> dup @ swap 1+ @
 292 ;
 293
 294 create-symbol quote     quote-symbol
 295 create-symbol define    define-symbol
 296 create-symbol set!      set!-symbol
 297 create-symbol ok        ok-symbol
 298 create-symbol if        if-symbol
 299 create-symbol lambda    lambda-symbol
 300 create-symbol λ         λ-symbol
 301
 302 \ }}}
 303
 304 \ ---- Environments ---- {{{
 305
 306 : enclosing-env ( env -- env )
 307     cdr ;
 308
 309 : first-frame ( env -- frame )
 310     car ;
 311
 312 : make-frame ( vars vals -- frame )
 313     cons ;
 314
 315 : frame-vars ( frame -- vars )
 316     car ;
 317
 318 : frame-vals ( frame -- vals )
 319     cdr ;
 320
 321 : add-binding ( var val frame -- )
 322     2swap 2over frame-vals cons
 323     2over set-cdr!
 324     2swap 2over frame-vars cons
 325     2swap set-car!
 326 ;
 327
 328 : extend-env ( vars vals env -- env )
 329     >R >R
 330     make-frame
 331     R> R>
 332     cons
 333 ;
 334
 335 objvar vars
 336 objvar vals
 337
 338 : get-vars-vals-frame ( var frame -- bool )
 339     2dup frame-vars vars obj!
 340     frame-vals vals obj!
 341
 342     begin
 343         vars obj@ nil objeq? false =
 344     while
 345         2dup vars obj@ car objeq? if
 346             2drop true
 347             exit
 348         then
 349
 350         vars obj@ cdr vars obj!
 351         vals obj@ cdr vals obj!
 352     repeat
 353
 354     2drop false
 355 ;
 356
 357 : get-vars-vals ( var env -- vars? vals? bool )
 358
 359     begin
 360         2dup nil objeq? false =
 361     while
 362         2over 2over first-frame
 363         get-vars-vals-frame if
 364             2drop 2drop
 365             vars obj@ vals obj@ true
 366             exit
 367         then
 368
 369         enclosing-env
 370     repeat
 371
 372     2drop 2drop
 373     false
 374 ;
 375
 376 hide vars
 377 hide vals
 378
 379 : lookup-var ( var env -- val )
 380     get-vars-vals if
 381         2swap 2drop car
 382     else
 383         bold fg red ." Tried to read unbound variable." reset-term cr abort
 384     then
 385 ;
 386
 387 : set-var ( var val env -- )
 388     >R >R 2swap R> R> ( val var env )
 389     get-vars-vals if
 390         2swap 2drop ( val vals )
 391         set-car!
 392     else
 393         bold fg red ." Tried to set unbound variable." reset-term cr abort
 394     then
 395 ;
 396
 397 objvar env
 398
 399 : define-var ( var val env -- )
 400     env obj!
 401
 402     2over env obj@ ( var val var env )
 403     get-vars-vals if
 404         2swap 2drop ( var val vals )
 405         set-car!
 406         2drop
 407     else
 408         env obj@
 409         first-frame ( var val frame )
 410         add-binding
 411     then
 412 ;
 413
 414 hide env
 415
 416 objvar global-env
 417 nil nil nil extend-env
 418 global-env obj!
 419
 420 \ }}}
 421
 422 \ ---- Primitives ---- {{{
 423
 424 : make-primitive ( cfa -- )
 425     bl word
 426     count
 427
 428     \ 2dup ." Defining primitive " type ." ..." cr
 429
 430     (create-symbol)
 431     drop symbol-type
 432
 433     2dup
 434
 435     symbol-table obj@
 436     cons
 437     symbol-table obj!
 438
 439     rot primitive-proc-type ( var prim )
 440     global-env obj@ define-var
 441 ;
 442
 443 : arg-count-error
 444             bold fg red ." Incorrect argument count." reset-term cr
 445             abort
 446 ;
 447
 448 : ensure-arg-count ( args n -- )
 449     dup 0= if
 450         drop nil objeq? false = if
 451             arg-count-error
 452         then
 453     else
 454         -rot 2dup nil objeq? if
 455             arg-count-error
 456         then
 457
 458         cdr rot 1- recurse
 459     then
 460 ;
 461
 462 : arg-type-error
 463             bold fg red ." Incorrect argument type." reset-term cr
 464             abort
 465 ;
 466
 467 : ensure-arg-type ( arg type -- arg )
 468     istype? false = if
 469         arg-type-error
 470     then
 471 ;
 472
 473 include scheme-primitives.4th
 474
 475 \ }}}
 476
 477 \ ---- Read ---- {{{
 478
 479 variable parse-idx
 480 variable stored-parse-idx
 481 create parse-str 161 allot
 482 variable parse-str-span
 483
 484 create parse-idx-stack 10 allot
 485 variable parse-idx-sp
 486 parse-idx-stack parse-idx-sp !
 487
 488 : push-parse-idx
 489     parse-idx @ parse-idx-sp @ !
 490     1 parse-idx-sp +!
 491 ;
 492
 493 : pop-parse-idx
 494     parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
 495
 496     1 parse-idx-sp -!
 497
 498     parse-idx-sp @ @ parse-idx ! ;
 499
 500
 501 : append-newline
 502     '\n' parse-str parse-str-span @ + !
 503     1 parse-str-span +! ;
 504
 505 : empty-parse-str
 506     0 parse-str-span !
 507     0 parse-idx ! ;
 508
 509 : getline
 510     parse-str 160 expect cr
 511     span @ parse-str-span !
 512     append-newline
 513     0 parse-idx ! ;
 514
 515 : inc-parse-idx
 516     1 parse-idx +! ;
 517
 518 : dec-parse-idx
 519     1 parse-idx -! ;
 520
 521 : charavailable? ( -- bool )
 522     parse-str-span @ parse-idx @ > ;
 523
 524 : nextchar ( -- char )
 525     charavailable? false = if getline then
 526     parse-str parse-idx @ + @ ;
 527
 528 : whitespace? ( -- bool )
 529     nextchar BL =
 530     nextchar '\n' = or ;
 531
 532 : eof? ( -- bool )
 533     nextchar 4 = ;
 534
 535 : delim? ( -- bool )
 536     whitespace?
 537     nextchar [char] ( = or
 538     nextchar [char] ) = or
 539 ;
 540
 541 : commentstart? ( -- bool )
 542     nextchar [char] ; = ;
 543
 544 : eatspaces
 545
 546     false \ Indicates whether or not we're eating a comment
 547
 548     begin
 549         dup whitespace? or commentstart? or
 550     while
 551         dup nextchar '\n' = and if
 552             invert \ Stop eating comment
 553         else
 554             dup false = commentstart? and if
 555                 invert \ Begin eating comment
 556             then
 557         then
 558
 559         inc-parse-idx
 560     repeat
 561     drop
 562 ;
 563
 564 : digit? ( -- bool )
 565     nextchar [char] 0 >=
 566     nextchar [char] 9 <=
 567     and ;
 568
 569 : minus? ( -- bool )
 570     nextchar [char] - = ;
 571
 572 : plus? ( -- bool )
 573     nextchar [char] + = ;
 574
 575 : fixnum? ( -- bool )
 576     minus? plus? or if
 577         inc-parse-idx
 578
 579         delim? if
 580             dec-parse-idx
 581             false exit
 582         else
 583             dec-parse-idx
 584         then
 585     else
 586         digit? false = if
 587             false exit
 588         then
 589     then
 590
 591     push-parse-idx
 592     inc-parse-idx
 593
 594     begin digit? while
 595         inc-parse-idx
 596     repeat
 597
 598     delim? pop-parse-idx
 599 ;
 600
 601 : realnum? ( -- bool )
 602     push-parse-idx
 603
 604     minus? plus? or if
 605         inc-parse-idx
 606     then
 607
 608     \ Record starting parse idx:
 609     \ Want to detect whether any characters (following +/-) were eaten.
 610     parse-idx @
 611
 612     begin digit? while
 613             inc-parse-idx
 614     repeat
 615
 616     [char] . nextchar = if
 617         inc-parse-idx
 618         begin digit? while
 619                 inc-parse-idx
 620         repeat
 621     then
 622
 623     [char] e nextchar = [char] E nextchar = or if
 624         inc-parse-idx
 625
 626         minus? plus? or if
 627             inc-parse-idx
 628         then
 629
 630         digit? invert if
 631             drop pop-parse-idx false exit
 632         then
 633
 634         begin digit? while
 635                 inc-parse-idx
 636         repeat
 637     then
 638
 639     \ This is a real number if characters were
 640     \ eaten and the next characer is a delimiter.
 641     parse-idx @ < delim? and
 642
 643     pop-parse-idx
 644 ;
 645
 646 : boolean? ( -- bool )
 647     nextchar [char] # <> if false exit then
 648
 649     push-parse-idx
 650     inc-parse-idx
 651
 652     nextchar [char] t <>
 653     nextchar [char] f <>
 654     and if pop-parse-idx false exit then
 655
 656     inc-parse-idx
 657     delim? if
 658         pop-parse-idx
 659         true
 660     else
 661         pop-parse-idx
 662         false
 663     then
 664 ;
 665
 666 : str-equiv? ( str -- bool )
 667
 668     push-parse-idx
 669
 670     true -rot
 671
 672     swap dup rot + swap
 673
 674     do
 675         i @ nextchar <> if
 676             drop false
 677             leave
 678         then
 679
 680         inc-parse-idx
 681     loop
 682
 683     delim? false = if drop false then
 684
 685     pop-parse-idx
 686 ;
 687
 688 : character? ( -- bool )
 689     nextchar [char] # <> if false exit then
 690
 691     push-parse-idx
 692     inc-parse-idx
 693
 694     nextchar [char] \ <> if pop-parse-idx false exit then
 695
 696     inc-parse-idx
 697
 698     S" newline" str-equiv? if pop-parse-idx true exit then
 699     S" space" str-equiv? if pop-parse-idx true exit then
 700     S" tab" str-equiv? if pop-parse-idx true exit then
 701
 702     charavailable? false = if pop-parse-idx false exit then
 703
 704     pop-parse-idx true
 705 ;
 706
 707 : pair? ( -- bool )
 708     nextchar [char] ( = ;
 709
 710 : string? ( -- bool )
 711     nextchar [char] " = ;
 712
 713 : readfixnum ( -- num-atom )
 714     plus? minus? or if
 715         minus?
 716         inc-parse-idx
 717     else
 718         false
 719     then
 720
 721     0
 722
 723     begin digit? while
 724         10 * nextchar [char] 0 - +
 725         inc-parse-idx
 726     repeat
 727
 728     swap if negate then
 729
 730     fixnum-type
 731 ;
 732
 733 : readrealnum ( -- realnum )
 734
 735     \ Remember that at this point we're guaranteed to
 736     \ have a parsable real on this line.
 737
 738     parse-str parse-idx @ +
 739
 740     begin delim? false = while
 741             inc-parse-idx
 742     repeat
 743
 744     parse-str parse-idx @ + over -
 745
 746     float-parse
 747
 748     realnum-type
 749 ;
 750
 751 : readbool ( -- bool-atom )
 752     inc-parse-idx
 753
 754     nextchar [char] f = if
 755         false
 756     else
 757         true
 758     then
 759
 760     inc-parse-idx
 761
 762     boolean-type
 763 ;
 764
 765 : readchar ( -- char-atom )
 766     inc-parse-idx
 767     inc-parse-idx
 768
 769     S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
 770     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
 771     S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
 772
 773     nextchar character-type
 774
 775     inc-parse-idx
 776 ;
 777
 778 : readstring ( -- charlist )
 779     nextchar [char] " = if
 780         inc-parse-idx
 781
 782         delim? false = if
 783             bold fg red
 784             ." No delimiter following right double quote. Aborting." cr
 785             reset-term abort
 786         then
 787
 788         dec-parse-idx
 789
 790         0 nil-type exit
 791     then
 792
 793     nextchar [char] \ = if
 794         inc-parse-idx
 795         nextchar case
 796             [char] n of '\n' endof
 797             [char] " of [char] " endof
 798             [char] \
 799         endcase
 800     else
 801         nextchar
 802     then
 803     inc-parse-idx character-type
 804
 805     recurse
 806
 807     cons
 808 ;
 809
 810 : readsymbol ( -- charlist )
 811     delim? if nil exit then
 812
 813     nextchar inc-parse-idx character-type
 814
 815     recurse
 816
 817     cons
 818 ;
 819
 820 : readpair ( -- pairobj )
 821     eatspaces
 822
 823     \ Empty lists
 824     nextchar [char] ) = if
 825         inc-parse-idx
 826
 827         delim? false = if
 828             bold fg red
 829             ." No delimiter following right paren. Aborting." cr
 830             reset-term abort
 831         then
 832
 833         dec-parse-idx
 834
 835         0 nil-type exit
 836     then
 837
 838     \ Read first pair element
 839     read
 840
 841     \ Pairs
 842     eatspaces
 843     nextchar [char] . = if
 844         inc-parse-idx
 845
 846         delim? false = if
 847             bold fg red
 848             ." No delimiter following '.'. Aborting." cr
 849             reset-term abort
 850         then
 851
 852         eatspaces read
 853     else
 854         recurse
 855     then
 856
 857     eatspaces
 858
 859     cons
 860 ;
 861
 862 \ Parse a scheme expression
 863 :noname ( -- obj )
 864
 865     eatspaces
 866
 867     fixnum? if
 868         readfixnum
 869         exit
 870     then
 871
 872     realnum? if
 873         readrealnum
 874         exit
 875     then
 876
 877     boolean? if
 878         readbool
 879         exit
 880     then
 881
 882     character? if
 883         readchar
 884         exit
 885     then
 886
 887     string? if
 888         inc-parse-idx
 889
 890         readstring
 891         drop string-type
 892
 893         nextchar [char] " <> if
 894             bold red ." Missing closing double-quote." reset-term cr
 895             abort
 896         then
 897
 898         inc-parse-idx
 899
 900         exit
 901     then
 902
 903     pair? if
 904         inc-parse-idx
 905
 906         eatspaces
 907
 908         readpair
 909
 910         eatspaces
 911
 912         nextchar [char] ) <> if
 913             bold red ." Missing closing paren." reset-term cr
 914             abort
 915         then
 916
 917         inc-parse-idx
 918
 919         exit
 920     then
 921
 922     nextchar [char] ' = if
 923         inc-parse-idx
 924         quote-symbol recurse nil cons cons exit
 925     then
 926
 927     eof? if
 928         inc-parse-idx
 929         bold fg blue ." Moriturus te saluto." reset-term cr
 930         quit
 931     then
 932
 933     \ Anything else is parsed as a symbol
 934     readsymbol charlist>symbol
 935
 936     \ Replace λ with lambda
 937     2dup λ-symbol objeq? if
 938         2drop lambda-symbol
 939     then
 940
 941
 942 ; is read
 943
 944 \ }}}
 945
 946 \ ---- Eval ---- {{{
 947
 948 : self-evaluating? ( obj -- obj bool )
 949     boolean-type istype? if true exit then
 950     fixnum-type istype? if true exit then
 951     realnum-type istype? if true exit then
 952     character-type istype? if true exit then
 953     string-type istype? if true exit then
 954     nil-type istype? if true exit then
 955
 956     false
 957 ;
 958
 959 : tagged-list? ( obj tag-obj -- obj bool )
 960     2over
 961     pair-type istype? false = if
 962         2drop 2drop false
 963     else
 964         car objeq?
 965     then ;
 966
 967 : quote? ( obj -- obj bool )
 968     quote-symbol tagged-list?  ;
 969
 970 : quote-body ( quote-obj -- quote-body-obj )
 971     cadr ;
 972
 973 : variable? ( obj -- obj bool )
 974     symbol-type istype? ;
 975
 976 : definition? ( obj -- obj bool )
 977     define-symbol tagged-list? ;
 978
 979 : make-lambda ( params body -- lambda-exp )
 980     lambda-symbol -2rot cons cons ;
 981
 982 : definition-var ( obj -- var )
 983     cdr car
 984     symbol-type istype? false = if car then
 985 ;
 986
 987 : definition-val ( obj -- val )
 988     2dup cdr car symbol-type istype? if
 989         2drop
 990         cdr cdr car
 991     else
 992         cdr 2swap cdr cdr
 993         make-lambda
 994     then
 995 ;
 996
 997 : assignment? ( obj -- obj bool )
 998     set!-symbol tagged-list? ;
 999
1000 : assignment-var ( obj -- var )
1001     cdr car ;
1002
1003 : assignment-val ( obj -- val )
1004     cdr cdr car ;
1005
1006 : eval-definition ( obj env -- res )
1007     2swap
1008     2over 2over ( env obj env obj )
1009     definition-val 2swap ( env obj valexp env )
1010     eval  ( env obj val )
1011
1012     2swap definition-var 2swap ( env var val )
1013
1014     2rot ( var val env )
1015     define-var
1016
1017     ok-symbol
1018 ;
1019
1020 : eval-assignment ( obj env -- res )
1021     2swap
1022     2over 2over ( env obj env obj )
1023     assignment-val 2swap ( env obj valexp env )
1024     eval  ( env obj val )
1025
1026     2swap assignment-var 2swap ( env var val )
1027
1028     2rot ( var val env )
1029     set-var
1030
1031     ok-symbol
1032 ;
1033
1034 : if? ( obj -- obj bool )
1035     if-symbol tagged-list? ;
1036
1037 : if-predicate ( ifobj -- pred )
1038     cdr car ;
1039
1040 : if-consequent ( ifobj -- conseq )
1041     cdr cdr car ;
1042
1043 : if-alternative ( ifobj -- alt|false )
1044     cdr cdr cdr
1045     2dup nil objeq? if
1046         2drop false
1047     else
1048         car
1049     then ;
1050
1051 : false? ( boolobj -- boolean )
1052     boolean-type istype? if
1053         false boolean-type objeq?
1054     else
1055         2drop false
1056     then
1057 ;
1058
1059 : true? ( boolobj -- bool )
1060     false? invert ;
1061
1062 : lambda? ( obj -- obj bool )
1063     lambda-symbol tagged-list? ;
1064
1065 : lambda-parameters ( obj -- params )
1066     cdr car ;
1067
1068 : lambda-body ( obj -- body )
1069     cdr cdr ;
1070
1071 : make-procedure ( params body env -- proc )
1072     nil
1073     cons cons cons
1074     drop compound-proc-type
1075 ;
1076
1077 : application? ( obj -- obj bool)
1078     pair-type istype? ;
1079
1080 : operator ( obj -- operator )
1081     car ;
1082
1083 : operands ( obj -- operands )
1084     cdr ;
1085
1086 : nooperands? ( operands -- bool )
1087     nil objeq? ;
1088
1089 : first-operand ( operands -- operand )
1090     car ;
1091
1092 : rest-operands ( operands -- other-operands )
1093     cdr ;
1094
1095 : list-of-vals ( args env -- vals )
1096     2swap
1097
1098     2dup nooperands? if
1099         2swap 2drop
1100     else
1101         2over 2over first-operand 2swap eval
1102         -2rot rest-operands 2swap recurse
1103         cons
1104     then
1105 ;
1106
1107 : procedure-params ( proc -- params )
1108     drop pair-type car ;
1109
1110 : procedure-body ( proc -- body )
1111     drop pair-type cdr car ;
1112
1113 : procedure-env ( proc -- body )
1114     drop pair-type cdr cdr car ;
1115
1116 : apply ( proc args )
1117         2swap dup case
1118             primitive-proc-type of
1119                 drop execute
1120             endof
1121
1122             compound-proc-type of
1123                 2dup procedure-body ( args proc body )
1124                 -2rot 2dup procedure-params ( body args proc params )
1125                 -2rot procedure-env ( body params args procenv )
1126
1127                 extend-env ( body env )
1128
1129                 2swap ( env body )
1130
1131                 begin
1132                     2dup cdr 2dup nil objeq? false =
1133                 while
1134                     -2rot car 2over ( nextbody env exp env )
1135                     eval
1136                     2drop \ discard result
1137                     2swap ( env nextbody )
1138                 repeat
1139
1140                 2drop ( env body )
1141                 car 2swap ( exp env )
1142
1143                 R> drop ['] eval goto-deferred  \ Tail call optimization
1144             endof
1145
1146             bold fg red ." Object not applicable. Aboring." reset-term cr
1147             abort
1148         endcase
1149 ;
1150
1151 :noname ( obj env -- result )
1152     2swap
1153
1154     self-evaluating? if
1155         2swap 2drop
1156         exit
1157     then
1158
1159     quote? if
1160         quote-body
1161         2swap 2drop
1162         exit
1163     then
1164
1165     variable? if
1166         2swap lookup-var
1167         exit
1168     then
1169
1170     definition? if
1171         2swap eval-definition
1172         exit
1173     then
1174
1175     assignment? if
1176         2swap eval-assignment
1177         exit
1178     then
1179
1180     if? if
1181         2over 2over
1182         if-predicate
1183         2swap eval
1184
1185         true? if
1186             if-consequent
1187         else
1188             if-alternative
1189         then
1190
1191         2swap
1192         ['] eval goto-deferred
1193     then
1194
1195     lambda? if
1196         2dup lambda-parameters
1197         2swap lambda-body
1198         2rot make-procedure
1199         exit
1200     then
1201
1202     application? if
1203         2over 2over
1204         operator 2swap eval
1205         -2rot
1206         operands 2swap list-of-vals
1207
1208         apply
1209         exit
1210     then
1211
1212     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
1213     abort
1214 ; is eval
1215
1216 \ }}}
1217
1218 \ ---- Print ---- {{{
1219
1220 : printfixnum ( fixnumobj -- ) drop 0 .R ;
1221
1222 : printrealnum ( realnumobj -- ) drop float-print ;
1223
1224 : printbool ( numobj -- )
1225     drop if
1226         ." #t"
1227     else
1228         ." #f"
1229     then
1230 ;
1231
1232 : printchar ( charobj -- )
1233     drop
1234     case
1235         9 of ." #\tab" endof
1236         bl of ." #\space" endof
1237         '\n' of ." #\newline" endof
1238
1239         dup ." #\" emit
1240     endcase
1241 ;
1242
1243 : (printstring) ( stringobj -- )
1244     nil-type istype? if 2drop exit then
1245
1246     2dup car drop dup
1247     case
1248         '\n' of ." \n" drop endof
1249         [char] \ of ." \\" drop endof
1250         [char] " of [char] \ emit [char] " emit drop endof
1251         emit
1252     endcase
1253
1254     cdr recurse
1255 ;
1256 : printstring ( stringobj -- )
1257     [char] " emit
1258     (printstring)
1259     [char] " emit ;
1260
1261 : printsymbol ( symbolobj -- )
1262     nil-type istype? if 2drop exit then
1263
1264     2dup car drop emit
1265     cdr recurse
1266 ;
1267
1268 : printnil ( nilobj -- )
1269     2drop ." ()" ;
1270
1271 : printpair ( pairobj -- )
1272     2dup
1273     car print
1274     cdr
1275     nil-type istype? if 2drop exit then
1276     pair-type istype? if space recurse exit then
1277     ."  . " print
1278 ;
1279
1280 : printprim ( primobj -- )
1281     2drop ." <primitive procedure>" ;
1282
1283 : printcomp ( primobj -- )
1284     2drop ." <compound procedure>" ;
1285
1286 :noname ( obj -- )
1287     fixnum-type istype? if printfixnum exit then
1288     realnum-type istype? if printrealnum exit then
1289     boolean-type istype? if printbool exit then
1290     character-type istype? if printchar exit then
1291     string-type istype? if printstring exit then
1292     symbol-type istype? if printsymbol exit then
1293     nil-type istype? if printnil exit then
1294     pair-type istype? if ." (" printpair ." )" exit then
1295     primitive-proc-type istype? if printprim exit then
1296     compound-proc-type istype? if printcomp exit then
1297
1298     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
1299     abort
1300 ; is print
1301
1302 \ }}}
1303
1304 \ ---- DEBUGGING ---- {{{
1305
1306 false value debug-mode
1307
1308 :noname
1309     debug-mode if
1310         ." Object: " 2dup cr print cr
1311         ." Pairlike: " pairlike? if
1312             ." TRUE"
1313             pairlike-marked? if
1314                 ."  (Marked)"
1315             else
1316                 ."  (Unmarked)"
1317             then
1318         else
1319             ." FALSE"
1320         then
1321         cr ." [paused]"
1322         key drop cr
1323     then
1324 ; is gc-mark-trace
1325
1326 : gc-mark-sweep
1327     gc-unmark
1328     symbol-table obj@ gc-mark-obj
1329     global-env obj@ gc-mark-obj
1330     gc-sweep
1331 ;
1332
1333 : gc-count-marked
1334     0
1335     scheme-memsize 0 do
1336         nextfrees i + @ 0= if 1+ then
1337     loop
1338 ;
1339
1340 : gc-zero-unmarked
1341     scheme-memsize 0 do
1342         nextfrees i + @ 0<> if
1343             0 car-cells i + !
1344             0 cdr-cells i + !
1345         then
1346     loop
1347 ;
1348
1349 \ }}}
1350
1351
1352 \ ---- REPL ----
1353
1354 : repl
1355     cr ." Welcome to scheme.forth.jl!" cr
1356        ." Use Ctrl-D to exit." cr
1357
1358
1359     empty-parse-str
1360
1361     begin
1362         cr bold fg green ." > " reset-term
1363         read
1364
1365         global-env obj@ eval
1366
1367         fg cyan ." ; " print reset-term
1368     again
1369 ;
1370
1371 forth definitions
1372
1373 \ vim:fdm=marker