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