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