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