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