scheme.4th

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