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