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 )
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. Aboring." reset-term cr
1214             abort
1215         endcase
1216 ;
1217
1218 :noname ( obj env -- result )
1219     2swap
1220
1221     self-evaluating? if
1222         2swap 2drop
1223         exit
1224     then
1225
1226     quote? if
1227         quote-body
1228         2swap 2drop
1229         exit
1230     then
1231
1232     variable? if
1233         2swap lookup-var
1234         exit
1235     then
1236
1237     definition? if
1238         2swap eval-definition
1239         exit
1240     then
1241
1242     assignment? if
1243         2swap eval-assignment
1244         exit
1245     then
1246
1247     macro-definition? if
1248         2swap eval-define-macro
1249         exit
1250     then
1251
1252     if? if
1253         2over 2over
1254         if-predicate
1255         2swap eval
1256
1257         true? if
1258             if-consequent
1259         else
1260             if-alternative
1261         then
1262
1263         2swap
1264         ['] eval goto-deferred
1265     then
1266
1267     lambda? if
1268         2dup lambda-parameters
1269         2swap lambda-body
1270         2rot make-procedure
1271         exit
1272     then
1273
1274     begin? if
1275         begin-actions 2swap
1276         eval-sequence
1277         ['] eval goto-deferred
1278     then
1279
1280     application? if
1281
1282         2over 2over ( env exp env exp )
1283         operator 2dup ( env exp env opname opname )
1284
1285         lookup-macro nil? if
1286             \ Regular function application
1287
1288             2drop ( env exp env opname )
1289
1290             2swap eval ( env exp proc )
1291             -2rot ( proc env exp )
1292             operands 2swap ( proc operands env )
1293             list-of-vals ( proc argvals )
1294
1295             apply
1296         else
1297             \ Macro function evaluation
1298
1299             ." Macro eval"
1300
1301             ( env exp env opname mproc )
1302             2swap 2drop -2rot 2drop cdr ( env mproc body )
1303
1304             \ TODO: evaluate macro procedure on expression body
1305             ." ABORTED: Macros not yet fully implemented!" abort
1306         then
1307         exit
1308     then
1309
1310     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
1311     abort
1312 ; is eval
1313
1314 \ }}}
1315
1316 \ ---- Print ---- {{{
1317
1318 : printfixnum ( fixnumobj -- ) drop 0 .R ;
1319
1320 : printrealnum ( realnumobj -- ) drop float-print ;
1321
1322 : printbool ( numobj -- )
1323     drop if
1324         ." #t"
1325     else
1326         ." #f"
1327     then
1328 ;
1329
1330 : printchar ( charobj -- )
1331     drop
1332     case
1333         9 of ." #\tab" endof
1334         bl of ." #\space" endof
1335         '\n' of ." #\newline" endof
1336
1337         dup ." #\" emit
1338     endcase
1339 ;
1340
1341 : (printstring) ( stringobj -- )
1342     nil-type istype? if 2drop exit then
1343
1344     2dup car drop dup
1345     case
1346         '\n' of ." \n" drop endof
1347         [char] \ of ." \\" drop endof
1348         [char] " of [char] \ emit [char] " emit drop endof
1349         emit
1350     endcase
1351
1352     cdr recurse
1353 ;
1354 : printstring ( stringobj -- )
1355     [char] " emit
1356     (printstring)
1357     [char] " emit ;
1358
1359 : printsymbol ( symbolobj -- )
1360     nil-type istype? if 2drop exit then
1361
1362     2dup car drop emit
1363     cdr recurse
1364 ;
1365
1366 : printnil ( nilobj -- )
1367     2drop ." ()" ;
1368
1369 : printpair ( pairobj -- )
1370     2dup
1371     car print
1372     cdr
1373     nil-type istype? if 2drop exit then
1374     pair-type istype? if space recurse exit then
1375     ."  . " print
1376 ;
1377
1378 : printprim ( primobj -- )
1379     2drop ." <primitive procedure>" ;
1380
1381 : printcomp ( primobj -- )
1382     2drop ." <compound procedure>" ;
1383
1384 : printnone ( noneobj -- )
1385     2drop ." Unspecified return value" ;
1386
1387 :noname ( obj -- )
1388     fixnum-type istype? if printfixnum exit then
1389     realnum-type istype? if printrealnum exit then
1390     boolean-type istype? if printbool exit then
1391     character-type istype? if printchar exit then
1392     string-type istype? if printstring exit then
1393     symbol-type istype? if printsymbol exit then
1394     nil-type istype? if printnil exit then
1395     pair-type istype? if ." (" printpair ." )" exit then
1396     primitive-proc-type istype? if printprim exit then
1397     compound-proc-type istype? if printcomp exit then
1398     none-type istype? if printnone exit then
1399
1400     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
1401     abort
1402 ; is print
1403
1404 \ }}}
1405
1406 \ ---- Garbage Collection ---- {{{
1407
1408 variable gc-enabled
1409 false gc-enabled !
1410
1411 variable gc-stack-depth
1412
1413 : enable-gc
1414     depth gc-stack-depth !
1415     true gc-enabled ! ;
1416
1417 : disable-gc
1418     false gc-enabled ! ;
1419
1420 : gc-enabled?
1421     gc-enabled @ ;
1422
1423 : pairlike? ( obj -- obj bool )
1424     pair-type istype? if true exit then
1425     string-type istype? if true exit then
1426     symbol-type istype? if true exit then
1427     compound-proc-type istype? if true exit then
1428
1429     false
1430 ;
1431
1432 : pairlike-marked? ( obj -- obj bool )
1433     over nextfrees + @ 0=
1434 ;
1435
1436 : mark-pairlike ( obj -- obj )
1437         over nextfrees + 0 swap !
1438 ;
1439
1440 : gc-unmark ( -- )
1441     scheme-memsize 0 do
1442         1 nextfrees i + !
1443     loop
1444 ;
1445
1446 : gc-mark-obj ( obj -- )
1447
1448     pairlike? invert if 2drop exit then
1449     pairlike-marked? if 2drop exit then
1450
1451     mark-pairlike
1452
1453     drop pair-type 2dup
1454
1455     car recurse
1456     cdr recurse
1457 ;
1458
1459 : gc-sweep
1460     scheme-memsize nextfree !
1461     0 scheme-memsize 1- do
1462         nextfrees i + @ 0<> if
1463             nextfree @ nextfrees i + !
1464             i nextfree !
1465         then
1466     -1 +loop
1467 ;
1468
1469 \ Following a GC, this gives the amount of free memory
1470 : gc-count-marked
1471     0
1472     scheme-memsize 0 do
1473         nextfrees i + @ 0= if 1+ then
1474     loop
1475 ;
1476
1477 \ Debugging word - helps spot memory that is retained
1478 : gc-zero-unmarked
1479     scheme-memsize 0 do
1480         nextfrees i + @ 0<> if
1481             0 car-cells i + !
1482             0 cdr-cells i + !
1483         then
1484     loop
1485 ;
1486
1487 :noname
1488     \ ." GC! "
1489
1490     gc-unmark
1491
1492     symbol-table obj@ gc-mark-obj
1493     macro-table obj@ gc-mark-obj
1494     global-env obj@ gc-mark-obj
1495
1496     depth gc-stack-depth @ do
1497         PSP0 i + 1 + @
1498         PSP0 i + 2 + @
1499
1500         gc-mark-obj
1501     2 +loop
1502
1503     gc-sweep
1504
1505     \ ." (" gc-count-marked . ." pairs marked as used.)" cr
1506 ; is collect-garbage
1507
1508 \ }}}
1509
1510 \ ---- Primitives ---- {{{
1511
1512 : make-primitive ( cfa -- )
1513     bl word
1514     count
1515
1516     \ 2dup ." Defining primitive " type ." ..." cr
1517
1518     cstr>charlist
1519     drop symbol-type
1520
1521     2dup
1522
1523     symbol-table obj@
1524     cons
1525     symbol-table obj!
1526
1527     rot primitive-proc-type ( var prim )
1528     global-env obj@ define-var
1529 ;
1530
1531 : arg-count-error
1532             bold fg red ." Incorrect argument count." reset-term cr
1533             abort
1534 ;
1535
1536 : ensure-arg-count ( args n -- )
1537     dup 0= if
1538         drop nil objeq? false = if
1539             arg-count-error
1540         then
1541     else
1542         -rot nil? if
1543             arg-count-error
1544         then
1545
1546         cdr rot 1- recurse
1547     then
1548 ;
1549
1550 : arg-type-error
1551             bold fg red ." Incorrect argument type." reset-term cr
1552             abort
1553 ;
1554
1555 : ensure-arg-type ( arg type -- arg )
1556     istype? false = if
1557         arg-type-error
1558     then
1559 ;
1560
1561 include scheme-primitives.4th
1562
1563 \ }}}
1564
1565 \ ---- Loading files ---- {{{
1566
1567 : charlist>cstr ( charlist addr -- n )
1568
1569     dup 2swap ( origaddr addr charlist )
1570
1571     begin
1572         nil? false =
1573     while
1574         2dup cdr 2swap car
1575         drop ( origaddr addr charlist char )
1576         -rot 2swap ( origaddr charlist addr char )
1577         over !
1578         1+ -rot ( origaddr nextaddr charlist )
1579     repeat
1580
1581     2drop ( origaddr finaladdr )
1582     swap -
1583 ;
1584
1585 : load ( addr n -- finalResult )
1586     open-input-file
1587
1588     empty-parse-str
1589
1590     ok-symbol ( port res )
1591
1592     begin
1593         2over read-port ( port res obj )
1594
1595         2dup EOF character-type objeq? if
1596             2drop 2swap close-port
1597             exit
1598         then
1599
1600         2swap 2drop ( port obj )
1601
1602         global-env obj@ eval ( port res )
1603     again
1604 ;
1605
1606 :noname ( args -- finalResult )
1607     2dup 1 ensure-arg-count
1608     car string-type ensure-arg-type
1609
1610     drop pair-type
1611     pad charlist>cstr
1612     pad swap load
1613 ; make-primitive load
1614
1615 \ }}}
1616
1617 \ ---- REPL ----
1618
1619 : repl
1620     cr ." Welcome to scheme.forth.jl!" cr
1621        ." Use Ctrl-D to exit." cr
1622
1623     empty-parse-str
1624
1625     enable-gc
1626
1627     begin
1628         cr bold fg green ." > " reset-term
1629         read-console
1630
1631         2dup EOF character-type objeq? if
1632             2drop
1633             bold fg blue ." Moriturus te saluto." reset-term cr
1634             exit
1635         then
1636
1637         global-env obj@ eval
1638
1639         fg cyan ." ; " print reset-term
1640     again
1641 ;
1642
1643 forth definitions
1644
1645 \ vim:fdm=marker