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     2dup nil objeq? 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         2dup nil objeq? 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     repeat
 426 ;
 427
 428 : make-macro ( name_symbol params body env -- )
 429     make-procedure
 430
 431     2swap ( proc name_symbol )
 432
 433     macro-table obj@
 434
 435     begin
 436         nil? false =
 437     while
 438         2over 2over ( proc name table name table )
 439         car car objeq? if
 440             2swap 2drop ( proc table )
 441             car ( proc entry )
 442             set-cdr!
 443             exit
 444         then
 445     repeat
 446
 447     2drop
 448
 449     2swap cons
 450     macro-table obj@ cons
 451     macro-table obj!
 452 ;
 453
 454 \ }}}
 455
 456 \ ---- Read ---- {{{
 457
 458 variable parse-idx
 459 variable stored-parse-idx
 460 create parse-str 161 allot
 461 variable parse-str-span
 462
 463 create parse-idx-stack 10 allot
 464 variable parse-idx-sp
 465 parse-idx-stack parse-idx-sp !
 466
 467 : push-parse-idx
 468     parse-idx @ parse-idx-sp @ !
 469     1 parse-idx-sp +!
 470 ;
 471
 472 : pop-parse-idx
 473     parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
 474
 475     1 parse-idx-sp -!
 476
 477     parse-idx-sp @ @ parse-idx ! ;
 478
 479
 480 : append-newline
 481     '\n' parse-str parse-str-span @ + !
 482     1 parse-str-span +! ;
 483
 484 : append-eof
 485     4 parse-str parse-str-span @ + !
 486     1 parse-str-span +!  ;
 487
 488 : empty-parse-str
 489     0 parse-str-span !
 490     0 parse-idx ! ;
 491
 492 : getline
 493     current-input-port obj@ console-i/o-port obj@ objeq? if
 494         parse-str 160 expect cr
 495         span @ parse-str-span !
 496     else
 497         parse-str 160 current-input-port obj@ fileport>fid read-line
 498         drop swap parse-str-span !
 499
 500         parse-str-span @ 0= and if append-eof then
 501     then
 502     append-newline
 503     0 parse-idx ! ;
 504
 505 : inc-parse-idx
 506     1 parse-idx +! ;
 507
 508 : dec-parse-idx
 509     1 parse-idx -! ;
 510
 511 : charavailable? ( -- bool )
 512     parse-str-span @ parse-idx @ > ;
 513
 514 : nextchar ( -- char )
 515     charavailable? false = if getline then
 516     parse-str parse-idx @ + @ ;
 517
 518 : '\t' 9 ;
 519 : whitespace? ( -- bool )
 520     nextchar BL =
 521     nextchar '\n' =
 522     nextchar '\t' =
 523     or or ;
 524
 525 : EOF 4 ;
 526 : eof? ( -- bool )
 527     nextchar EOF = ;
 528
 529 : delim? ( -- bool )
 530     whitespace?
 531     nextchar [char] ( = or
 532     nextchar [char] ) = or
 533 ;
 534
 535 : commentstart? ( -- bool )
 536     nextchar [char] ; = ;
 537
 538 : eatspaces
 539
 540     false \ Indicates whether or not we're eating a comment
 541
 542     begin
 543         dup whitespace? or commentstart? or
 544     while
 545         dup nextchar '\n' = and if
 546             invert \ Stop eating comment
 547         else
 548             dup false = commentstart? and if
 549                 invert \ Begin eating comment
 550             then
 551         then
 552
 553         inc-parse-idx
 554     repeat
 555     drop
 556 ;
 557
 558 : digit? ( -- bool )
 559     nextchar [char] 0 >=
 560     nextchar [char] 9 <=
 561     and ;
 562
 563 : minus? ( -- bool )
 564     nextchar [char] - = ;
 565
 566 : plus? ( -- bool )
 567     nextchar [char] + = ;
 568
 569 : fixnum? ( -- bool )
 570     minus? plus? or if
 571         inc-parse-idx
 572
 573         delim? if
 574             dec-parse-idx
 575             false exit
 576         else
 577             dec-parse-idx
 578         then
 579     else
 580         digit? false = if
 581             false exit
 582         then
 583     then
 584
 585     push-parse-idx
 586     inc-parse-idx
 587
 588     begin digit? while
 589         inc-parse-idx
 590     repeat
 591
 592     delim? pop-parse-idx
 593 ;
 594
 595 : realnum? ( -- bool )
 596     push-parse-idx
 597
 598     minus? plus? or if
 599         inc-parse-idx
 600     then
 601
 602     \ Record starting parse idx:
 603     \ Want to detect whether any characters (following +/-) were eaten.
 604     parse-idx @
 605
 606     begin digit? while
 607             inc-parse-idx
 608     repeat
 609
 610     [char] . nextchar = if
 611         inc-parse-idx
 612         begin digit? while
 613                 inc-parse-idx
 614         repeat
 615     then
 616
 617     [char] e nextchar = [char] E nextchar = or if
 618         inc-parse-idx
 619
 620         minus? plus? or if
 621             inc-parse-idx
 622         then
 623
 624         digit? invert if
 625             drop pop-parse-idx false exit
 626         then
 627
 628         begin digit? while
 629                 inc-parse-idx
 630         repeat
 631     then
 632
 633     \ This is a real number if characters were
 634     \ eaten and the next characer is a delimiter.
 635     parse-idx @ < delim? and
 636
 637     pop-parse-idx
 638 ;
 639
 640 : boolean? ( -- bool )
 641     nextchar [char] # <> if false exit then
 642
 643     push-parse-idx
 644     inc-parse-idx
 645
 646     nextchar [char] t <>
 647     nextchar [char] f <>
 648     and if pop-parse-idx false exit then
 649
 650     inc-parse-idx
 651     delim? if
 652         pop-parse-idx
 653         true
 654     else
 655         pop-parse-idx
 656         false
 657     then
 658 ;
 659
 660 : str-equiv? ( str -- bool )
 661
 662     push-parse-idx
 663
 664     true -rot
 665
 666     swap dup rot + swap
 667
 668     do
 669         i @ nextchar <> if
 670             drop false
 671             leave
 672         then
 673
 674         inc-parse-idx
 675     loop
 676
 677     delim? false = if drop false then
 678
 679     pop-parse-idx
 680 ;
 681
 682 : character? ( -- bool )
 683     nextchar [char] # <> if false exit then
 684
 685     push-parse-idx
 686     inc-parse-idx
 687
 688     nextchar [char] \ <> if pop-parse-idx false exit then
 689
 690     inc-parse-idx
 691
 692     S" newline" str-equiv? if pop-parse-idx true exit then
 693     S" space" str-equiv? if pop-parse-idx true exit then
 694     S" tab" str-equiv? if pop-parse-idx true exit then
 695
 696     charavailable? false = if pop-parse-idx false exit then
 697
 698     pop-parse-idx true
 699 ;
 700
 701 : pair? ( -- bool )
 702     nextchar [char] ( = ;
 703
 704 : string? ( -- bool )
 705     nextchar [char] " = ;
 706
 707 : readfixnum ( -- num-atom )
 708     plus? minus? or if
 709         minus?
 710         inc-parse-idx
 711     else
 712         false
 713     then
 714
 715     0
 716
 717     begin digit? while
 718         10 * nextchar [char] 0 - +
 719         inc-parse-idx
 720     repeat
 721
 722     swap if negate then
 723
 724     fixnum-type
 725 ;
 726
 727 : readrealnum ( -- realnum )
 728
 729     \ Remember that at this point we're guaranteed to
 730     \ have a parsable real on this line.
 731
 732     parse-str parse-idx @ +
 733
 734     begin delim? false = while
 735             inc-parse-idx
 736     repeat
 737
 738     parse-str parse-idx @ + over -
 739
 740     float-parse
 741
 742     realnum-type
 743 ;
 744
 745 : readbool ( -- bool-obj )
 746     inc-parse-idx
 747
 748     nextchar [char] f = if
 749         false
 750     else
 751         true
 752     then
 753
 754     inc-parse-idx
 755
 756     boolean-type
 757 ;
 758
 759 : readchar ( -- char-obj )
 760     inc-parse-idx
 761     inc-parse-idx
 762
 763     S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
 764     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
 765     S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
 766
 767     nextchar character-type
 768
 769     inc-parse-idx
 770 ;
 771
 772 : readstring ( -- charlist )
 773     nextchar [char] " = if
 774         inc-parse-idx
 775
 776         delim? false = if
 777             bold fg red
 778             ." No delimiter following right double quote. Aborting." cr
 779             reset-term abort
 780         then
 781
 782         dec-parse-idx
 783
 784         0 nil-type exit
 785     then
 786
 787     nextchar [char] \ = if
 788         inc-parse-idx
 789         nextchar case
 790             [char] n of '\n' endof
 791             [char] " of [char] " endof
 792             [char] \
 793         endcase
 794     else
 795         nextchar
 796     then
 797     inc-parse-idx character-type
 798
 799     recurse
 800
 801     cons
 802 ;
 803
 804 : readsymbol ( -- charlist )
 805     delim? if nil exit then
 806
 807     nextchar inc-parse-idx character-type
 808
 809     recurse
 810
 811     cons
 812 ;
 813
 814 : readpair ( -- pairobj )
 815     eatspaces
 816
 817     \ Empty lists
 818     nextchar [char] ) = if
 819         inc-parse-idx
 820
 821         delim? false = if
 822             bold fg red
 823             ." No delimiter following right paren. Aborting." cr
 824             reset-term abort
 825         then
 826
 827         dec-parse-idx
 828
 829         0 nil-type exit
 830     then
 831
 832     \ Read first pair element
 833     read
 834
 835     \ Pairs
 836     eatspaces
 837     nextchar [char] . = if
 838         inc-parse-idx
 839
 840         delim? false = if
 841             bold fg red
 842             ." No delimiter following '.'. Aborting." cr
 843             reset-term abort
 844         then
 845
 846         eatspaces read
 847     else
 848         recurse
 849     then
 850
 851     eatspaces
 852
 853     cons
 854 ;
 855
 856 \ Parse a scheme expression
 857 :noname ( -- obj )
 858
 859     eatspaces
 860
 861     fixnum? if
 862         readfixnum
 863         exit
 864     then
 865
 866     realnum? if
 867         readrealnum
 868         exit
 869     then
 870
 871     boolean? if
 872         readbool
 873         exit
 874     then
 875
 876     character? if
 877         readchar
 878         exit
 879     then
 880
 881     string? if
 882         inc-parse-idx
 883
 884         readstring
 885         drop string-type
 886
 887         nextchar [char] " <> if
 888             bold red ." Missing closing double-quote." reset-term cr
 889             abort
 890         then
 891
 892         inc-parse-idx
 893
 894         exit
 895     then
 896
 897     pair? if
 898         inc-parse-idx
 899
 900         eatspaces
 901
 902         readpair
 903
 904         eatspaces
 905
 906         nextchar [char] ) <> if
 907             bold red ." Missing closing paren." reset-term cr
 908             abort
 909         then
 910
 911         inc-parse-idx
 912
 913         exit
 914     then
 915
 916     nextchar [char] ' = if
 917         inc-parse-idx
 918         quote-symbol recurse nil cons cons exit
 919     then
 920
 921     eof? if
 922         EOF character-type
 923         inc-parse-idx
 924         exit
 925     then
 926
 927     \ Anything else is parsed as a symbol
 928     readsymbol charlist>symbol
 929
 930     \ Replace λ with lambda
 931     2dup λ-symbol objeq? if
 932         2drop lambda-symbol
 933     then
 934
 935
 936 ; is read
 937
 938 \ }}}
 939
 940 \ ---- Eval ---- {{{
 941
 942 : self-evaluating? ( obj -- obj bool )
 943     boolean-type istype? if true exit then
 944     fixnum-type istype? if true exit then
 945     realnum-type istype? if true exit then
 946     character-type istype? if true exit then
 947     string-type istype? if true exit then
 948     nil-type istype? if true exit then
 949     none-type istype? if true exit then
 950
 951     false
 952 ;
 953
 954 : tagged-list? ( obj tag-obj -- obj bool )
 955     2over
 956     pair-type istype? false = if
 957         2drop 2drop false
 958     else
 959         car objeq?
 960     then ;
 961
 962 : quote? ( obj -- obj bool )
 963     quote-symbol tagged-list?  ;
 964
 965 : quote-body ( quote-obj -- quote-body-obj )
 966     cadr ;
 967
 968 : variable? ( obj -- obj bool )
 969     symbol-type istype? ;
 970
 971 : definition? ( obj -- obj bool )
 972     define-symbol tagged-list? ;
 973
 974 : make-lambda ( params body -- lambda-exp )
 975     lambda-symbol -2rot cons cons ;
 976
 977 : definition-var ( obj -- var )
 978     cdr car
 979     symbol-type istype? false = if car then
 980 ;
 981
 982 : definition-val ( obj -- val )
 983     2dup cdr car symbol-type istype? if
 984         2drop
 985         cdr cdr car
 986     else
 987         cdr 2swap cdr cdr
 988         make-lambda
 989     then
 990 ;
 991
 992 : assignment? ( obj -- obj bool )
 993     set!-symbol tagged-list? ;
 994
 995 : assignment-var ( obj -- var )
 996     cdr car ;
 997
 998 : assignment-val ( obj -- val )
 999     cdr cdr car ;
1000
1001 : eval-definition ( obj env -- res )
1002     2swap
1003     2over 2over ( env obj env obj )
1004     definition-val 2swap ( env obj valexp env )
1005     eval  ( env obj val )
1006
1007     2swap definition-var 2swap ( env var val )
1008
1009     2rot ( var val env )
1010     define-var
1011
1012     ok-symbol
1013 ;
1014
1015 : eval-assignment ( obj env -- res )
1016     2swap
1017     2over 2over ( env obj env obj )
1018     assignment-val 2swap ( env obj valexp env )
1019     eval  ( env obj val )
1020
1021     2swap assignment-var 2swap ( env var val )
1022
1023     2rot ( var val env )
1024     set-var
1025
1026     ok-symbol
1027 ;
1028
1029 : macro-definition? ( obj -- obj bool )
1030     define-macro-symbol tagged-list? ;
1031
1032 : macro-definition-name ( exp -- mname )
1033     cdr car car ;
1034
1035 : macro-definition-params ( exp -- params )
1036     cdr car cdr ;
1037
1038 : macro-definition-body ( exp -- body )
1039     cdr cdr ;
1040
1041 objvar env
1042 : eval-define-macro ( obj env -- res )
1043     env obj!
1044
1045     2dup macro-definition-name 2swap ( name obj )
1046     2dup macro-definition-params 2swap ( name params obj )
1047     macro-definition-body ( name params body )
1048
1049     env obj@ ( name params body env )
1050
1051     make-macro
1052
1053     ok-symbol
1054 ;
1055 hide env
1056
1057 : if? ( obj -- obj bool )
1058     if-symbol tagged-list? ;
1059
1060 : if-predicate ( ifobj -- pred )
1061     cdr car ;
1062
1063 : if-consequent ( ifobj -- conseq )
1064     cdr cdr car ;
1065
1066 : if-alternative ( ifobj -- alt|false )
1067     cdr cdr cdr
1068     2dup nil objeq? if
1069         2drop false
1070     else
1071         car
1072     then ;
1073
1074 : false? ( boolobj -- boolean )
1075     boolean-type istype? if
1076         false boolean-type objeq?
1077     else
1078         2drop false
1079     then
1080 ;
1081
1082 : true? ( boolobj -- bool )
1083     false? invert ;
1084
1085 : lambda? ( obj -- obj bool )
1086     lambda-symbol tagged-list? ;
1087
1088 : lambda-parameters ( obj -- params )
1089     cdr car ;
1090
1091 : lambda-body ( obj -- body )
1092     cdr cdr ;
1093
1094 : begin? ( obj -- obj bool )
1095     begin-symbol tagged-list? ;
1096
1097 : begin-actions ( obj -- actions )
1098     cdr ;
1099
1100 : eval-sequence ( explist env -- finalexp env )
1101     ( Evaluates all bar the final expressions in
1102       an an expression list. The final expression
1103       is returned to allow for tail optimization. )
1104
1105     2swap ( env explist )
1106
1107     \ Abort on empty list
1108     2dup nil objeq? if
1109         2drop none
1110         2swap exit
1111     then
1112
1113     begin
1114         2dup cdr ( env explist nextexplist )
1115         2dup nil objeq? false =
1116     while
1117         -2rot car 2over ( nextexplist env exp env )
1118         eval
1119         2drop \ discard result
1120         2swap ( env nextexplist )
1121     repeat
1122
1123     2drop car 2swap ( finalexp env )
1124 ;
1125
1126 : application? ( obj -- obj bool )
1127     pair-type istype? ;
1128
1129 : operator ( obj -- operator )
1130     car ;
1131
1132 : operands ( obj -- operands )
1133     cdr ;
1134
1135 : nooperands? ( operands -- bool )
1136     nil objeq? ;
1137
1138 : first-operand ( operands -- operand )
1139     car ;
1140
1141 : rest-operands ( operands -- other-operands )
1142     cdr ;
1143
1144 : list-of-vals ( args env -- vals )
1145     2swap
1146
1147     2dup nooperands? if
1148         2swap 2drop
1149     else
1150         2over 2over first-operand 2swap eval
1151         -2rot rest-operands 2swap recurse
1152         cons
1153     then
1154 ;
1155
1156 : procedure-params ( proc -- params )
1157     drop pair-type car ;
1158
1159 : procedure-body ( proc -- body )
1160     drop pair-type cdr car ;
1161
1162 : procedure-env ( proc -- body )
1163     drop pair-type cdr cdr car ;
1164
1165 ( Ensure terminating symbol arg name is handled
1166   specially to allow for variadic procedures. )
1167 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1168     nil? if exit then
1169
1170     symbol-type istype? if
1171         nil cons
1172         2swap
1173         nil cons
1174         2swap
1175         exit
1176     then
1177
1178     2over cdr 2over cdr
1179     recurse ( argvals argnames argvals'' argnames'' )
1180     2rot car 2swap cons  ( argvals argvals'' argnames' )
1181     2rot car 2rot cons ( argnames' argvals' )
1182     2swap
1183 ;
1184
1185 : apply ( proc argvals )
1186         2swap dup case
1187             primitive-proc-type of
1188                 drop execute
1189             endof
1190
1191             compound-proc-type of
1192                 2dup procedure-body ( argvals proc body )
1193                 -2rot 2dup procedure-params ( body argvals proc argnames )
1194                 -2rot procedure-env ( body argnames argvals procenv )
1195
1196                 -2rot 2swap
1197                 flatten-proc-args
1198                 2swap 2rot
1199
1200                 extend-env ( body env )
1201
1202                 eval-sequence
1203
1204                 R> drop ['] eval goto-deferred  \ Tail call optimization
1205             endof
1206
1207             bold fg red ." Object not applicable. Aboring." reset-term cr
1208             abort
1209         endcase
1210 ;
1211
1212 :noname ( obj env -- result )
1213     2swap
1214
1215     self-evaluating? if
1216         2swap 2drop
1217         exit
1218     then
1219
1220     quote? if
1221         quote-body
1222         2swap 2drop
1223         exit
1224     then
1225
1226     variable? if
1227         2swap lookup-var
1228         exit
1229     then
1230
1231     definition? if
1232         2swap eval-definition
1233         exit
1234     then
1235
1236     assignment? if
1237         2swap eval-assignment
1238         exit
1239     then
1240
1241     macro-definition? if
1242         2swap eval-define-macro
1243         exit
1244     then
1245
1246     if? if
1247         2over 2over
1248         if-predicate
1249         2swap eval
1250
1251         true? if
1252             if-consequent
1253         else
1254             if-alternative
1255         then
1256
1257         2swap
1258         ['] eval goto-deferred
1259     then
1260
1261     lambda? if
1262         2dup lambda-parameters
1263         2swap lambda-body
1264         2rot make-procedure
1265         exit
1266     then
1267
1268     begin? if
1269         begin-actions 2swap
1270         eval-sequence
1271         ['] eval goto-deferred
1272     then
1273
1274     application? if
1275
1276         2over 2over ( env exp env exp )
1277         operator 2dup ( env exp env opname opname )
1278
1279         lookup-macro 2dup nil objeq? if
1280             \ Regular function application
1281
1282             2drop ( env exp env opname )
1283
1284             2swap eval ( env exp proc )
1285             -2rot ( proc env exp )
1286             operands 2swap ( proc operands env )
1287             list-of-vals ( proc argvals )
1288
1289             apply
1290         else
1291             \ Macro function evaluation
1292
1293             ( env exp env opname mproc )
1294             2swap 2drop -2rot 2drop  ( env mproc exp )
1295             apply 2swap ( expanded-exp env )
1296
1297             ['] eval goto-deferred
1298         then
1299         exit
1300     then
1301
1302     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
1303     abort
1304 ; is eval
1305
1306 \ }}}
1307
1308 \ ---- Print ---- {{{
1309
1310 : printfixnum ( fixnumobj -- ) drop 0 .R ;
1311
1312 : printrealnum ( realnumobj -- ) drop float-print ;
1313
1314 : printbool ( numobj -- )
1315     drop if
1316         ." #t"
1317     else
1318         ." #f"
1319     then
1320 ;
1321
1322 : printchar ( charobj -- )
1323     drop
1324     case
1325         9 of ." #\tab" endof
1326         bl of ." #\space" endof
1327         '\n' of ." #\newline" endof
1328
1329         dup ." #\" emit
1330     endcase
1331 ;
1332
1333 : (printstring) ( stringobj -- )
1334     nil-type istype? if 2drop exit then
1335
1336     2dup car drop dup
1337     case
1338         '\n' of ." \n" drop endof
1339         [char] \ of ." \\" drop endof
1340         [char] " of [char] \ emit [char] " emit drop endof
1341         emit
1342     endcase
1343
1344     cdr recurse
1345 ;
1346 : printstring ( stringobj -- )
1347     [char] " emit
1348     (printstring)
1349     [char] " emit ;
1350
1351 : printsymbol ( symbolobj -- )
1352     nil-type istype? if 2drop exit then
1353
1354     2dup car drop emit
1355     cdr recurse
1356 ;
1357
1358 : printnil ( nilobj -- )
1359     2drop ." ()" ;
1360
1361 : printpair ( pairobj -- )
1362     2dup
1363     car print
1364     cdr
1365     nil-type istype? if 2drop exit then
1366     pair-type istype? if space recurse exit then
1367     ."  . " print
1368 ;
1369
1370 : printprim ( primobj -- )
1371     2drop ." <primitive procedure>" ;
1372
1373 : printcomp ( primobj -- )
1374     2drop ." <compound procedure>" ;
1375
1376 : printnone ( noneobj -- )
1377     2drop ." Unspecified return value" ;
1378
1379 :noname ( obj -- )
1380     fixnum-type istype? if printfixnum exit then
1381     realnum-type istype? if printrealnum exit then
1382     boolean-type istype? if printbool exit then
1383     character-type istype? if printchar exit then
1384     string-type istype? if printstring exit then
1385     symbol-type istype? if printsymbol exit then
1386     nil-type istype? if printnil exit then
1387     pair-type istype? if ." (" printpair ." )" exit then
1388     primitive-proc-type istype? if printprim exit then
1389     compound-proc-type istype? if printcomp exit then
1390     none-type istype? if printnone exit then
1391
1392     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
1393     abort
1394 ; is print
1395
1396 \ }}}
1397
1398 \ ---- Garbage Collection ---- {{{
1399
1400 variable gc-enabled
1401 false gc-enabled !
1402
1403 variable gc-stack-depth
1404
1405 : enable-gc
1406     depth gc-stack-depth !
1407     true gc-enabled ! ;
1408
1409 : disable-gc
1410     false gc-enabled ! ;
1411
1412 : gc-enabled?
1413     gc-enabled @ ;
1414
1415 : pairlike? ( obj -- obj bool )
1416     pair-type istype? if true exit then
1417     string-type istype? if true exit then
1418     symbol-type istype? if true exit then
1419     compound-proc-type istype? if true exit then
1420
1421     false
1422 ;
1423
1424 : pairlike-marked? ( obj -- obj bool )
1425     over nextfrees + @ 0=
1426 ;
1427
1428 : mark-pairlike ( obj -- obj )
1429         over nextfrees + 0 swap !
1430 ;
1431
1432 : gc-unmark ( -- )
1433     scheme-memsize 0 do
1434         1 nextfrees i + !
1435     loop
1436 ;
1437
1438 : gc-mark-obj ( obj -- )
1439
1440     pairlike? invert if 2drop exit then
1441     pairlike-marked? if 2drop exit then
1442
1443     mark-pairlike
1444
1445     drop pair-type 2dup
1446
1447     car recurse
1448     cdr recurse
1449 ;
1450
1451 : gc-sweep
1452     scheme-memsize nextfree !
1453     0 scheme-memsize 1- do
1454         nextfrees i + @ 0<> if
1455             nextfree @ nextfrees i + !
1456             i nextfree !
1457         then
1458     -1 +loop
1459 ;
1460
1461 \ Following a GC, this gives the amount of free memory
1462 : gc-count-marked
1463     0
1464     scheme-memsize 0 do
1465         nextfrees i + @ 0= if 1+ then
1466     loop
1467 ;
1468
1469 \ Debugging word - helps spot memory that is retained
1470 : gc-zero-unmarked
1471     scheme-memsize 0 do
1472         nextfrees i + @ 0<> if
1473             0 car-cells i + !
1474             0 cdr-cells i + !
1475         then
1476     loop
1477 ;
1478
1479 :noname
1480     \ ." GC! "
1481
1482     gc-unmark
1483
1484     symbol-table obj@ gc-mark-obj
1485     macro-table obj@ gc-mark-obj
1486     global-env obj@ gc-mark-obj
1487
1488     depth gc-stack-depth @ do
1489         PSP0 i + 1 + @
1490         PSP0 i + 2 + @
1491
1492         gc-mark-obj
1493     2 +loop
1494
1495     gc-sweep
1496
1497     \ ." (" gc-count-marked . ." pairs marked as used.)" cr
1498 ; is collect-garbage
1499
1500 \ }}}
1501
1502 \ ---- Primitives ---- {{{
1503
1504 : make-primitive ( cfa -- )
1505     bl word
1506     count
1507
1508     \ 2dup ." Defining primitive " type ." ..." cr
1509
1510     cstr>charlist
1511     drop symbol-type
1512
1513     2dup
1514
1515     symbol-table obj@
1516     cons
1517     symbol-table obj!
1518
1519     rot primitive-proc-type ( var prim )
1520     global-env obj@ define-var
1521 ;
1522
1523 : arg-count-error
1524             bold fg red ." Incorrect argument count." reset-term cr
1525             abort
1526 ;
1527
1528 : ensure-arg-count ( args n -- )
1529     dup 0= if
1530         drop nil objeq? false = if
1531             arg-count-error
1532         then
1533     else
1534         -rot 2dup nil objeq? if
1535             arg-count-error
1536         then
1537
1538         cdr rot 1- recurse
1539     then
1540 ;
1541
1542 : arg-type-error
1543             bold fg red ." Incorrect argument type." reset-term cr
1544             abort
1545 ;
1546
1547 : ensure-arg-type ( arg type -- arg )
1548     istype? false = if
1549         arg-type-error
1550     then
1551 ;
1552
1553 include scheme-primitives.4th
1554
1555 \ }}}
1556
1557 \ ---- Loading files ---- {{{
1558
1559 : charlist>cstr ( charlist addr -- n )
1560
1561     dup 2swap ( origaddr addr charlist )
1562
1563     begin
1564         2dup nil objeq? false =
1565     while
1566         2dup cdr 2swap car
1567         drop ( origaddr addr charlist char )
1568         -rot 2swap ( origaddr charlist addr char )
1569         over !
1570         1+ -rot ( origaddr nextaddr charlist )
1571     repeat
1572
1573     2drop ( origaddr finaladdr )
1574     swap -
1575 ;
1576
1577 : load ( addr n -- finalResult )
1578     open-input-file
1579
1580     empty-parse-str
1581
1582     ok-symbol ( port res )
1583
1584     begin
1585         2over read-port ( port res obj )
1586
1587         2dup EOF character-type objeq? if
1588             2drop 2swap close-port
1589             exit
1590         then
1591
1592         2swap 2drop ( port obj )
1593
1594         global-env obj@ eval ( port res )
1595     again
1596 ;
1597
1598 :noname ( args -- finalResult )
1599     2dup 1 ensure-arg-count
1600     car string-type ensure-arg-type
1601
1602     drop pair-type
1603     pad charlist>cstr
1604     pad swap load
1605 ; make-primitive load
1606
1607 \ }}}
1608
1609 \ ---- REPL ----
1610
1611 : repl
1612     cr ." Welcome to scheme.forth.jl!" cr
1613        ." Use Ctrl-D to exit." cr
1614
1615     empty-parse-str
1616
1617     enable-gc
1618
1619     begin
1620         cr bold fg green ." > " reset-term
1621         read-console
1622
1623         2dup EOF character-type objeq? if
1624             2drop
1625             bold fg blue ." Moriturus te saluto." reset-term cr
1626             exit
1627         then
1628
1629         global-env obj@ eval
1630
1631         fg cyan ." ; " print reset-term
1632     again
1633 ;
1634
1635 forth definitions
1636
1637 \ vim:fdm=marker