scheme.4th

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