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