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