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