scheme.4th

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