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 : apply ( proc args )
1088         2swap dup case
1089             primitive-proc-type of
1090                 drop execute
1091             endof
1092
1093             compound-proc-type of
1094                 2dup procedure-body ( args proc body )
1095                 -2rot 2dup procedure-params ( body args proc params )
1096                 -2rot procedure-env ( body params args procenv )
1097
1098                 extend-env ( body env )
1099
1100                 eval-sequence
1101
1102                 R> drop ['] eval goto-deferred  \ Tail call optimization
1103             endof
1104
1105             bold fg red ." Object not applicable. Aboring." reset-term cr
1106             abort
1107         endcase
1108 ;
1109
1110 :noname ( obj env -- result )
1111     2swap
1112
1113     self-evaluating? if
1114         2swap 2drop
1115         exit
1116     then
1117
1118     quote? if
1119         quote-body
1120         2swap 2drop
1121         exit
1122     then
1123
1124     variable? if
1125         2swap lookup-var
1126         exit
1127     then
1128
1129     definition? if
1130         2swap eval-definition
1131         exit
1132     then
1133
1134     assignment? if
1135         2swap eval-assignment
1136         exit
1137     then
1138
1139     if? if
1140         2over 2over
1141         if-predicate
1142         2swap eval
1143
1144         true? if
1145             if-consequent
1146         else
1147             if-alternative
1148         then
1149
1150         2swap
1151         ['] eval goto-deferred
1152     then
1153
1154     lambda? if
1155         2dup lambda-parameters
1156         2swap lambda-body
1157         2rot make-procedure
1158         exit
1159     then
1160
1161     begin? if
1162         begin-actions 2swap
1163         eval-sequence
1164         ['] eval goto-deferred
1165     then
1166
1167     application? if
1168         2over 2over
1169         operator 2swap eval
1170         -2rot
1171         operands 2swap list-of-vals
1172
1173         apply
1174         exit
1175     then
1176
1177     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
1178     abort
1179 ; is eval
1180
1181 \ }}}
1182
1183 \ ---- Print ---- {{{
1184
1185 : printfixnum ( fixnumobj -- ) drop 0 .R ;
1186
1187 : printrealnum ( realnumobj -- ) drop float-print ;
1188
1189 : printbool ( numobj -- )
1190     drop if
1191         ." #t"
1192     else
1193         ." #f"
1194     then
1195 ;
1196
1197 : printchar ( charobj -- )
1198     drop
1199     case
1200         9 of ." #\tab" endof
1201         bl of ." #\space" endof
1202         '\n' of ." #\newline" endof
1203
1204         dup ." #\" emit
1205     endcase
1206 ;
1207
1208 : (printstring) ( stringobj -- )
1209     nil-type istype? if 2drop exit then
1210
1211     2dup car drop dup
1212     case
1213         '\n' of ." \n" drop endof
1214         [char] \ of ." \\" drop endof
1215         [char] " of [char] \ emit [char] " emit drop endof
1216         emit
1217     endcase
1218
1219     cdr recurse
1220 ;
1221 : printstring ( stringobj -- )
1222     [char] " emit
1223     (printstring)
1224     [char] " emit ;
1225
1226 : printsymbol ( symbolobj -- )
1227     nil-type istype? if 2drop exit then
1228
1229     2dup car drop emit
1230     cdr recurse
1231 ;
1232
1233 : printnil ( nilobj -- )
1234     2drop ." ()" ;
1235
1236 : printpair ( pairobj -- )
1237     2dup
1238     car print
1239     cdr
1240     nil-type istype? if 2drop exit then
1241     pair-type istype? if space recurse exit then
1242     ."  . " print
1243 ;
1244
1245 : printprim ( primobj -- )
1246     2drop ." <primitive procedure>" ;
1247
1248 : printcomp ( primobj -- )
1249     2drop ." <compound procedure>" ;
1250
1251 : printnone ( noneobj -- )
1252     2drop ." Unspecified return value" ;
1253
1254 :noname ( obj -- )
1255     fixnum-type istype? if printfixnum exit then
1256     realnum-type istype? if printrealnum exit then
1257     boolean-type istype? if printbool exit then
1258     character-type istype? if printchar exit then
1259     string-type istype? if printstring exit then
1260     symbol-type istype? if printsymbol exit then
1261     nil-type istype? if printnil exit then
1262     pair-type istype? if ." (" printpair ." )" exit then
1263     primitive-proc-type istype? if printprim exit then
1264     compound-proc-type istype? if printcomp exit then
1265     none-type istype? if printnone exit then
1266
1267     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
1268     abort
1269 ; is print
1270
1271 \ }}}
1272
1273 \ ---- Garbage Collection ---- {{{
1274
1275 variable gc-enabled
1276 false gc-enabled !
1277
1278 variable gc-stack-depth
1279
1280 : enable-gc
1281     depth gc-stack-depth !
1282     true gc-enabled ! ;
1283
1284 : disable-gc
1285     false gc-enabled ! ;
1286
1287 : gc-enabled?
1288     gc-enabled @ ;
1289
1290 : pairlike? ( obj -- obj bool )
1291     pair-type istype? if true exit then
1292     string-type istype? if true exit then
1293     symbol-type istype? if true exit then
1294     compound-proc-type istype? if true exit then
1295
1296     false
1297 ;
1298
1299 : pairlike-marked? ( obj -- obj bool )
1300     over nextfrees + @ 0=
1301 ;
1302
1303 : mark-pairlike ( obj -- obj )
1304         over nextfrees + 0 swap !
1305 ;
1306
1307 : gc-unmark ( -- )
1308     scheme-memsize 0 do
1309         1 nextfrees i + !
1310     loop
1311 ;
1312
1313 : gc-mark-obj ( obj -- )
1314
1315     pairlike? invert if 2drop exit then
1316     pairlike-marked? if 2drop exit then
1317
1318     mark-pairlike
1319
1320     drop pair-type 2dup
1321
1322     car recurse
1323     cdr recurse
1324 ;
1325
1326 : gc-sweep
1327     scheme-memsize nextfree !
1328     0 scheme-memsize 1- do
1329         nextfrees i + @ 0<> if
1330             nextfree @ nextfrees i + !
1331             i nextfree !
1332         then
1333     -1 +loop
1334 ;
1335
1336 \ Following a GC, this gives the amount of free memory
1337 : gc-count-marked
1338     0
1339     scheme-memsize 0 do
1340         nextfrees i + @ 0= if 1+ then
1341     loop
1342 ;
1343
1344 \ Debugging word - helps spot memory that is retained
1345 : gc-zero-unmarked
1346     scheme-memsize 0 do
1347         nextfrees i + @ 0<> if
1348             0 car-cells i + !
1349             0 cdr-cells i + !
1350         then
1351     loop
1352 ;
1353
1354 :noname
1355     \ ." GC! "
1356
1357     gc-unmark
1358
1359     symbol-table obj@ gc-mark-obj
1360     global-env obj@ gc-mark-obj
1361
1362     depth gc-stack-depth @ do
1363         PSP0 i + 1 + @
1364         PSP0 i + 2 + @
1365
1366         gc-mark-obj
1367     2 +loop
1368
1369     gc-sweep
1370
1371     \ ." (" gc-count-marked . ." pairs marked as used.)" cr
1372 ; is collect-garbage
1373
1374 \ }}}
1375
1376 \ ---- Primitives ---- {{{
1377
1378 : make-primitive ( cfa -- )
1379     bl word
1380     count
1381
1382     \ 2dup ." Defining primitive " type ." ..." cr
1383
1384     cstr>charlist
1385     drop symbol-type
1386
1387     2dup
1388
1389     symbol-table obj@
1390     cons
1391     symbol-table obj!
1392
1393     rot primitive-proc-type ( var prim )
1394     global-env obj@ define-var
1395 ;
1396
1397 : arg-count-error
1398             bold fg red ." Incorrect argument count." reset-term cr
1399             abort
1400 ;
1401
1402 : ensure-arg-count ( args n -- )
1403     dup 0= if
1404         drop nil objeq? false = if
1405             arg-count-error
1406         then
1407     else
1408         -rot 2dup nil objeq? if
1409             arg-count-error
1410         then
1411
1412         cdr rot 1- recurse
1413     then
1414 ;
1415
1416 : arg-type-error
1417             bold fg red ." Incorrect argument type." reset-term cr
1418             abort
1419 ;
1420
1421 : ensure-arg-type ( arg type -- arg )
1422     istype? false = if
1423         arg-type-error
1424     then
1425 ;
1426
1427 include scheme-primitives.4th
1428
1429 \ }}}
1430
1431 \ ---- Loading files ---- {{{
1432
1433 : charlist>cstr ( charlist addr -- n )
1434
1435     dup 2swap ( origaddr addr charlist )
1436
1437     begin
1438         2dup nil objeq? false =
1439     while
1440         2dup cdr 2swap car
1441         drop ( origaddr addr charlist char )
1442         -rot 2swap ( origaddr charlist addr char )
1443         over !
1444         1+ -rot ( origaddr nextaddr charlist )
1445     repeat
1446
1447     2drop ( origaddr finaladdr )
1448     swap -
1449 ;
1450
1451 : load ( addr n -- finalResult )
1452     open-input-file
1453
1454     empty-parse-str
1455
1456     ok-symbol ( port res )
1457
1458     begin
1459         2over read-port ( port res obj )
1460
1461         2dup EOF character-type objeq? if
1462             2drop 2swap close-port
1463             exit
1464         then
1465
1466         2swap 2drop ( port obj )
1467
1468         global-env obj@ eval ( port res )
1469     again
1470 ;
1471
1472 :noname ( args -- finalResult )
1473     2dup 1 ensure-arg-count
1474     car string-type ensure-arg-type
1475
1476     drop pair-type
1477     pad charlist>cstr
1478     pad swap load
1479 ; make-primitive load
1480
1481 \ }}}
1482
1483 \ ---- REPL ----
1484
1485 : repl
1486     cr ." Welcome to scheme.forth.jl!" cr
1487        ." Use Ctrl-D to exit." cr
1488
1489     empty-parse-str
1490
1491     enable-gc
1492
1493     begin
1494         cr bold fg green ." > " reset-term
1495         read-console
1496
1497         2dup EOF character-type objeq? if
1498             2drop
1499             bold fg blue ." Moriturus te saluto." reset-term cr
1500             exit
1501         then
1502
1503         global-env obj@ eval
1504
1505         fg cyan ." ; " print reset-term
1506     again
1507 ;
1508
1509 forth definitions
1510
1511 \ vim:fdm=marker