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