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 : lookup-macro ( name_symbol -- proc? bool )
 412     macro-table obj@
 413
 414     begin
 415         nil? false =
 416     while
 417         2over 2over
 418         car car objeq? if
 419             2swap 2drop
 420             car cdr
 421             true exit
 422         then
 423     repeat
 424
 425     2drop false
 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 : if? ( obj -- obj bool )
1033     if-symbol tagged-list? ;
1034
1035 : if-predicate ( ifobj -- pred )
1036     cdr car ;
1037
1038 : if-consequent ( ifobj -- conseq )
1039     cdr cdr car ;
1040
1041 : if-alternative ( ifobj -- alt|false )
1042     cdr cdr cdr
1043     2dup nil objeq? if
1044         2drop false
1045     else
1046         car
1047     then ;
1048
1049 : false? ( boolobj -- boolean )
1050     boolean-type istype? if
1051         false boolean-type objeq?
1052     else
1053         2drop false
1054     then
1055 ;
1056
1057 : true? ( boolobj -- bool )
1058     false? invert ;
1059
1060 : lambda? ( obj -- obj bool )
1061     lambda-symbol tagged-list? ;
1062
1063 : lambda-parameters ( obj -- params )
1064     cdr car ;
1065
1066 : lambda-body ( obj -- body )
1067     cdr cdr ;
1068
1069 : begin? ( obj -- obj bool )
1070     begin-symbol tagged-list? ;
1071
1072 : begin-actions ( obj -- actions )
1073     cdr ;
1074
1075 : eval-sequence ( explist env -- finalexp env )
1076     ( Evaluates all bar the final expressions in
1077       an an expression list. The final expression
1078       is returned to allow for tail optimization. )
1079
1080     2swap ( env explist )
1081
1082     \ Abort on empty list
1083     2dup nil objeq? if
1084         2drop none
1085         2swap exit
1086     then
1087
1088     begin
1089         2dup cdr ( env explist nextexplist )
1090         2dup nil objeq? false =
1091     while
1092         -2rot car 2over ( nextexplist env exp env )
1093         eval
1094         2drop \ discard result
1095         2swap ( env nextexplist )
1096     repeat
1097
1098     2drop car 2swap ( finalexp env )
1099 ;
1100
1101 : application? ( obj -- obj bool )
1102     pair-type istype? ;
1103
1104 : operator ( obj -- operator )
1105     car ;
1106
1107 : operands ( obj -- operands )
1108     cdr ;
1109
1110 : nooperands? ( operands -- bool )
1111     nil objeq? ;
1112
1113 : first-operand ( operands -- operand )
1114     car ;
1115
1116 : rest-operands ( operands -- other-operands )
1117     cdr ;
1118
1119 : list-of-vals ( args env -- vals )
1120     2swap
1121
1122     2dup nooperands? if
1123         2swap 2drop
1124     else
1125         2over 2over first-operand 2swap eval
1126         -2rot rest-operands 2swap recurse
1127         cons
1128     then
1129 ;
1130
1131 : procedure-params ( proc -- params )
1132     drop pair-type car ;
1133
1134 : procedure-body ( proc -- body )
1135     drop pair-type cdr car ;
1136
1137 : procedure-env ( proc -- body )
1138     drop pair-type cdr cdr car ;
1139
1140 ( Ensure terminating symbol arg name is handled
1141   specially to allow for variadic procedures. )
1142 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1143     nil? if exit then
1144
1145     symbol-type istype? if
1146         nil cons
1147         2swap
1148         nil cons
1149         2swap
1150         exit
1151     then
1152
1153     2over cdr 2over cdr
1154     recurse ( argvals argnames argvals'' argnames'' )
1155     2rot car 2swap cons  ( argvals argvals'' argnames' )
1156     2rot car 2rot cons ( argnames' argvals' )
1157     2swap
1158 ;
1159
1160 : apply ( proc argvals )
1161         2swap dup case
1162             primitive-proc-type of
1163                 drop execute
1164             endof
1165
1166             compound-proc-type of
1167                 2dup procedure-body ( argvals proc body )
1168                 -2rot 2dup procedure-params ( body argvals proc argnames )
1169                 -2rot procedure-env ( body argnames argvals procenv )
1170
1171                 -2rot 2swap
1172                 flatten-proc-args
1173                 2swap 2rot
1174
1175                 extend-env ( body env )
1176
1177                 eval-sequence
1178
1179                 R> drop ['] eval goto-deferred  \ Tail call optimization
1180             endof
1181
1182             bold fg red ." Object not applicable. Aboring." reset-term cr
1183             abort
1184         endcase
1185 ;
1186
1187 :noname ( obj env -- result )
1188     2swap
1189
1190     self-evaluating? if
1191         2swap 2drop
1192         exit
1193     then
1194
1195     quote? if
1196         quote-body
1197         2swap 2drop
1198         exit
1199     then
1200
1201     variable? if
1202         2swap lookup-var
1203         exit
1204     then
1205
1206     definition? if
1207         2swap eval-definition
1208         exit
1209     then
1210
1211     assignment? if
1212         2swap eval-assignment
1213         exit
1214     then
1215
1216     macro-definition? if
1217         2swap eval-define-macro
1218         exit
1219     then
1220
1221     if? if
1222         2over 2over
1223         if-predicate
1224         2swap eval
1225
1226         true? if
1227             if-consequent
1228         else
1229             if-alternative
1230         then
1231
1232         2swap
1233         ['] eval goto-deferred
1234     then
1235
1236     lambda? if
1237         2dup lambda-parameters
1238         2swap lambda-body
1239         2rot make-procedure
1240         exit
1241     then
1242
1243     begin? if
1244         begin-actions 2swap
1245         eval-sequence
1246         ['] eval goto-deferred
1247     then
1248
1249     application? if
1250
1251         2over 2over
1252         operator
1253
1254         find-macro-proc nil objeq? if
1255             \ Regular function application
1256
1257             2swap eval
1258             -2rot
1259             operands 2swap list-of-vals
1260
1261             apply
1262         else
1263             \ Macro function evaluation
1264
1265             2swap 2drop 2swap ( env mproc exp )
1266
1267             apply 2swap ( expanded-exp env )
1268
1269             ['] eval goto-deferred
1270         then
1271         exit
1272     then
1273
1274     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
1275     abort
1276 ; is eval
1277
1278 \ }}}
1279
1280 \ ---- Print ---- {{{
1281
1282 : printfixnum ( fixnumobj -- ) drop 0 .R ;
1283
1284 : printrealnum ( realnumobj -- ) drop float-print ;
1285
1286 : printbool ( numobj -- )
1287     drop if
1288         ." #t"
1289     else
1290         ." #f"
1291     then
1292 ;
1293
1294 : printchar ( charobj -- )
1295     drop
1296     case
1297         9 of ." #\tab" endof
1298         bl of ." #\space" endof
1299         '\n' of ." #\newline" endof
1300
1301         dup ." #\" emit
1302     endcase
1303 ;
1304
1305 : (printstring) ( stringobj -- )
1306     nil-type istype? if 2drop exit then
1307
1308     2dup car drop dup
1309     case
1310         '\n' of ." \n" drop endof
1311         [char] \ of ." \\" drop endof
1312         [char] " of [char] \ emit [char] " emit drop endof
1313         emit
1314     endcase
1315
1316     cdr recurse
1317 ;
1318 : printstring ( stringobj -- )
1319     [char] " emit
1320     (printstring)
1321     [char] " emit ;
1322
1323 : printsymbol ( symbolobj -- )
1324     nil-type istype? if 2drop exit then
1325
1326     2dup car drop emit
1327     cdr recurse
1328 ;
1329
1330 : printnil ( nilobj -- )
1331     2drop ." ()" ;
1332
1333 : printpair ( pairobj -- )
1334     2dup
1335     car print
1336     cdr
1337     nil-type istype? if 2drop exit then
1338     pair-type istype? if space recurse exit then
1339     ."  . " print
1340 ;
1341
1342 : printprim ( primobj -- )
1343     2drop ." <primitive procedure>" ;
1344
1345 : printcomp ( primobj -- )
1346     2drop ." <compound procedure>" ;
1347
1348 : printnone ( noneobj -- )
1349     2drop ." Unspecified return value" ;
1350
1351 :noname ( obj -- )
1352     fixnum-type istype? if printfixnum exit then
1353     realnum-type istype? if printrealnum exit then
1354     boolean-type istype? if printbool exit then
1355     character-type istype? if printchar exit then
1356     string-type istype? if printstring exit then
1357     symbol-type istype? if printsymbol exit then
1358     nil-type istype? if printnil exit then
1359     pair-type istype? if ." (" printpair ." )" exit then
1360     primitive-proc-type istype? if printprim exit then
1361     compound-proc-type istype? if printcomp exit then
1362     none-type istype? if printnone exit then
1363
1364     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
1365     abort
1366 ; is print
1367
1368 \ }}}
1369
1370 \ ---- Garbage Collection ---- {{{
1371
1372 variable gc-enabled
1373 false gc-enabled !
1374
1375 variable gc-stack-depth
1376
1377 : enable-gc
1378     depth gc-stack-depth !
1379     true gc-enabled ! ;
1380
1381 : disable-gc
1382     false gc-enabled ! ;
1383
1384 : gc-enabled?
1385     gc-enabled @ ;
1386
1387 : pairlike? ( obj -- obj bool )
1388     pair-type istype? if true exit then
1389     string-type istype? if true exit then
1390     symbol-type istype? if true exit then
1391     compound-proc-type istype? if true exit then
1392
1393     false
1394 ;
1395
1396 : pairlike-marked? ( obj -- obj bool )
1397     over nextfrees + @ 0=
1398 ;
1399
1400 : mark-pairlike ( obj -- obj )
1401         over nextfrees + 0 swap !
1402 ;
1403
1404 : gc-unmark ( -- )
1405     scheme-memsize 0 do
1406         1 nextfrees i + !
1407     loop
1408 ;
1409
1410 : gc-mark-obj ( obj -- )
1411
1412     pairlike? invert if 2drop exit then
1413     pairlike-marked? if 2drop exit then
1414
1415     mark-pairlike
1416
1417     drop pair-type 2dup
1418
1419     car recurse
1420     cdr recurse
1421 ;
1422
1423 : gc-sweep
1424     scheme-memsize nextfree !
1425     0 scheme-memsize 1- do
1426         nextfrees i + @ 0<> if
1427             nextfree @ nextfrees i + !
1428             i nextfree !
1429         then
1430     -1 +loop
1431 ;
1432
1433 \ Following a GC, this gives the amount of free memory
1434 : gc-count-marked
1435     0
1436     scheme-memsize 0 do
1437         nextfrees i + @ 0= if 1+ then
1438     loop
1439 ;
1440
1441 \ Debugging word - helps spot memory that is retained
1442 : gc-zero-unmarked
1443     scheme-memsize 0 do
1444         nextfrees i + @ 0<> if
1445             0 car-cells i + !
1446             0 cdr-cells i + !
1447         then
1448     loop
1449 ;
1450
1451 :noname
1452     \ ." GC! "
1453
1454     gc-unmark
1455
1456     symbol-table obj@ gc-mark-obj
1457     macro-table obj@ gc-mark-obj
1458     global-env obj@ gc-mark-obj
1459
1460     depth gc-stack-depth @ do
1461         PSP0 i + 1 + @
1462         PSP0 i + 2 + @
1463
1464         gc-mark-obj
1465     2 +loop
1466
1467     gc-sweep
1468
1469     \ ." (" gc-count-marked . ." pairs marked as used.)" cr
1470 ; is collect-garbage
1471
1472 \ }}}
1473
1474 \ ---- Primitives ---- {{{
1475
1476 : make-primitive ( cfa -- )
1477     bl word
1478     count
1479
1480     \ 2dup ." Defining primitive " type ." ..." cr
1481
1482     cstr>charlist
1483     drop symbol-type
1484
1485     2dup
1486
1487     symbol-table obj@
1488     cons
1489     symbol-table obj!
1490
1491     rot primitive-proc-type ( var prim )
1492     global-env obj@ define-var
1493 ;
1494
1495 : arg-count-error
1496             bold fg red ." Incorrect argument count." reset-term cr
1497             abort
1498 ;
1499
1500 : ensure-arg-count ( args n -- )
1501     dup 0= if
1502         drop nil objeq? false = if
1503             arg-count-error
1504         then
1505     else
1506         -rot 2dup nil objeq? if
1507             arg-count-error
1508         then
1509
1510         cdr rot 1- recurse
1511     then
1512 ;
1513
1514 : arg-type-error
1515             bold fg red ." Incorrect argument type." reset-term cr
1516             abort
1517 ;
1518
1519 : ensure-arg-type ( arg type -- arg )
1520     istype? false = if
1521         arg-type-error
1522     then
1523 ;
1524
1525 include scheme-primitives.4th
1526
1527 \ }}}
1528
1529 \ ---- Loading files ---- {{{
1530
1531 : charlist>cstr ( charlist addr -- n )
1532
1533     dup 2swap ( origaddr addr charlist )
1534
1535     begin
1536         2dup nil objeq? false =
1537     while
1538         2dup cdr 2swap car
1539         drop ( origaddr addr charlist char )
1540         -rot 2swap ( origaddr charlist addr char )
1541         over !
1542         1+ -rot ( origaddr nextaddr charlist )
1543     repeat
1544
1545     2drop ( origaddr finaladdr )
1546     swap -
1547 ;
1548
1549 : load ( addr n -- finalResult )
1550     open-input-file
1551
1552     empty-parse-str
1553
1554     ok-symbol ( port res )
1555
1556     begin
1557         2over read-port ( port res obj )
1558
1559         2dup EOF character-type objeq? if
1560             2drop 2swap close-port
1561             exit
1562         then
1563
1564         2swap 2drop ( port obj )
1565
1566         global-env obj@ eval ( port res )
1567     again
1568 ;
1569
1570 :noname ( args -- finalResult )
1571     2dup 1 ensure-arg-count
1572     car string-type ensure-arg-type
1573
1574     drop pair-type
1575     pad charlist>cstr
1576     pad swap load
1577 ; make-primitive load
1578
1579 \ }}}
1580
1581 \ ---- REPL ----
1582
1583 : repl
1584     cr ." Welcome to scheme.forth.jl!" cr
1585        ." Use Ctrl-D to exit." cr
1586
1587     empty-parse-str
1588
1589     enable-gc
1590
1591     begin
1592         cr bold fg green ." > " reset-term
1593         read-console
1594
1595         2dup EOF character-type objeq? if
1596             2drop
1597             bold fg blue ." Moriturus te saluto." reset-term cr
1598             exit
1599         then
1600
1601         global-env obj@ eval
1602
1603         fg cyan ." ; " print reset-term
1604     again
1605 ;
1606
1607 forth definitions
1608
1609 \ vim:fdm=marker