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