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