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