scheme.4th

   1 vocabulary scheme
   2 scheme definitions
   3
   4 include term-colours.4th
   5 include defer-is.4th
   6 include float.4th
   7
   8 include debugging.4th
   9
  10 defer read
  11 defer eval
  12 defer print
  13
  14 defer collect-garbage
  15
  16 \ ------ Types ------
  17
  18 variable nexttype
  19 0 nexttype !
  20 : make-type
  21     create nexttype @ ,
  22     1 nexttype +!
  23     does> @ ;
  24
  25 make-type fixnum-type
  26 make-type realnum-type
  27 make-type boolean-type
  28 make-type character-type
  29 make-type string-type
  30 make-type nil-type
  31 make-type none-type
  32 make-type pair-type
  33 make-type symbol-type
  34 make-type primitive-proc-type
  35 make-type compound-proc-type
  36 make-type fileport-type
  37 : istype? ( obj type -- obj bool )
  38     over = ;
  39
  40 \ ---- List-structured memory ---- {{{
  41
  42 10000 constant scheme-memsize
  43
  44 create car-cells scheme-memsize allot
  45 create car-type-cells scheme-memsize allot
  46 create cdr-cells scheme-memsize allot
  47 create cdr-type-cells scheme-memsize allot
  48
  49 create nextfrees scheme-memsize allot
  50 :noname
  51     scheme-memsize 0 do
  52         i 1+ nextfrees i + !
  53     loop
  54 ; execute
  55
  56 variable nextfree
  57 0 nextfree !
  58
  59 : inc-nextfree
  60     nextfrees nextfree @ + @
  61     nextfree !
  62
  63     nextfree @ scheme-memsize >= if
  64         collect-garbage
  65     then
  66
  67     nextfree @ scheme-memsize >= if
  68         fg red bold
  69         ." Out of memory! Aborting."
  70         reset-term abort
  71     then
  72 ;
  73
  74 : cons ( car-obj cdr-obj -- pair-obj )
  75     cdr-type-cells nextfree @ + !
  76     cdr-cells nextfree @ + !
  77     car-type-cells nextfree @ + !
  78     car-cells nextfree @ + !
  79
  80     nextfree @ pair-type
  81     inc-nextfree
  82 ;
  83
  84 : car ( pair-obj -- car-obj )
  85     drop
  86     dup car-cells + @ swap
  87     car-type-cells + @
  88 ;
  89
  90 : cdr ( pair-obj -- car-obj )
  91     drop
  92     dup cdr-cells + @ swap
  93     cdr-type-cells + @
  94 ;
  95
  96 : set-car! ( obj pair-obj -- )
  97     drop dup
  98     rot swap  car-type-cells + !
  99     car-cells + !
 100 ;
 101
 102 : set-cdr! ( obj pair-obj -- )
 103     drop dup
 104     rot swap  cdr-type-cells + !
 105     cdr-cells + !
 106 ;
 107
 108 : caar car car ;
 109 : cadr cdr car ;
 110 : cdar car cdr ;
 111 : cddr cdr cdr ;
 112
 113 : nil 0 nil-type ;
 114 : nil? nil-type istype? ;
 115
 116 : none 0 none-type ;
 117 : none? none-type istype? ;
 118
 119 : objvar create nil swap , , ;
 120
 121 : value@ ( objvar -- val ) @ ;
 122 : type@ ( objvar -- type ) 1+ @ ;
 123 : value! ( newval objvar -- ) ! ;
 124 : type! ( newtype objvar -- ) 1+ ! ;
 125 : obj! ( newobj objvar -- ) dup rot swap 1+ ! ! ;
 126 : obj@ ( objvar -- obj ) dup @ swap 1+ @ ;
 127
 128 : objeq? ( obj obj -- bool )
 129     rot = -rot = and ;
 130
 131 : 2rot ( a1 a2 b1 b2 c1 c2 -- b1 b2 c1 c2 a1 a2 )
 132     >R >R ( a1 a2 b1 b2 )
 133     2swap ( b1 b2 a1 a2 )
 134     R> R> ( b1 b2 a1 a2 c1 c2 )
 135     2swap
 136 ;
 137
 138 : -2rot ( a1 a2 b1 b2 c1 c2 -- c1 c2 a1 a2 b1 b2 )
 139     2swap ( a1 a2 c1 c2 b1 b2 )
 140     >R >R ( a1 a2 c1 c2 )
 141     2swap ( c1 c2 a1 a2 )
 142     R> R>
 143 ;
 144
 145 \ }}}
 146
 147 \ ---- Port I/O ----  {{{
 148
 149 : fileport>fid ( fileport -- fid )
 150     drop ;
 151
 152 : fid>fileport ( fid -- fileport )
 153     fileport-type ;
 154
 155 : open-input-file ( addr n -- fileport )
 156     r/o open-file drop fid>fileport
 157 ;
 158
 159 : close-port ( fileport -- )
 160     fileport>fid close-file drop
 161 ;
 162
 163 objvar console-i/o-port
 164 0 fileport-type console-i/o-port obj!
 165
 166 objvar current-input-port
 167 console-i/o-port obj@ current-input-port obj!
 168
 169 : read-port ( fileport -- obj )
 170     current-input-port obj!
 171     read ;
 172
 173 : read-console ( -- obj )
 174     console-i/o-port obj@ read-port ;
 175
 176 \ }}}
 177
 178 \ ---- Pre-defined symbols ---- {{{
 179
 180 objvar symbol-table
 181
 182 : duplicate-charlist ( charlist -- copy )
 183     nil? false = if
 184         2dup car 2swap cdr recurse cons
 185     then ;
 186
 187 : charlist-equiv ( charlist charlist -- bool )
 188
 189     2over 2over
 190
 191     \ One or both nil
 192     nil? -rot 2drop
 193     if
 194         nil? -rot 2drop
 195         if
 196             2drop 2drop true exit
 197         else
 198             2drop 2drop false exit
 199         then
 200     else
 201         nil? -rot 2drop
 202         if
 203             2drop 2drop false exit
 204         then
 205     then
 206
 207     2over 2over
 208
 209     \ Neither nil
 210     car drop -rot car drop = if
 211             cdr 2swap cdr recurse
 212         else
 213             2drop 2drop false
 214     then
 215 ;
 216
 217 : charlist>symbol ( charlist -- symbol-obj )
 218
 219     symbol-table obj@
 220
 221     begin
 222         nil? false =
 223     while
 224         2over 2over
 225         car drop pair-type
 226         charlist-equiv if
 227             2swap 2drop
 228             car
 229             exit
 230         else
 231             cdr
 232         then
 233     repeat
 234
 235     2drop
 236     drop symbol-type 2dup
 237     symbol-table obj@ cons
 238     symbol-table obj!
 239 ;
 240
 241
 242 : cstr>charlist ( addr n -- symbol-obj )
 243     dup 0= if
 244         2drop nil
 245     else
 246         2dup drop @ character-type 2swap
 247         swap 1+ swap 1-
 248         recurse
 249
 250         cons
 251     then
 252 ;
 253
 254 : create-symbol ( -- )
 255     bl word
 256     count
 257
 258     cstr>charlist
 259     drop symbol-type
 260
 261     2dup
 262
 263     symbol-table obj@
 264     cons
 265     symbol-table obj!
 266
 267     create swap , ,
 268     does> dup @ swap 1+ @
 269 ;
 270
 271 create-symbol quote         quote-symbol
 272 create-symbol define        define-symbol
 273 create-symbol define-macro  define-macro-symbol
 274 create-symbol set!          set!-symbol
 275 create-symbol ok            ok-symbol
 276 create-symbol if            if-symbol
 277 create-symbol lambda        lambda-symbol
 278 create-symbol λ             λ-symbol
 279 create-symbol begin         begin-symbol
 280
 281 \ }}}
 282
 283 \ ---- Environments ---- {{{
 284
 285 : enclosing-env ( env -- env )
 286     cdr ;
 287
 288 : first-frame ( env -- frame )
 289     car ;
 290
 291 : make-frame ( vars vals -- frame )
 292     cons ;
 293
 294 : frame-vars ( frame -- vars )
 295     car ;
 296
 297 : frame-vals ( frame -- vals )
 298     cdr ;
 299
 300 : add-binding ( var val frame -- )
 301     2swap 2over frame-vals cons
 302     2over set-cdr!
 303     2swap 2over frame-vars cons
 304     2swap set-car!
 305 ;
 306
 307 : extend-env ( vars vals env -- env )
 308     >R >R
 309     make-frame
 310     R> R>
 311     cons
 312 ;
 313
 314 objvar vars
 315 objvar vals
 316
 317 : get-vars-vals-frame ( var frame -- bool )
 318     2dup frame-vars vars obj!
 319     frame-vals vals obj!
 320
 321     begin
 322         vars obj@ nil objeq? false =
 323     while
 324         2dup vars obj@ car objeq? if
 325             2drop true
 326             exit
 327         then
 328
 329         vars obj@ cdr vars obj!
 330         vals obj@ cdr vals obj!
 331     repeat
 332
 333     2drop false
 334 ;
 335
 336 : get-vars-vals ( var env -- vars? vals? bool )
 337
 338     begin
 339         nil? false =
 340     while
 341         2over 2over first-frame
 342         get-vars-vals-frame if
 343             2drop 2drop
 344             vars obj@ vals obj@ true
 345             exit
 346         then
 347
 348         enclosing-env
 349     repeat
 350
 351     2drop 2drop
 352     false
 353 ;
 354
 355 hide vars
 356 hide vals
 357
 358 : lookup-var ( var env -- val )
 359     get-vars-vals if
 360         2swap 2drop car
 361     else
 362         bold fg red ." Tried to read unbound variable." reset-term cr abort
 363     then
 364 ;
 365
 366 : set-var ( var val env -- )
 367     >R >R 2swap R> R> ( val var env )
 368     get-vars-vals if
 369         2swap 2drop ( val vals )
 370         set-car!
 371     else
 372         bold fg red ." Tried to set unbound variable." reset-term cr abort
 373     then
 374 ;
 375
 376 objvar env
 377
 378 : define-var ( var val env -- )
 379     env obj!
 380
 381     2over env obj@ ( var val var env )
 382     get-vars-vals if
 383         2swap 2drop ( var val vals )
 384         set-car!
 385         2drop
 386     else
 387         env obj@
 388         first-frame ( var val frame )
 389         add-binding
 390     then
 391 ;
 392
 393 hide env
 394
 395 : make-procedure ( params body env -- proc )
 396     nil
 397     cons cons cons
 398     drop compound-proc-type
 399 ;
 400
 401 objvar global-env
 402 nil nil nil extend-env
 403 global-env obj!
 404
 405 \ }}}
 406
 407 \ ---- Macros ---- {{{
 408
 409 objvar macro-table
 410
 411 ( Look up macro in macro table. Returns nil if
 412   no macro is found. )
 413 : lookup-macro ( name_symbol -- proc )
 414     macro-table obj@
 415
 416     begin
 417         nil? false =
 418     while
 419         2over 2over
 420         car car objeq? if
 421             2swap 2drop
 422             car cdr
 423             exit
 424         then
 425
 426         cdr
 427     repeat
 428
 429     2swap 2drop
 430 ;
 431
 432 : make-macro ( name_symbol params body env -- )
 433     make-procedure
 434
 435     2swap ( proc name_symbol )
 436
 437     macro-table obj@
 438
 439     begin
 440         nil? false =
 441     while
 442         2over 2over ( proc name table name table )
 443         car car objeq? if
 444             2swap 2drop ( proc table )
 445             car ( proc entry )
 446             set-cdr!
 447             exit
 448         then
 449
 450         cdr
 451     repeat
 452
 453     2drop
 454
 455     2swap cons
 456     macro-table obj@ cons
 457     macro-table obj!
 458 ;
 459
 460 \ }}}
 461
 462 \ ---- Read ---- {{{
 463
 464 variable parse-idx
 465 variable stored-parse-idx
 466 create parse-str 161 allot
 467 variable parse-str-span
 468
 469 create parse-idx-stack 10 allot
 470 variable parse-idx-sp
 471 parse-idx-stack parse-idx-sp !
 472
 473 : push-parse-idx
 474     parse-idx @ parse-idx-sp @ !
 475     1 parse-idx-sp +!
 476 ;
 477
 478 : pop-parse-idx
 479     parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
 480
 481     1 parse-idx-sp -!
 482
 483     parse-idx-sp @ @ parse-idx ! ;
 484
 485
 486 : append-newline
 487     '\n' parse-str parse-str-span @ + !
 488     1 parse-str-span +! ;
 489
 490 : append-eof
 491     4 parse-str parse-str-span @ + !
 492     1 parse-str-span +!  ;
 493
 494 : empty-parse-str
 495     0 parse-str-span !
 496     0 parse-idx ! ;
 497
 498 : getline
 499     current-input-port obj@ console-i/o-port obj@ objeq? if
 500         parse-str 160 expect cr
 501         span @ parse-str-span !
 502     else
 503         parse-str 160 current-input-port obj@ fileport>fid read-line
 504         drop swap parse-str-span !
 505
 506         parse-str-span @ 0= and if append-eof then
 507     then
 508     append-newline
 509     0 parse-idx ! ;
 510
 511 : inc-parse-idx
 512     1 parse-idx +! ;
 513
 514 : dec-parse-idx
 515     1 parse-idx -! ;
 516
 517 : charavailable? ( -- bool )
 518     parse-str-span @ parse-idx @ > ;
 519
 520 : nextchar ( -- char )
 521     charavailable? false = if getline then
 522     parse-str parse-idx @ + @ ;
 523
 524 : '\t' 9 ;
 525 : whitespace? ( -- bool )
 526     nextchar BL =
 527     nextchar '\n' =
 528     nextchar '\t' =
 529     or or ;
 530
 531 : EOF 4 ;
 532 : eof? ( -- bool )
 533     nextchar EOF = ;
 534
 535 : delim? ( -- bool )
 536     whitespace?
 537     nextchar [char] ( = or
 538     nextchar [char] ) = or
 539 ;
 540
 541 : commentstart? ( -- bool )
 542     nextchar [char] ; = ;
 543
 544 : eatspaces
 545
 546     false \ Indicates whether or not we're eating a comment
 547
 548     begin
 549         dup whitespace? or commentstart? or
 550     while
 551         dup nextchar '\n' = and if
 552             invert \ Stop eating comment
 553         else
 554             dup false = commentstart? and if
 555                 invert \ Begin eating comment
 556             then
 557         then
 558
 559         inc-parse-idx
 560     repeat
 561     drop
 562 ;
 563
 564 : digit? ( -- bool )
 565     nextchar [char] 0 >=
 566     nextchar [char] 9 <=
 567     and ;
 568
 569 : minus? ( -- bool )
 570     nextchar [char] - = ;
 571
 572 : plus? ( -- bool )
 573     nextchar [char] + = ;
 574
 575 : fixnum? ( -- bool )
 576     minus? plus? or if
 577         inc-parse-idx
 578
 579         delim? if
 580             dec-parse-idx
 581             false exit
 582         else
 583             dec-parse-idx
 584         then
 585     else
 586         digit? false = if
 587             false exit
 588         then
 589     then
 590
 591     push-parse-idx
 592     inc-parse-idx
 593
 594     begin digit? while
 595         inc-parse-idx
 596     repeat
 597
 598     delim? pop-parse-idx
 599 ;
 600
 601 : realnum? ( -- bool )
 602     push-parse-idx
 603
 604     minus? plus? or if
 605         inc-parse-idx
 606     then
 607
 608     \ Record starting parse idx:
 609     \ Want to detect whether any characters (following +/-) were eaten.
 610     parse-idx @
 611
 612     begin digit? while
 613             inc-parse-idx
 614     repeat
 615
 616     [char] . nextchar = if
 617         inc-parse-idx
 618         begin digit? while
 619                 inc-parse-idx
 620         repeat
 621     then
 622
 623     [char] e nextchar = [char] E nextchar = or if
 624         inc-parse-idx
 625
 626         minus? plus? or if
 627             inc-parse-idx
 628         then
 629
 630         digit? invert if
 631             drop pop-parse-idx false exit
 632         then
 633
 634         begin digit? while
 635                 inc-parse-idx
 636         repeat
 637     then
 638
 639     \ This is a real number if characters were
 640     \ eaten and the next characer is a delimiter.
 641     parse-idx @ < delim? and
 642
 643     pop-parse-idx
 644 ;
 645
 646 : boolean? ( -- bool )
 647     nextchar [char] # <> if false exit then
 648
 649     push-parse-idx
 650     inc-parse-idx
 651
 652     nextchar [char] t <>
 653     nextchar [char] f <>
 654     and if pop-parse-idx false exit then
 655
 656     inc-parse-idx
 657     delim? if
 658         pop-parse-idx
 659         true
 660     else
 661         pop-parse-idx
 662         false
 663     then
 664 ;
 665
 666 : str-equiv? ( str -- bool )
 667
 668     push-parse-idx
 669
 670     true -rot
 671
 672     swap dup rot + swap
 673
 674     do
 675         i @ nextchar <> if
 676             drop false
 677             leave
 678         then
 679
 680         inc-parse-idx
 681     loop
 682
 683     delim? false = if drop false then
 684
 685     pop-parse-idx
 686 ;
 687
 688 : character? ( -- bool )
 689     nextchar [char] # <> if false exit then
 690
 691     push-parse-idx
 692     inc-parse-idx
 693
 694     nextchar [char] \ <> if pop-parse-idx false exit then
 695
 696     inc-parse-idx
 697
 698     S" newline" str-equiv? if pop-parse-idx true exit then
 699     S" space" str-equiv? if pop-parse-idx true exit then
 700     S" tab" str-equiv? if pop-parse-idx true exit then
 701
 702     charavailable? false = if pop-parse-idx false exit then
 703
 704     pop-parse-idx true
 705 ;
 706
 707 : pair? ( -- bool )
 708     nextchar [char] ( = ;
 709
 710 : string? ( -- bool )
 711     nextchar [char] " = ;
 712
 713 : readfixnum ( -- num-atom )
 714     plus? minus? or if
 715         minus?
 716         inc-parse-idx
 717     else
 718         false
 719     then
 720
 721     0
 722
 723     begin digit? while
 724         10 * nextchar [char] 0 - +
 725         inc-parse-idx
 726     repeat
 727
 728     swap if negate then
 729
 730     fixnum-type
 731 ;
 732
 733 : readrealnum ( -- realnum )
 734
 735     \ Remember that at this point we're guaranteed to
 736     \ have a parsable real on this line.
 737
 738     parse-str parse-idx @ +
 739
 740     begin delim? false = while
 741             inc-parse-idx
 742     repeat
 743
 744     parse-str parse-idx @ + over -
 745
 746     float-parse
 747
 748     realnum-type
 749 ;
 750
 751 : readbool ( -- bool-obj )
 752     inc-parse-idx
 753
 754     nextchar [char] f = if
 755         false
 756     else
 757         true
 758     then
 759
 760     inc-parse-idx
 761
 762     boolean-type
 763 ;
 764
 765 : readchar ( -- char-obj )
 766     inc-parse-idx
 767     inc-parse-idx
 768
 769     S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
 770     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
 771     S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
 772
 773     nextchar character-type
 774
 775     inc-parse-idx
 776 ;
 777
 778 : readstring ( -- charlist )
 779     nextchar [char] " = if
 780         inc-parse-idx
 781
 782         delim? false = if
 783             bold fg red
 784             ." No delimiter following right double quote. Aborting." cr
 785             reset-term abort
 786         then
 787
 788         dec-parse-idx
 789
 790         0 nil-type exit
 791     then
 792
 793     nextchar [char] \ = if
 794         inc-parse-idx
 795         nextchar case
 796             [char] n of '\n' endof
 797             [char] " of [char] " endof
 798             [char] \
 799         endcase
 800     else
 801         nextchar
 802     then
 803     inc-parse-idx character-type
 804
 805     recurse
 806
 807     cons
 808 ;
 809
 810 : readsymbol ( -- charlist )
 811     delim? if nil exit then
 812
 813     nextchar inc-parse-idx character-type
 814
 815     recurse
 816
 817     cons
 818 ;
 819
 820 : readpair ( -- pairobj )
 821     eatspaces
 822
 823     \ Empty lists
 824     nextchar [char] ) = if
 825         inc-parse-idx
 826
 827         delim? false = if
 828             bold fg red
 829             ." No delimiter following right paren. Aborting." cr
 830             reset-term abort
 831         then
 832
 833         dec-parse-idx
 834
 835         0 nil-type exit
 836     then
 837
 838     \ Read first pair element
 839     read
 840
 841     \ Pairs
 842     eatspaces
 843     nextchar [char] . = if
 844         inc-parse-idx
 845
 846         delim? false = if
 847             bold fg red
 848             ." No delimiter following '.'. Aborting." cr
 849             reset-term abort
 850         then
 851
 852         eatspaces read
 853     else
 854         recurse
 855     then
 856
 857     eatspaces
 858
 859     cons
 860 ;
 861
 862 \ Parse a scheme expression
 863 :noname ( -- obj )
 864
 865     eatspaces
 866
 867     fixnum? if
 868         readfixnum
 869         exit
 870     then
 871
 872     realnum? if
 873         readrealnum
 874         exit
 875     then
 876
 877     boolean? if
 878         readbool
 879         exit
 880     then
 881
 882     character? if
 883         readchar
 884         exit
 885     then
 886
 887     string? if
 888         inc-parse-idx
 889
 890         readstring
 891         drop string-type
 892
 893         nextchar [char] " <> if
 894             bold red ." Missing closing double-quote." reset-term cr
 895             abort
 896         then
 897
 898         inc-parse-idx
 899
 900         exit
 901     then
 902
 903     pair? if
 904         inc-parse-idx
 905
 906         eatspaces
 907
 908         readpair
 909
 910         eatspaces
 911
 912         nextchar [char] ) <> if
 913             bold red ." Missing closing paren." reset-term cr
 914             abort
 915         then
 916
 917         inc-parse-idx
 918
 919         exit
 920     then
 921
 922     nextchar [char] ' = if
 923         inc-parse-idx
 924         quote-symbol recurse nil cons cons exit
 925     then
 926
 927     eof? if
 928         EOF character-type
 929         inc-parse-idx
 930         exit
 931     then
 932
 933     \ Anything else is parsed as a symbol
 934     readsymbol charlist>symbol
 935
 936     \ Replace λ with lambda
 937     2dup λ-symbol objeq? if
 938         2drop lambda-symbol
 939     then
 940
 941
 942 ; is read
 943
 944 \ }}}
 945
 946 \ ---- Eval ---- {{{
 947
 948 : self-evaluating? ( obj -- obj bool )
 949     boolean-type istype? if true exit then
 950     fixnum-type istype? if true exit then
 951     realnum-type istype? if true exit then
 952     character-type istype? if true exit then
 953     string-type istype? if true exit then
 954     nil-type istype? if true exit then
 955     none-type istype? if true exit then
 956
 957     false
 958 ;
 959
 960 : tagged-list? ( obj tag-obj -- obj bool )
 961     2over
 962     pair-type istype? false = if
 963         2drop 2drop false
 964     else
 965         car objeq?
 966     then ;
 967
 968 : quote? ( obj -- obj bool )
 969     quote-symbol tagged-list?  ;
 970
 971 : quote-body ( quote-obj -- quote-body-obj )
 972     cadr ;
 973
 974 : variable? ( obj -- obj bool )
 975     symbol-type istype? ;
 976
 977 : definition? ( obj -- obj bool )
 978     define-symbol tagged-list? ;
 979
 980 : make-lambda ( params body -- lambda-exp )
 981     lambda-symbol -2rot cons cons ;
 982
 983 : definition-var ( obj -- var )
 984     cdr car
 985     symbol-type istype? false = if car then
 986 ;
 987
 988 : definition-val ( obj -- val )
 989     2dup cdr car symbol-type istype? if
 990         2drop
 991         cdr cdr car
 992     else
 993         cdr 2swap cdr cdr
 994         make-lambda
 995     then
 996 ;
 997
 998 : assignment? ( obj -- obj bool )
 999     set!-symbol tagged-list? ;
1000
1001 : assignment-var ( obj -- var )
1002     cdr car ;
1003
1004 : assignment-val ( obj -- val )
1005     cdr cdr car ;
1006
1007 : eval-definition ( obj env -- res )
1008     2swap
1009     2over 2over ( env obj env obj )
1010     definition-val 2swap ( env obj valexp env )
1011     eval  ( env obj val )
1012
1013     2swap definition-var 2swap ( env var val )
1014
1015     2rot ( var val env )
1016     define-var
1017
1018     ok-symbol
1019 ;
1020
1021 : eval-assignment ( obj env -- res )
1022     2swap
1023     2over 2over ( env obj env obj )
1024     assignment-val 2swap ( env obj valexp env )
1025     eval  ( env obj val )
1026
1027     2swap assignment-var 2swap ( env var val )
1028
1029     2rot ( var val env )
1030     set-var
1031
1032     ok-symbol
1033 ;
1034
1035 : macro-definition? ( obj -- obj bool )
1036     define-macro-symbol tagged-list? ;
1037
1038 : macro-definition-name ( exp -- mname )
1039     cdr car car ;
1040
1041 : macro-definition-params ( exp -- params )
1042     cdr car cdr ;
1043
1044 : macro-definition-body ( exp -- body )
1045     cdr cdr ;
1046
1047 objvar env
1048 : eval-define-macro ( obj env -- res )
1049     env obj!
1050
1051     2dup macro-definition-name 2swap ( name obj )
1052     2dup macro-definition-params 2swap ( name params obj )
1053     macro-definition-body ( name params body )
1054
1055     env obj@ ( name params body env )
1056
1057     make-macro
1058
1059     ok-symbol
1060 ;
1061 hide env
1062
1063 : if? ( obj -- obj bool )
1064     if-symbol tagged-list? ;
1065
1066 : if-predicate ( ifobj -- pred )
1067     cdr car ;
1068
1069 : if-consequent ( ifobj -- conseq )
1070     cdr cdr car ;
1071
1072 : if-alternative ( ifobj -- alt|false )
1073     cdr cdr cdr
1074     nil? if
1075         2drop false
1076     else
1077         car
1078     then ;
1079
1080 : false? ( boolobj -- boolean )
1081     boolean-type istype? if
1082         false boolean-type objeq?
1083     else
1084         2drop false
1085     then
1086 ;
1087
1088 : true? ( boolobj -- bool )
1089     false? invert ;
1090
1091 : lambda? ( obj -- obj bool )
1092     lambda-symbol tagged-list? ;
1093
1094 : lambda-parameters ( obj -- params )
1095     cdr car ;
1096
1097 : lambda-body ( obj -- body )
1098     cdr cdr ;
1099
1100 : begin? ( obj -- obj bool )
1101     begin-symbol tagged-list? ;
1102
1103 : begin-actions ( obj -- actions )
1104     cdr ;
1105
1106 : eval-sequence ( explist env -- finalexp env )
1107     ( Evaluates all bar the final expressions in
1108       an an expression list. The final expression
1109       is returned to allow for tail optimization. )
1110
1111     2swap ( env explist )
1112
1113     \ Abort on empty list
1114     nil? if
1115         2drop none
1116         2swap exit
1117     then
1118
1119     begin
1120         2dup cdr ( env explist nextexplist )
1121         nil? false =
1122     while
1123         -2rot car 2over ( nextexplist env exp env )
1124         eval
1125         2drop \ discard result
1126         2swap ( env nextexplist )
1127     repeat
1128
1129     2drop car 2swap ( finalexp env )
1130 ;
1131
1132 : application? ( obj -- obj bool )
1133     pair-type istype? ;
1134
1135 : operator ( obj -- operator )
1136     car ;
1137
1138 : operands ( obj -- operands )
1139     cdr ;
1140
1141 : nooperands? ( operands -- bool )
1142     nil objeq? ;
1143
1144 : first-operand ( operands -- operand )
1145     car ;
1146
1147 : rest-operands ( operands -- other-operands )
1148     cdr ;
1149
1150 : list-of-vals ( args env -- vals )
1151     2swap
1152
1153     2dup nooperands? if
1154         2swap 2drop
1155     else
1156         2over 2over first-operand 2swap eval
1157         -2rot rest-operands 2swap recurse
1158         cons
1159     then
1160 ;
1161
1162 : procedure-params ( proc -- params )
1163     drop pair-type car ;
1164
1165 : procedure-body ( proc -- body )
1166     drop pair-type cdr car ;
1167
1168 : procedure-env ( proc -- body )
1169     drop pair-type cdr cdr car ;
1170
1171 ( Ensure terminating symbol arg name is handled
1172   specially to allow for variadic procedures. )
1173 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1174     nil? if exit then
1175
1176     symbol-type istype? if
1177         nil cons
1178         2swap
1179         nil cons
1180         2swap
1181         exit
1182     then
1183
1184     2over cdr 2over cdr
1185     recurse ( argvals argnames argvals'' argnames'' )
1186     2rot car 2swap cons  ( argvals argvals'' argnames' )
1187     2rot car 2rot cons ( argnames' argvals' )
1188     2swap
1189 ;
1190
1191 : apply ( proc argvals -- result )
1192         2swap dup case
1193             primitive-proc-type of
1194                 drop execute
1195             endof
1196
1197             compound-proc-type of
1198                 2dup procedure-body ( argvals proc body )
1199                 -2rot 2dup procedure-params ( body argvals proc argnames )
1200                 -2rot procedure-env ( body argnames argvals procenv )
1201
1202                 -2rot 2swap
1203                 flatten-proc-args
1204                 2swap 2rot
1205
1206                 extend-env ( body env )
1207
1208                 eval-sequence
1209
1210                 R> drop ['] eval goto-deferred  \ Tail call optimization
1211             endof
1212
1213             bold fg red ." Object not applicable. Aborting." reset-term cr
1214             abort
1215         endcase
1216 ;
1217
1218 : macro-expand ( proc expbody -- result )
1219     2swap
1220     2dup procedure-body ( expbody proc procbody )
1221     -2rot 2dup procedure-params ( procbody expbody proc argnames )
1222     -2rot procedure-env ( procbody argnames expbody procenv )
1223
1224     -2rot 2swap
1225     flatten-proc-args
1226     2swap 2rot
1227
1228     extend-env eval-sequence eval
1229 ;
1230
1231 :noname ( obj env -- result )
1232     2swap
1233
1234     self-evaluating? if
1235         2swap 2drop
1236         exit
1237     then
1238
1239     quote? if
1240         quote-body
1241         2swap 2drop
1242         exit
1243     then
1244
1245     variable? if
1246         2swap lookup-var
1247         exit
1248     then
1249
1250     definition? if
1251         2swap eval-definition
1252         exit
1253     then
1254
1255     assignment? if
1256         2swap eval-assignment
1257         exit
1258     then
1259
1260     macro-definition? if
1261         2swap eval-define-macro
1262         exit
1263     then
1264
1265     if? if
1266         2over 2over
1267         if-predicate
1268         2swap eval
1269
1270         true? if
1271             if-consequent
1272         else
1273             if-alternative
1274         then
1275
1276         2swap
1277         ['] eval goto-deferred
1278     then
1279
1280     lambda? if
1281         2dup lambda-parameters
1282         2swap lambda-body
1283         2rot make-procedure
1284         exit
1285     then
1286
1287     begin? if
1288         begin-actions 2swap
1289         eval-sequence
1290         ['] eval goto-deferred
1291     then
1292
1293     application? if
1294
1295         2over 2over ( env exp env exp )
1296         operator 2dup ( env exp env opname opname )
1297
1298         lookup-macro nil? if
1299             \ Regular function application
1300
1301             2drop ( env exp env opname )
1302
1303             2swap eval ( env exp proc )
1304             -2rot ( proc env exp )
1305             operands 2swap ( proc operands env )
1306             list-of-vals ( proc argvals )
1307
1308             apply
1309         else
1310             \ Macro function evaluation
1311
1312             ( env exp env opname mproc )
1313             2swap 2drop -2rot 2drop cdr ( env mproc body )
1314
1315             2dup print cr
1316             macro-expand
1317             2dup print cr
1318
1319             2swap
1320             ['] eval goto-deferred
1321         then
1322         exit
1323     then
1324
1325     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
1326     abort
1327 ; is eval
1328
1329 \ }}}
1330
1331 \ ---- Print ---- {{{
1332
1333 : printfixnum ( fixnumobj -- ) drop 0 .R ;
1334
1335 : printrealnum ( realnumobj -- ) drop float-print ;
1336
1337 : printbool ( numobj -- )
1338     drop if
1339         ." #t"
1340     else
1341         ." #f"
1342     then
1343 ;
1344
1345 : printchar ( charobj -- )
1346     drop
1347     case
1348         9 of ." #\tab" endof
1349         bl of ." #\space" endof
1350         '\n' of ." #\newline" endof
1351
1352         dup ." #\" emit
1353     endcase
1354 ;
1355
1356 : (printstring) ( stringobj -- )
1357     nil-type istype? if 2drop exit then
1358
1359     2dup car drop dup
1360     case
1361         '\n' of ." \n" drop endof
1362         [char] \ of ." \\" drop endof
1363         [char] " of [char] \ emit [char] " emit drop endof
1364         emit
1365     endcase
1366
1367     cdr recurse
1368 ;
1369 : printstring ( stringobj -- )
1370     [char] " emit
1371     (printstring)
1372     [char] " emit ;
1373
1374 : printsymbol ( symbolobj -- )
1375     nil-type istype? if 2drop exit then
1376
1377     2dup car drop emit
1378     cdr recurse
1379 ;
1380
1381 : printnil ( nilobj -- )
1382     2drop ." ()" ;
1383
1384 : printpair ( pairobj -- )
1385     2dup
1386     car print
1387     cdr
1388     nil-type istype? if 2drop exit then
1389     pair-type istype? if space recurse exit then
1390     ."  . " print
1391 ;
1392
1393 : printprim ( primobj -- )
1394     2drop ." <primitive procedure>" ;
1395
1396 : printcomp ( primobj -- )
1397     2drop ." <compound procedure>" ;
1398
1399 : printnone ( noneobj -- )
1400     2drop ." Unspecified return value" ;
1401
1402 :noname ( obj -- )
1403     fixnum-type istype? if printfixnum exit then
1404     realnum-type istype? if printrealnum exit then
1405     boolean-type istype? if printbool exit then
1406     character-type istype? if printchar exit then
1407     string-type istype? if printstring exit then
1408     symbol-type istype? if printsymbol exit then
1409     nil-type istype? if printnil exit then
1410     pair-type istype? if ." (" printpair ." )" exit then
1411     primitive-proc-type istype? if printprim exit then
1412     compound-proc-type istype? if printcomp exit then
1413     none-type istype? if printnone exit then
1414
1415     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
1416     abort
1417 ; is print
1418
1419 \ }}}
1420
1421 \ ---- Garbage Collection ---- {{{
1422
1423 variable gc-enabled
1424 false gc-enabled !
1425
1426 variable gc-stack-depth
1427
1428 : enable-gc
1429     depth gc-stack-depth !
1430     true gc-enabled ! ;
1431
1432 : disable-gc
1433     false gc-enabled ! ;
1434
1435 : gc-enabled?
1436     gc-enabled @ ;
1437
1438 : pairlike? ( obj -- obj bool )
1439     pair-type istype? if true exit then
1440     string-type istype? if true exit then
1441     symbol-type istype? if true exit then
1442     compound-proc-type istype? if true exit then
1443
1444     false
1445 ;
1446
1447 : pairlike-marked? ( obj -- obj bool )
1448     over nextfrees + @ 0=
1449 ;
1450
1451 : mark-pairlike ( obj -- obj )
1452         over nextfrees + 0 swap !
1453 ;
1454
1455 : gc-unmark ( -- )
1456     scheme-memsize 0 do
1457         1 nextfrees i + !
1458     loop
1459 ;
1460
1461 : gc-mark-obj ( obj -- )
1462
1463     pairlike? invert if 2drop exit then
1464     pairlike-marked? if 2drop exit then
1465
1466     mark-pairlike
1467
1468     drop pair-type 2dup
1469
1470     car recurse
1471     cdr recurse
1472 ;
1473
1474 : gc-sweep
1475     scheme-memsize nextfree !
1476     0 scheme-memsize 1- do
1477         nextfrees i + @ 0<> if
1478             nextfree @ nextfrees i + !
1479             i nextfree !
1480         then
1481     -1 +loop
1482 ;
1483
1484 \ Following a GC, this gives the amount of free memory
1485 : gc-count-marked
1486     0
1487     scheme-memsize 0 do
1488         nextfrees i + @ 0= if 1+ then
1489     loop
1490 ;
1491
1492 \ Debugging word - helps spot memory that is retained
1493 : gc-zero-unmarked
1494     scheme-memsize 0 do
1495         nextfrees i + @ 0<> if
1496             0 car-cells i + !
1497             0 cdr-cells i + !
1498         then
1499     loop
1500 ;
1501
1502 :noname
1503     \ ." GC! "
1504
1505     gc-unmark
1506
1507     symbol-table obj@ gc-mark-obj
1508     macro-table obj@ gc-mark-obj
1509     global-env obj@ gc-mark-obj
1510
1511     depth gc-stack-depth @ do
1512         PSP0 i + 1 + @
1513         PSP0 i + 2 + @
1514
1515         gc-mark-obj
1516     2 +loop
1517
1518     gc-sweep
1519
1520     \ ." (" gc-count-marked . ." pairs marked as used.)" cr
1521 ; is collect-garbage
1522
1523 \ }}}
1524
1525 \ ---- Loading files ---- {{{
1526
1527 : charlist>cstr ( charlist addr -- n )
1528
1529     dup 2swap ( origaddr addr charlist )
1530
1531     begin
1532         nil? false =
1533     while
1534         2dup cdr 2swap car
1535         drop ( origaddr addr charlist char )
1536         -rot 2swap ( origaddr charlist addr char )
1537         over !
1538         1+ -rot ( origaddr nextaddr charlist )
1539     repeat
1540
1541     2drop ( origaddr finaladdr )
1542     swap -
1543 ;
1544
1545 : load ( addr n -- finalResult )
1546     open-input-file
1547
1548     empty-parse-str
1549
1550     ok-symbol ( port res )
1551
1552     begin
1553         2over read-port ( port res obj )
1554
1555         2dup EOF character-type objeq? if
1556             2drop 2swap close-port
1557             exit
1558         then
1559
1560         2swap 2drop ( port obj )
1561
1562         global-env obj@ eval ( port res )
1563     again
1564 ;
1565
1566 \ }}}
1567
1568 \ ---- Primitives ---- {{{
1569
1570 : make-primitive ( cfa -- )
1571     bl word
1572     count
1573
1574     \ 2dup ." Defining primitive " type ." ..." cr
1575
1576     cstr>charlist
1577     drop symbol-type
1578
1579     2dup
1580
1581     symbol-table obj@
1582     cons
1583     symbol-table obj!
1584
1585     rot primitive-proc-type ( var prim )
1586     global-env obj@ define-var
1587 ;
1588
1589 : arg-count-error
1590             bold fg red ." Incorrect argument count." reset-term cr
1591             abort
1592 ;
1593
1594 : ensure-arg-count ( args n -- )
1595     dup 0= if
1596         drop nil objeq? false = if
1597             arg-count-error
1598         then
1599     else
1600         -rot nil? if
1601             arg-count-error
1602         then
1603
1604         cdr rot 1- recurse
1605     then
1606 ;
1607
1608 : arg-type-error
1609             bold fg red ." Incorrect argument type." reset-term cr
1610             abort
1611 ;
1612
1613 : ensure-arg-type ( arg type -- arg )
1614     istype? false = if
1615         arg-type-error
1616     then
1617 ;
1618
1619 include scheme-primitives.4th
1620
1621 \ }}}
1622
1623 \ ---- Standard Library ---- {{{
1624
1625     s" scheme-library.scm" load 2drop
1626
1627 \ }}}
1628
1629 \ ---- REPL ----
1630
1631 : repl
1632     cr ." Welcome to scheme.forth.jl!" cr
1633        ." Use Ctrl-D to exit." cr
1634
1635     empty-parse-str
1636
1637     enable-gc
1638
1639     begin
1640         cr bold fg green ." > " reset-term
1641         read-console
1642
1643         2dup EOF character-type objeq? if
1644             2drop
1645             bold fg blue ." Moriturus te saluto." reset-term cr
1646             exit
1647         then
1648
1649         global-env obj@ eval
1650
1651         fg cyan ." ; " print reset-term
1652     again
1653 ;
1654
1655 forth definitions
1656
1657 \ vim:fdm=marker