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