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