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