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