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