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     \ Record starting parse idx:
 517     \ Want to detect whether any characters were eaten.
 518     parse-idx @
 519
 520     push-parse-idx
 521
 522     minus? plus? or if
 523         inc-parse-idx
 524     then
 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         begin digit? while
 545                 inc-parse-idx
 546         repeat
 547     then
 548
 549     \ This is a real number if characters were
 550     \ eaten and the next characer is a delimiter.
 551     parse-idx @ < delim? and
 552
 553     pop-parse-idx
 554 ;
 555
 556 : boolean? ( -- bool )
 557     nextchar [char] # <> if false exit then
 558
 559     push-parse-idx
 560     inc-parse-idx
 561
 562     nextchar [char] t <>
 563     nextchar [char] f <>
 564     and if pop-parse-idx false exit then
 565
 566     inc-parse-idx
 567     delim? if
 568         pop-parse-idx
 569         true
 570     else
 571         pop-parse-idx
 572         false
 573     then
 574 ;
 575
 576 : str-equiv? ( str -- bool )
 577
 578     push-parse-idx
 579
 580     true -rot
 581
 582     swap dup rot + swap
 583
 584     do
 585         i @ nextchar <> if
 586             drop false
 587             leave
 588         then
 589
 590         inc-parse-idx
 591     loop
 592
 593     delim? false = if drop false then
 594
 595     pop-parse-idx
 596 ;
 597
 598 : character? ( -- bool )
 599     nextchar [char] # <> if false exit then
 600
 601     push-parse-idx
 602     inc-parse-idx
 603
 604     nextchar [char] \ <> if pop-parse-idx false exit then
 605
 606     inc-parse-idx
 607
 608     S" newline" str-equiv? if pop-parse-idx true exit then
 609     S" space" str-equiv? if pop-parse-idx true exit then
 610     S" tab" str-equiv? if pop-parse-idx true exit then
 611
 612     charavailable? false = if pop-parse-idx false exit then
 613
 614     pop-parse-idx true
 615 ;
 616
 617 : pair? ( -- bool )
 618     nextchar [char] ( = ;
 619
 620 : string? ( -- bool )
 621     nextchar [char] " = ;
 622
 623 : readfixnum ( -- num-atom )
 624     plus? minus? or if
 625         minus?
 626         inc-parse-idx
 627     else
 628         false
 629     then
 630
 631     0
 632
 633     begin digit? while
 634         10 * nextchar [char] 0 - +
 635         inc-parse-idx
 636     repeat
 637
 638     swap if negate then
 639
 640     fixnum-type
 641 ;
 642
 643 : readrealnum ( -- realnum )
 644
 645     \ Remember that at this point we're guaranteed to
 646     \ have a parsable real on this line.
 647
 648     parse-str parse-idx @ +
 649
 650     begin delim? false = while
 651             inc-parse-idx
 652     repeat
 653
 654     parse-str parse-idx @ + over -
 655
 656     float-parse
 657
 658     realnum-type
 659 ;
 660
 661 : readbool ( -- bool-atom )
 662     inc-parse-idx
 663
 664     nextchar [char] f = if
 665         false
 666     else
 667         true
 668     then
 669
 670     inc-parse-idx
 671
 672     boolean-type
 673 ;
 674
 675 : readchar ( -- char-atom )
 676     inc-parse-idx
 677     inc-parse-idx
 678
 679     S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
 680     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
 681     S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
 682
 683     nextchar character-type
 684
 685     inc-parse-idx
 686 ;
 687
 688 : readstring ( -- charlist )
 689     nextchar [char] " = if
 690         inc-parse-idx
 691
 692         delim? false = if
 693             bold fg red
 694             ." No delimiter following right double quote. Aborting." cr
 695             reset-term abort
 696         then
 697
 698         dec-parse-idx
 699
 700         0 nil-type exit
 701     then
 702
 703     nextchar [char] \ = if
 704         inc-parse-idx
 705         nextchar case
 706             [char] n of '\n' endof
 707             [char] " of [char] " endof
 708             [char] \
 709         endcase
 710     else
 711         nextchar
 712     then
 713     inc-parse-idx character-type
 714
 715     recurse
 716
 717     cons
 718 ;
 719
 720 : readsymbol ( -- charlist )
 721     delim? if nil exit then
 722
 723     nextchar inc-parse-idx character-type
 724
 725     recurse
 726
 727     cons
 728 ;
 729
 730 : readpair ( -- pairobj )
 731     eatspaces
 732
 733     \ Empty lists
 734     nextchar [char] ) = if
 735         inc-parse-idx
 736
 737         delim? false = if
 738             bold fg red
 739             ." No delimiter following right paren. Aborting." cr
 740             reset-term abort
 741         then
 742
 743         dec-parse-idx
 744
 745         0 nil-type exit
 746     then
 747
 748     \ Read first pair element
 749     read
 750
 751     \ Pairs
 752     eatspaces
 753     nextchar [char] . = if
 754         inc-parse-idx
 755
 756         delim? false = if
 757             bold fg red
 758             ." No delimiter following '.'. Aborting." cr
 759             reset-term abort
 760         then
 761
 762         eatspaces read
 763     else
 764         recurse
 765     then
 766
 767     eatspaces
 768
 769     cons
 770 ;
 771
 772 \ Parse a scheme expression
 773 :noname ( -- obj )
 774
 775     eatspaces
 776
 777     fixnum? if
 778         readfixnum
 779         exit
 780     then
 781
 782     realnum? if
 783         readrealnum
 784         exit
 785     then
 786
 787     boolean? if
 788         readbool
 789         exit
 790     then
 791
 792     character? if
 793         readchar
 794         exit
 795     then
 796
 797     string? if
 798         inc-parse-idx
 799
 800         readstring
 801         drop string-type
 802
 803         nextchar [char] " <> if
 804             bold red ." Missing closing double-quote." reset-term cr
 805             abort
 806         then
 807
 808         inc-parse-idx
 809
 810         exit
 811     then
 812
 813     pair? if
 814         inc-parse-idx
 815
 816         eatspaces
 817
 818         readpair
 819
 820         eatspaces
 821
 822         nextchar [char] ) <> if
 823             bold red ." Missing closing paren." reset-term cr
 824             abort
 825         then
 826
 827         inc-parse-idx
 828
 829         exit
 830     then
 831
 832     nextchar [char] ' = if
 833         inc-parse-idx
 834         quote-symbol recurse nil cons cons exit
 835     then
 836
 837     eof? if
 838         inc-parse-idx
 839         bold fg blue ." Moriturus te saluto." reset-term ."  ok" cr
 840         quit
 841     then
 842
 843     \ Anything else is parsed as a symbol
 844     readsymbol charlist>symbol
 845
 846     \ Replace λ with lambda
 847     2dup λ-symbol objeq? if
 848         2drop lambda-symbol
 849     then
 850
 851
 852 ; is read
 853
 854 \ }}}
 855
 856 \ ---- Eval ---- {{{
 857
 858 : self-evaluating? ( obj -- obj bool )
 859     boolean-type istype? if true exit then
 860     fixnum-type istype? if true exit then
 861     realnum-type istype? if true exit then
 862     character-type istype? if true exit then
 863     string-type istype? if true exit then
 864     nil-type istype? if true exit then
 865
 866     false
 867 ;
 868
 869 : tagged-list? ( obj tag-obj -- obj bool )
 870     2over
 871     pair-type istype? false = if
 872         2drop 2drop false
 873     else
 874         car objeq?
 875     then ;
 876
 877 : quote? ( obj -- obj bool )
 878     quote-symbol tagged-list?  ;
 879
 880 : quote-body ( quote-obj -- quote-body-obj )
 881     cadr ;
 882
 883 : variable? ( obj -- obj bool )
 884     symbol-type istype? ;
 885
 886 : definition? ( obj -- obj bool )
 887     define-symbol tagged-list? ;
 888
 889 : make-lambda ( params body -- lambda-exp )
 890     lambda-symbol -2rot cons cons ;
 891
 892 : definition-var ( obj -- var )
 893     cdr car
 894     symbol-type istype? false = if car then
 895 ;
 896
 897 : definition-val ( obj -- val )
 898     2dup cdr car symbol-type istype? if
 899         2drop
 900         cdr cdr car
 901     else
 902         cdr 2swap cdr cdr
 903         make-lambda
 904     then
 905 ;
 906
 907 : assignment? ( obj -- obj bool )
 908     set!-symbol tagged-list? ;
 909
 910 : assignment-var ( obj -- var )
 911     cdr car ;
 912
 913 : assignment-val ( obj -- val )
 914     cdr cdr car ;
 915
 916 : eval-definition ( obj env -- res )
 917     2swap
 918     2over 2over ( env obj env obj )
 919     definition-val 2swap ( env obj valexp env )
 920     eval  ( env obj val )
 921
 922     2swap definition-var 2swap ( env var val )
 923
 924     2rot ( var val env )
 925     define-var
 926
 927     ok-symbol
 928 ;
 929
 930 : eval-assignment ( obj env -- res )
 931     2swap
 932     2over 2over ( env obj env obj )
 933     assignment-val 2swap ( env obj valexp env )
 934     eval  ( env obj val )
 935
 936     2swap assignment-var 2swap ( env var val )
 937
 938     2rot ( var val env )
 939     set-var
 940
 941     ok-symbol
 942 ;
 943
 944 : if? ( obj -- obj bool )
 945     if-symbol tagged-list? ;
 946
 947 : if-predicate ( ifobj -- pred )
 948     cdr car ;
 949
 950 : if-consequent ( ifobj -- conseq )
 951     cdr cdr car ;
 952
 953 : if-alternative ( ifobj -- alt|false )
 954     cdr cdr cdr
 955     2dup nil objeq? if
 956         2drop false
 957     else
 958         car
 959     then ;
 960
 961 : false? ( boolobj -- boolean )
 962     boolean-type istype? if
 963         false boolean-type objeq?
 964     else
 965         2drop false
 966     then
 967 ;
 968
 969 : true? ( boolobj -- bool )
 970     false? invert ;
 971
 972 : lambda? ( obj -- obj bool )
 973     lambda-symbol tagged-list? ;
 974
 975 : lambda-parameters ( obj -- params )
 976     cdr car ;
 977
 978 : lambda-body ( obj -- body )
 979     cdr cdr ;
 980
 981 : make-procedure ( params body env -- proc )
 982     nil
 983     cons cons cons
 984     drop compound-proc-type
 985 ;
 986
 987 : application? ( obj -- obj bool)
 988     pair-type istype? ;
 989
 990 : operator ( obj -- operator )
 991     car ;
 992
 993 : operands ( obj -- operands )
 994     cdr ;
 995
 996 : nooperands? ( operands -- bool )
 997     nil objeq? ;
 998
 999 : first-operand ( operands -- operand )
1000     car ;
1001
1002 : rest-operands ( operands -- other-operands )
1003     cdr ;
1004
1005 : list-of-vals ( args env -- vals )
1006     2swap
1007
1008     2dup nooperands? if
1009         2swap 2drop
1010     else
1011         2over 2over first-operand 2swap eval
1012         -2rot rest-operands 2swap recurse
1013         cons
1014     then
1015 ;
1016
1017 : procedure-params ( proc -- params )
1018     drop pair-type car ;
1019
1020 : procedure-body ( proc -- body )
1021     drop pair-type cdr car ;
1022
1023 : procedure-env ( proc -- body )
1024     drop pair-type cdr cdr car ;
1025
1026 : apply ( proc args )
1027         2swap dup case
1028             primitive-proc-type of
1029                 drop execute
1030             endof
1031
1032             compound-proc-type of
1033                 2dup procedure-body ( args proc body )
1034                 -2rot 2dup procedure-params ( body args proc params )
1035                 -2rot procedure-env ( body params args procenv )
1036
1037                 extend-env ( body env )
1038
1039                 2swap ( env body )
1040
1041                 begin
1042                     2dup cdr 2dup nil objeq? false =
1043                 while
1044                     -2rot car 2over ( nextbody env exp env )
1045                     eval
1046                     2drop \ discard result
1047                     2swap ( env nextbody )
1048                 repeat
1049
1050                 2drop ( env body )
1051                 car 2swap ( exp env )
1052
1053                 R> drop ['] eval goto-deferred  \ Tail call optimization
1054             endof
1055
1056             bold fg red ." Object not applicable. Aboring." reset-term cr
1057             abort
1058         endcase
1059 ;
1060
1061 :noname ( obj env -- result )
1062     2swap
1063
1064     self-evaluating? if
1065         2swap 2drop
1066         exit
1067     then
1068
1069     quote? if
1070         quote-body
1071         2swap 2drop
1072         exit
1073     then
1074
1075     variable? if
1076         2swap lookup-var
1077         exit
1078     then
1079
1080     definition? if
1081         2swap eval-definition
1082         exit
1083     then
1084
1085     assignment? if
1086         2swap eval-assignment
1087         exit
1088     then
1089
1090     if? if
1091         2over 2over
1092         if-predicate
1093         2swap eval
1094
1095         true? if
1096             if-consequent
1097         else
1098             if-alternative
1099         then
1100
1101         2swap
1102         ['] eval goto-deferred
1103     then
1104
1105     lambda? if
1106         2dup lambda-parameters
1107         2swap lambda-body
1108         2rot make-procedure
1109         exit
1110     then
1111
1112     application? if
1113         2over 2over
1114         operator 2swap eval
1115         -2rot
1116         operands 2swap list-of-vals
1117
1118         apply
1119         exit
1120     then
1121
1122     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
1123     abort
1124 ; is eval
1125
1126 \ }}}
1127
1128 \ ---- Print ---- {{{
1129
1130 : printfixnum ( fixnumobj -- ) drop 0 .R ;
1131
1132 : printrealnum ( realnumobj -- ) drop float-print ;
1133
1134 : printbool ( numobj -- )
1135     drop if
1136         ." #t"
1137     else
1138         ." #f"
1139     then
1140 ;
1141
1142 : printchar ( charobj -- )
1143     drop
1144     case
1145         9 of ." #\tab" endof
1146         bl of ." #\space" endof
1147         '\n' of ." #\newline" endof
1148
1149         dup ." #\" emit
1150     endcase
1151 ;
1152
1153 : (printstring) ( stringobj -- )
1154     nil-type istype? if 2drop exit then
1155
1156     2dup car drop dup
1157     case
1158         '\n' of ." \n" drop endof
1159         [char] \ of ." \\" drop endof
1160         [char] " of [char] \ emit [char] " emit drop endof
1161         emit
1162     endcase
1163
1164     cdr recurse
1165 ;
1166 : printstring ( stringobj -- )
1167     [char] " emit
1168     (printstring)
1169     [char] " emit ;
1170
1171 : printsymbol ( symbolobj -- )
1172     nil-type istype? if 2drop exit then
1173
1174     2dup car drop emit
1175     cdr recurse
1176 ;
1177
1178 : printnil ( nilobj -- )
1179     2drop ." ()" ;
1180
1181 : printpair ( pairobj -- )
1182     2dup
1183     car print
1184     cdr
1185     nil-type istype? if 2drop exit then
1186     pair-type istype? if space recurse exit then
1187     ."  . " print
1188 ;
1189
1190 : printprim ( primobj -- )
1191     2drop ." <primitive procedure>" ;
1192
1193 : printcomp ( primobj -- )
1194     2drop ." <compound procedure>" ;
1195
1196 :noname ( obj -- )
1197     fixnum-type istype? if printfixnum exit then
1198     realnum-type istype? if printrealnum exit then
1199     boolean-type istype? if printbool exit then
1200     character-type istype? if printchar exit then
1201     string-type istype? if printstring exit then
1202     symbol-type istype? if printsymbol exit then
1203     nil-type istype? if printnil exit then
1204     pair-type istype? if ." (" printpair ." )" exit then
1205     primitive-proc-type istype? if printprim exit then
1206     compound-proc-type istype? if printcomp exit then
1207
1208     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
1209     abort
1210 ; is print
1211
1212 \ }}}
1213
1214 \ ---- REPL ----
1215
1216 : repl
1217     cr ." Welcome to scheme.forth.jl!" cr
1218        ." Use Ctrl-D to exit." cr
1219
1220     empty-parse-str
1221
1222     begin
1223         cr bold fg green ." > " reset-term
1224         read
1225         global-env obj@ eval
1226         fg cyan ." ; " print reset-term
1227     again
1228 ;
1229
1230 forth definitions
1231
1232 \ vim:fdm=marker