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