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