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 : eatspaces
 381     begin
 382         whitespace?
 383     while
 384         inc-parse-idx
 385     repeat
 386 ;
 387
 388 : digit? ( -- bool )
 389     nextchar [char] 0 >=
 390     nextchar [char] 9 <=
 391     and ;
 392
 393 : minus? ( -- bool )
 394     nextchar [char] - = ;
 395
 396 : fixnum? ( -- bool )
 397     minus? if
 398         inc-parse-idx
 399
 400         delim? if
 401             dec-parse-idx
 402             false exit
 403         else
 404             dec-parse-idx
 405         then
 406     else
 407         digit? false = if
 408             false exit
 409         then
 410     then
 411
 412     push-parse-idx
 413     inc-parse-idx
 414
 415     begin digit? while
 416         inc-parse-idx
 417     repeat
 418
 419     delim? if
 420         pop-parse-idx
 421         true
 422     else
 423         pop-parse-idx
 424         false
 425     then
 426 ;
 427
 428 : boolean? ( -- bool )
 429     nextchar [char] # <> if false exit then
 430
 431     push-parse-idx
 432     inc-parse-idx
 433
 434     nextchar [char] t <>
 435     nextchar [char] f <>
 436     and if pop-parse-idx false exit then
 437
 438     inc-parse-idx
 439     delim? if
 440         pop-parse-idx
 441         true
 442     else
 443         pop-parse-idx
 444         false
 445     then
 446 ;
 447
 448 : str-equiv? ( str -- bool )
 449
 450     push-parse-idx
 451
 452     true -rot
 453
 454     swap dup rot + swap
 455
 456     do
 457         i @ nextchar <> if
 458             drop false
 459             leave
 460         then
 461
 462         inc-parse-idx
 463     loop
 464
 465     delim? false = if drop false then
 466
 467     pop-parse-idx
 468 ;
 469
 470 : character? ( -- bool )
 471     nextchar [char] # <> if false exit then
 472
 473     push-parse-idx
 474     inc-parse-idx
 475
 476     nextchar [char] \ <> if pop-parse-idx false exit then
 477
 478     inc-parse-idx
 479
 480     S" newline" str-equiv? if pop-parse-idx true exit then
 481     S" space" str-equiv? if pop-parse-idx true exit then
 482     S" tab" str-equiv? if pop-parse-idx true exit then
 483
 484     charavailable? false = if pop-parse-idx false exit then
 485
 486     pop-parse-idx true
 487 ;
 488
 489 : pair? ( -- bool )
 490     nextchar [char] ( = ;
 491
 492 : string? ( -- bool )
 493     nextchar [char] " = ;
 494
 495 : readnum ( -- num-atom )
 496     minus? dup if
 497         inc-parse-idx
 498     then
 499
 500     0
 501
 502     begin digit? while
 503         10 * nextchar [char] 0 - +
 504         inc-parse-idx
 505     repeat
 506
 507     swap if negate then
 508
 509     fixnum-type
 510 ;
 511
 512 : readbool ( -- bool-atom )
 513     inc-parse-idx
 514
 515     nextchar [char] f = if
 516         false
 517     else
 518         true
 519     then
 520
 521     inc-parse-idx
 522
 523     boolean-type
 524 ;
 525
 526 : readchar ( -- char-atom )
 527     inc-parse-idx
 528     inc-parse-idx
 529
 530     S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
 531     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
 532     S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
 533
 534     nextchar character-type
 535
 536     inc-parse-idx
 537 ;
 538
 539 : readstring ( -- charlist )
 540     nextchar [char] " = if
 541         inc-parse-idx
 542
 543         delim? false = if
 544             bold fg red
 545             ." No delimiter following right double quote. Aborting." cr
 546             reset-term abort
 547         then
 548
 549         dec-parse-idx
 550
 551         0 nil-type exit
 552     then
 553
 554     nextchar [char] \ = if
 555         inc-parse-idx
 556         nextchar case
 557             [char] n of '\n' endof
 558             [char] " of [char] " endof
 559             [char] \
 560         endcase
 561     else
 562         nextchar
 563     then
 564     inc-parse-idx character-type
 565
 566     recurse
 567
 568     cons
 569 ;
 570
 571 : readsymbol ( -- charlist )
 572     delim? if nil exit then
 573
 574     nextchar inc-parse-idx character-type
 575
 576     recurse
 577
 578     cons
 579 ;
 580
 581 : charlist-equiv ( charlist charlist -- bool )
 582
 583     2over 2over
 584
 585     \ One or both nil
 586     nil? -rot 2drop
 587     if
 588         nil? -rot 2drop
 589         if
 590             2drop 2drop true exit
 591         else
 592             2drop 2drop false exit
 593         then
 594     else
 595         nil? -rot 2drop
 596         if
 597             2drop 2drop false exit
 598         then
 599     then
 600
 601     2over 2over
 602
 603     \ Neither nil
 604     car drop -rot car drop = if
 605             cdr 2swap cdr recurse
 606         else
 607             2drop 2drop false
 608     then
 609 ;
 610
 611 : charlist>symbol ( charlist -- symbol-obj )
 612
 613     symbol-table fetchobj
 614
 615     begin
 616         nil? false =
 617     while
 618         2over 2over
 619         car drop pair-type
 620         charlist-equiv if
 621             2swap 2drop
 622             car
 623             exit
 624         else
 625             cdr
 626         then
 627     repeat
 628
 629     2drop
 630     drop symbol-type 2dup
 631     symbol-table fetchobj cons
 632     symbol-table setobj
 633 ;
 634
 635 : readpair ( -- pairobj )
 636     eatspaces
 637
 638     \ Empty lists
 639     nextchar [char] ) = if
 640         inc-parse-idx
 641
 642         delim? false = if
 643             bold fg red
 644             ." No delimiter following right paren. Aborting." cr
 645             reset-term abort
 646         then
 647
 648         dec-parse-idx
 649
 650         0 nil-type exit
 651     then
 652
 653     \ Read first pair element
 654     read
 655
 656     \ Pairs
 657     eatspaces
 658     nextchar [char] . = if
 659         inc-parse-idx
 660
 661         delim? false = if
 662             bold fg red
 663             ." No delimiter following '.'. Aborting." cr
 664             reset-term abort
 665         then
 666
 667         eatspaces read
 668     else
 669         recurse
 670     then
 671
 672     eatspaces
 673
 674     cons
 675 ;
 676
 677 \ Parse a scheme expression
 678 :noname ( -- obj )
 679
 680     eatspaces
 681
 682     fixnum? if
 683         readnum
 684         exit
 685     then
 686
 687     boolean? if
 688         readbool
 689         exit
 690     then
 691
 692     character? if
 693         readchar
 694         exit
 695     then
 696
 697     string? if
 698         inc-parse-idx
 699
 700         readstring
 701         drop string-type
 702
 703         nextchar [char] " <> if
 704             bold red ." Missing closing double-quote." reset-term cr
 705             abort
 706         then
 707
 708         inc-parse-idx
 709
 710         exit
 711     then
 712
 713     pair? if
 714         inc-parse-idx
 715
 716         eatspaces
 717
 718         readpair
 719
 720         eatspaces
 721
 722         nextchar [char] ) <> if
 723             bold red ." Missing closing paren." reset-term cr
 724             abort
 725         then
 726
 727         inc-parse-idx
 728
 729         exit
 730     then
 731
 732     nextchar [char] ' = if
 733         inc-parse-idx
 734         quote-symbol recurse nil cons cons exit
 735     then
 736
 737     eof? if
 738         bold fg blue ." Moriturus te saluto." reset-term ."  ok" cr
 739         quit
 740     then
 741
 742     \ Anything else is parsed as a symbol
 743     readsymbol charlist>symbol
 744
 745 ; is read
 746
 747 \ }}}
 748
 749 \ ---- Eval ---- {{{
 750
 751 defer eval
 752
 753 : self-evaluating? ( obj -- obj bool )
 754     boolean-type istype? if true exit then
 755     fixnum-type istype? if true exit then
 756     character-type istype? if true exit then
 757     string-type istype? if true exit then
 758     nil-type istype? if true exit then
 759
 760     false
 761 ;
 762
 763 : tagged-list? ( obj tag-obj -- obj bool )
 764     2over
 765     pair-type istype? false = if
 766         2drop 2drop false
 767     else
 768         car objeq?
 769     then ;
 770
 771 : quote? ( obj -- obj bool )
 772     quote-symbol tagged-list?  ;
 773
 774 : quote-body ( quote-obj -- quote-body-obj )
 775     cadr ;
 776
 777 : variable? ( obj -- obj bool )
 778     symbol-type istype? ;
 779
 780 : definition? ( obj -- obj bool )
 781     define-symbol tagged-list? ;
 782
 783 : definition-var ( obj -- var )
 784     cdr car ;
 785
 786 : definition-val ( obj -- val )
 787     cdr cdr car ;
 788
 789 : assignment? ( obj -- obj bool )
 790     set!-symbol tagged-list? ;
 791
 792 : assignment-var ( obj -- var )
 793     cdr car ;
 794
 795 : assignment-val ( obj -- val )
 796     cdr cdr car ;
 797
 798 : eval-definition ( obj env -- res )
 799     2swap
 800     2over 2over ( env obj env obj )
 801     definition-val 2swap ( env obj valexp env )
 802     eval  ( env obj val )
 803
 804     2swap definition-var 2swap ( env var val )
 805
 806     2rot ( var val env )
 807     define-var
 808
 809     ok-symbol
 810 ;
 811
 812 : eval-assignment ( obj env -- res )
 813     2swap
 814     2over 2over ( env obj env obj )
 815     assignment-val 2swap ( env obj valexp env )
 816     eval  ( env obj val )
 817
 818     2swap assignment-var 2swap ( env var val )
 819
 820     2rot ( var val env )
 821     set-var
 822
 823     ok-symbol
 824 ;
 825
 826 : if? ( obj -- obj bool )
 827     if-symbol tagged-list? ;
 828
 829 : if-predicate ( ifobj -- pred )
 830     cdr car ;
 831
 832 : if-consequent ( ifobj -- conseq )
 833     cdr cdr car ;
 834
 835 : if-alternative ( ifobj -- alt|false )
 836     cdr cdr cdr
 837     2dup nil objeq? if
 838         2drop false
 839     else
 840         car
 841     then ;
 842
 843 : false? ( boolobj -- boolean )
 844     boolean-type istype? if
 845         false boolean-type objeq?
 846     else
 847         2drop false
 848     then
 849 ;
 850
 851 : true? ( boolobj -- bool )
 852     false? invert ;
 853
 854 : application? ( obj -- obj bool)
 855     pair-type istype? ;
 856
 857 : operator ( obj -- operator )
 858     car ;
 859
 860 : operands ( obj -- operands )
 861     cdr ;
 862
 863 : nooperands? ( operands -- bool )
 864     nil objeq? ;
 865
 866 : first-operand ( operands -- operand )
 867     car ;
 868
 869 : rest-operands ( operands -- other-operands )
 870     cdr ;
 871
 872 : list-of-vals ( args env -- vals )
 873     2swap
 874
 875     2dup nooperands? if
 876         2swap 2drop
 877     else
 878         2over 2over first-operand 2swap eval
 879         -2rot rest-operands 2swap recurse
 880         cons
 881     then
 882 ;
 883
 884 :noname ( obj env -- result )
 885     2swap
 886
 887     self-evaluating? if
 888         2swap 2drop
 889         exit
 890     then
 891
 892     quote? if
 893         quote-body
 894         2swap 2drop
 895         exit
 896     then
 897
 898     variable? if
 899         2swap lookup-var
 900         exit
 901     then
 902
 903     definition? if
 904         2swap eval-definition
 905         exit
 906     then
 907
 908     assignment? if
 909         2swap eval-assignment
 910         exit
 911     then
 912
 913     if? if
 914         2over 2over
 915         if-predicate
 916         2swap eval
 917
 918         true? if
 919             if-consequent
 920         else
 921             if-alternative
 922         then
 923
 924         2swap ['] eval goto
 925     then
 926
 927     application? if
 928         2over 2over
 929         operator 2swap eval
 930
 931         primitive-type istype? false = if
 932             bold fg red ." Object not applicable. Aboring." reset-term cr
 933             abort
 934         then
 935
 936         -2rot
 937         operands 2swap list-of-vals
 938
 939         2swap drop execute
 940         exit
 941     then
 942
 943     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
 944     abort
 945 ; is eval
 946
 947 \ }}}
 948
 949 \ ---- Print ---- {{{
 950
 951 defer print
 952
 953 : printnum ( numobj -- ) drop 0 .R ;
 954
 955 : printbool ( numobj -- )
 956     drop if
 957         ." #t"
 958     else
 959         ." #f"
 960     then
 961 ;
 962
 963 : printchar ( charobj -- )
 964     drop
 965     case
 966         9 of ." #\tab" endof
 967         bl of ." #\space" endof
 968         '\n' of ." #\newline" endof
 969
 970         dup ." #\" emit
 971     endcase
 972 ;
 973
 974 : (printstring) ( stringobj -- )
 975     nil-type istype? if 2drop exit then
 976
 977     2dup car drop dup
 978     case
 979         '\n' of ." \n" drop endof
 980         [char] \ of ." \\" drop endof
 981         [char] " of [char] \ emit [char] " emit drop endof
 982         emit
 983     endcase
 984
 985     cdr recurse
 986 ;
 987 : printstring ( stringobj -- )
 988     [char] " emit
 989     (printstring)
 990     [char] " emit ;
 991
 992 : printsymbol ( symbolobj -- )
 993     nil-type istype? if 2drop exit then
 994
 995     2dup car drop emit
 996     cdr recurse
 997 ;
 998
 999 : printnil ( nilobj -- )
1000     2drop ." ()" ;
1001
1002 : printpair ( pairobj -- )
1003     2dup
1004     car print
1005     cdr
1006     nil-type istype? if 2drop exit then
1007     pair-type istype? if space recurse exit then
1008     ."  . " print
1009 ;
1010
1011 : printprim ( primobj -- )
1012     2drop ." <primitive procedure>" ;
1013
1014 :noname ( obj -- )
1015     fixnum-type istype? if printnum exit then
1016     boolean-type istype? if printbool exit then
1017     character-type istype? if printchar exit then
1018     string-type istype? if printstring exit then
1019     symbol-type istype? if printsymbol exit then
1020     nil-type istype? if printnil exit then
1021     pair-type istype? if ." (" printpair ." )" exit then
1022     primitive-type istype? if printprim exit then
1023
1024     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
1025     abort
1026 ; is print
1027
1028 \ }}}
1029
1030 \ ---- REPL ----
1031
1032 : repl
1033     cr ." Welcome to scheme.forth.jl!" cr
1034        ." Use Ctrl-D to exit." cr
1035
1036     empty-parse-str
1037
1038     begin
1039         cr bold fg green ." > " reset-term
1040         read
1041         global-env fetchobj eval
1042         fg cyan ." ; " print reset-term
1043     again
1044 ;
1045
1046 forth definitions
1047
1048 \ vim:fdm=marker