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