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