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 iterative expansion of defines in
1026   terms of nested lambdas. Most Schemes only
1027   handle one iteration of expansion! )
1028 : definition-var-val ( obj -- var val )
1029
1030     cdr 2dup cdr 2swap car ( val var )
1031
1032     begin
1033         symbol-type istype? false =
1034     while
1035         2dup cdr 2swap car ( val formals var' )
1036         -2rot 2swap ( var' formals val )
1037         make-lambda nil cons ( var' val' )
1038         2swap ( val' var' )
1039     repeat
1040
1041     2swap car
1042 ;
1043
1044 : eval-definition ( obj env -- res )
1045     2dup 2rot ( env env obj )
1046     definition-var-val ( env env var val )
1047     2rot eval  ( env var val )
1048
1049     2rot ( var val env )
1050     define-var
1051
1052     ok-symbol
1053 ;
1054
1055 : assignment? ( obj -- obj bool )
1056     set!-symbol tagged-list? ;
1057
1058 : assignment-var ( obj -- var )
1059     cdr car ;
1060
1061 : assignment-val ( obj -- val )
1062     cdr cdr car ;
1063
1064 : eval-assignment ( obj env -- res )
1065     2swap
1066     2over 2over ( env obj env obj )
1067     assignment-val 2swap ( env obj valexp env )
1068     eval  ( env obj val )
1069
1070     2swap assignment-var 2swap ( env var val )
1071
1072     2rot ( var val env )
1073     set-var
1074
1075     ok-symbol
1076 ;
1077
1078 : macro-definition? ( obj -- obj bool )
1079     define-macro-symbol tagged-list? ;
1080
1081 : macro-definition-name ( exp -- mname )
1082     cdr car car ;
1083
1084 : macro-definition-params ( exp -- params )
1085     cdr car cdr ;
1086
1087 : macro-definition-body ( exp -- body )
1088     cdr cdr ;
1089
1090 objvar env
1091 : eval-define-macro ( obj env -- res )
1092     env obj!
1093
1094     2dup macro-definition-name 2swap ( name obj )
1095     2dup macro-definition-params 2swap ( name params obj )
1096     macro-definition-body ( name params body )
1097
1098     env obj@ ( name params body env )
1099
1100     make-macro
1101
1102     ok-symbol
1103 ;
1104 hide env
1105
1106 : if? ( obj -- obj bool )
1107     if-symbol tagged-list? ;
1108
1109 : if-predicate ( ifobj -- pred )
1110     cdr car ;
1111
1112 : if-consequent ( ifobj -- conseq )
1113     cdr cdr car ;
1114
1115 : if-alternative ( ifobj -- alt|false )
1116     cdr cdr cdr
1117     nil? if
1118         2drop false
1119     else
1120         car
1121     then ;
1122
1123 : false? ( boolobj -- boolean )
1124     boolean-type istype? if
1125         false boolean-type objeq?
1126     else
1127         2drop false
1128     then
1129 ;
1130
1131 : true? ( boolobj -- bool )
1132     false? invert ;
1133
1134 : lambda? ( obj -- obj bool )
1135     lambda-symbol tagged-list? ;
1136
1137 : lambda-parameters ( obj -- params )
1138     cdr car ;
1139
1140 : lambda-body ( obj -- body )
1141     cdr cdr ;
1142
1143 : begin? ( obj -- obj bool )
1144     begin-symbol tagged-list? ;
1145
1146 : begin-actions ( obj -- actions )
1147     cdr ;
1148
1149 : eval-sequence ( explist env -- finalexp env )
1150     ( Evaluates all bar the final expressions in
1151       an an expression list. The final expression
1152       is returned to allow for tail optimization. )
1153
1154     2swap ( env explist )
1155
1156     \ Abort on empty list
1157     nil? if
1158         2drop none
1159         2swap exit
1160     then
1161
1162     begin
1163         2dup cdr ( env explist nextexplist )
1164         nil? false =
1165     while
1166         -2rot car 2over ( nextexplist env exp env )
1167         eval
1168         2drop \ discard result
1169         2swap ( env nextexplist )
1170     repeat
1171
1172     2drop car 2swap ( finalexp env )
1173 ;
1174
1175 : application? ( obj -- obj bool )
1176     pair-type istype? ;
1177
1178 : operator ( obj -- operator )
1179     car ;
1180
1181 : operands ( obj -- operands )
1182     cdr ;
1183
1184 : nooperands? ( operands -- bool )
1185     nil objeq? ;
1186
1187 : first-operand ( operands -- operand )
1188     car ;
1189
1190 : rest-operands ( operands -- other-operands )
1191     cdr ;
1192
1193 : list-of-vals ( args env -- vals )
1194     2swap
1195
1196     2dup nooperands? if
1197         2swap 2drop
1198     else
1199         2over 2over first-operand 2swap eval
1200         -2rot rest-operands 2swap recurse
1201         cons
1202     then
1203 ;
1204
1205 : procedure-params ( proc -- params )
1206     drop pair-type car ;
1207
1208 : procedure-body ( proc -- body )
1209     drop pair-type cdr car ;
1210
1211 : procedure-env ( proc -- body )
1212     drop pair-type cdr cdr car ;
1213
1214 ( Ensure terminating symbol arg name is handled
1215   specially to allow for variadic procedures. )
1216 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1217     nil? if
1218         2over nil? false = if
1219             bold fg red ." Too many arguments supplied to compound method. Aborting." reset-term cr
1220             abort
1221         else
1222             2drop
1223         then
1224         exit
1225     then
1226
1227     symbol-type istype? if
1228         nil cons
1229         2swap
1230         nil cons
1231         2swap
1232         exit
1233     then
1234
1235     2over
1236     nil? if
1237         bold fg red ." Too few arguments supplied to compound method. Aborting." reset-term cr
1238         abort
1239     else
1240         cdr
1241     then
1242
1243     2over cdr
1244
1245     recurse ( argvals argnames argvals'' argnames'' )
1246     2rot car 2swap cons  ( argvals argvals'' argnames' )
1247     2rot car 2rot cons ( argnames' argvals' )
1248     2swap
1249 ;
1250
1251 : apply ( proc argvals -- result )
1252         2swap dup case
1253             primitive-proc-type of
1254                 drop execute
1255             endof
1256
1257             compound-proc-type of
1258                 2dup procedure-body ( argvals proc body )
1259                 -2rot 2dup procedure-params ( body argvals proc argnames )
1260                 -2rot procedure-env ( body argnames argvals procenv )
1261
1262                 -2rot 2swap
1263                 flatten-proc-args
1264                 2swap 2rot
1265
1266                 extend-env ( body env )
1267
1268                 eval-sequence
1269
1270                 R> drop ['] eval goto-deferred  \ Tail call optimization
1271             endof
1272
1273             bold fg red ." Object not applicable. Aborting." reset-term cr
1274             abort
1275         endcase
1276 ;
1277
1278 : macro-expand ( proc expbody -- result )
1279     2swap
1280     2dup procedure-body ( expbody proc procbody )
1281     -2rot 2dup procedure-params ( procbody expbody proc argnames )
1282     -2rot procedure-env ( procbody argnames expbody procenv )
1283
1284     -2rot 2swap
1285     flatten-proc-args
1286     2swap 2rot
1287
1288     extend-env eval-sequence eval
1289 ;
1290
1291 :noname ( obj env -- result )
1292     2swap
1293
1294     self-evaluating? if
1295         2swap 2drop
1296         exit
1297     then
1298
1299     quote? if
1300         quote-body
1301         2swap 2drop
1302         exit
1303     then
1304
1305     variable? if
1306         2swap lookup-var
1307         exit
1308     then
1309
1310     definition? if
1311         2swap eval-definition
1312         exit
1313     then
1314
1315     assignment? if
1316         2swap eval-assignment
1317         exit
1318     then
1319
1320     macro-definition? if
1321         2swap eval-define-macro
1322         exit
1323     then
1324
1325     if? if
1326         2over 2over
1327         if-predicate
1328         2swap eval
1329
1330         true? if
1331             if-consequent
1332         else
1333             if-alternative
1334         then
1335
1336         2swap
1337         ['] eval goto-deferred
1338     then
1339
1340     lambda? if
1341         2dup lambda-parameters
1342         2swap lambda-body
1343         2rot make-procedure
1344         exit
1345     then
1346
1347     begin? if
1348         begin-actions 2swap
1349         eval-sequence
1350         ['] eval goto-deferred
1351     then
1352
1353     application? if
1354
1355         2over 2over ( env exp env exp )
1356         operator ( env exp env opname )
1357
1358         2dup lookup-macro nil? false = if
1359              \ Macro function evaluation
1360
1361             ( env exp env opname mproc )
1362             2swap 2drop -2rot 2drop cdr ( env mproc body )
1363
1364             macro-expand
1365
1366             2swap
1367             ['] eval goto-deferred
1368         else
1369            \ Regular function application
1370
1371             2drop ( env exp env opname )
1372
1373             2swap eval ( env exp proc )
1374
1375             -2rot ( proc env exp )
1376             operands 2swap ( proc operands env )
1377             list-of-vals ( proc argvals )
1378
1379             apply
1380             exit
1381         then
1382     then
1383
1384     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
1385     abort
1386 ; is eval
1387
1388 \ }}}
1389
1390 \ ---- Print ---- {{{
1391
1392 : printfixnum ( fixnumobj -- ) drop 0 .R ;
1393
1394 : printrealnum ( realnumobj -- ) drop float-print ;
1395
1396 : printbool ( numobj -- )
1397     drop if
1398         ." #t"
1399     else
1400         ." #f"
1401     then
1402 ;
1403
1404 : printchar ( charobj -- )
1405     drop
1406     case
1407         9 of ." #\tab" endof
1408         bl of ." #\space" endof
1409         '\n' of ." #\newline" endof
1410
1411         dup ." #\" emit
1412     endcase
1413 ;
1414
1415 : (printstring) ( stringobj -- )
1416     nil-type istype? if 2drop exit then
1417
1418     2dup car drop dup
1419     case
1420         '\n' of ." \n" drop endof
1421         [char] \ of ." \\" drop endof
1422         [char] " of [char] \ emit [char] " emit drop endof
1423         emit
1424     endcase
1425
1426     cdr recurse
1427 ;
1428 : printstring ( stringobj -- )
1429     [char] " emit
1430     (printstring)
1431     [char] " emit ;
1432
1433 : printsymbol ( symbolobj -- )
1434     nil-type istype? if 2drop exit then
1435
1436     2dup car drop emit
1437     cdr recurse
1438 ;
1439
1440 : printnil ( nilobj -- )
1441     2drop ." ()" ;
1442
1443 : printpair ( pairobj -- )
1444     2dup
1445     car print
1446     cdr
1447     nil-type istype? if 2drop exit then
1448     pair-type istype? if space recurse exit then
1449     ."  . " print
1450 ;
1451
1452 : printprim ( primobj -- )
1453     2drop ." <primitive procedure>" ;
1454
1455 : printcomp ( primobj -- )
1456     2drop ." <compound procedure>" ;
1457
1458 : printnone ( noneobj -- )
1459     2drop ." Unspecified return value" ;
1460
1461 :noname ( obj -- )
1462     fixnum-type istype? if printfixnum exit then
1463     realnum-type istype? if printrealnum exit then
1464     boolean-type istype? if printbool exit then
1465     character-type istype? if printchar exit then
1466     string-type istype? if printstring exit then
1467     symbol-type istype? if printsymbol exit then
1468     nil-type istype? if printnil exit then
1469     pair-type istype? if ." (" printpair ." )" exit then
1470     primitive-proc-type istype? if printprim exit then
1471     compound-proc-type istype? if printcomp exit then
1472     none-type istype? if printnone exit then
1473
1474     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
1475     abort
1476 ; is print
1477
1478 \ }}}
1479
1480 \ ---- Garbage Collection ---- {{{
1481
1482 variable gc-enabled
1483 false gc-enabled !
1484
1485 variable gc-stack-depth
1486
1487 : enable-gc
1488     depth gc-stack-depth !
1489     true gc-enabled ! ;
1490
1491 : disable-gc
1492     false gc-enabled ! ;
1493
1494 : gc-enabled?
1495     gc-enabled @ ;
1496
1497 : pairlike? ( obj -- obj bool )
1498     pair-type istype? if true exit then
1499     string-type istype? if true exit then
1500     symbol-type istype? if true exit then
1501     compound-proc-type istype? if true exit then
1502
1503     false
1504 ;
1505
1506 : pairlike-marked? ( obj -- obj bool )
1507     over nextfrees + @ 0=
1508 ;
1509
1510 : mark-pairlike ( obj -- obj )
1511         over nextfrees + 0 swap !
1512 ;
1513
1514 : gc-unmark ( -- )
1515     scheme-memsize 0 do
1516         1 nextfrees i + !
1517     loop
1518 ;
1519
1520 : gc-mark-obj ( obj -- )
1521
1522     pairlike? invert if 2drop exit then
1523     pairlike-marked? if 2drop exit then
1524
1525     mark-pairlike
1526
1527     drop pair-type 2dup
1528
1529     car recurse
1530     cdr recurse
1531 ;
1532
1533 : gc-sweep
1534     scheme-memsize nextfree !
1535     0 scheme-memsize 1- do
1536         nextfrees i + @ 0<> if
1537             nextfree @ nextfrees i + !
1538             i nextfree !
1539         then
1540     -1 +loop
1541 ;
1542
1543 \ Following a GC, this gives the amount of free memory
1544 : gc-count-marked
1545     0
1546     scheme-memsize 0 do
1547         nextfrees i + @ 0= if 1+ then
1548     loop
1549 ;
1550
1551 \ Debugging word - helps spot memory that is retained
1552 : gc-zero-unmarked
1553     scheme-memsize 0 do
1554         nextfrees i + @ 0<> if
1555             0 car-cells i + !
1556             0 cdr-cells i + !
1557         then
1558     loop
1559 ;
1560
1561 :noname
1562     \ ." GC! "
1563
1564     gc-unmark
1565
1566     symbol-table obj@ gc-mark-obj
1567     macro-table obj@ gc-mark-obj
1568     global-env obj@ gc-mark-obj
1569
1570     depth gc-stack-depth @ do
1571         PSP0 i + 1 + @
1572         PSP0 i + 2 + @
1573
1574         gc-mark-obj
1575     2 +loop
1576
1577     gc-sweep
1578
1579     \ ." (" gc-count-marked . ." pairs marked as used.)" cr
1580 ; is collect-garbage
1581
1582 \ }}}
1583
1584 \ ---- Loading files ---- {{{
1585
1586 : charlist>cstr ( charlist addr -- n )
1587
1588     dup 2swap ( origaddr addr charlist )
1589
1590     begin
1591         nil? false =
1592     while
1593         2dup cdr 2swap car
1594         drop ( origaddr addr charlist char )
1595         -rot 2swap ( origaddr charlist addr char )
1596         over !
1597         1+ -rot ( origaddr nextaddr charlist )
1598     repeat
1599
1600     2drop ( origaddr finaladdr )
1601     swap -
1602 ;
1603
1604 : load ( addr n -- finalResult )
1605     open-input-file
1606
1607     empty-parse-str
1608
1609     ok-symbol ( port res )
1610
1611     begin
1612         2over read-port ( port res obj )
1613
1614         2dup EOF character-type objeq? if
1615             2drop 2swap close-port
1616             exit
1617         then
1618
1619         2swap 2drop ( port obj )
1620
1621         global-env obj@ eval ( port res )
1622     again
1623 ;
1624
1625 \ }}}
1626
1627 \ ---- Standard Library ---- {{{
1628
1629     include scheme-primitives.4th
1630
1631     s" scheme-library.scm" load 2drop
1632
1633 \ }}}
1634
1635 \ ---- REPL ----
1636
1637 : repl
1638     cr ." Welcome to scheme.forth.jl!" cr
1639        ." Use Ctrl-D to exit." cr
1640
1641     empty-parse-str
1642
1643     enable-gc
1644
1645     begin
1646         cr bold fg green ." > " reset-term
1647         read-console
1648
1649         2dup EOF character-type objeq? if
1650             2drop
1651             bold fg blue ." Moriturus te saluto." reset-term cr
1652             exit
1653         then
1654
1655         global-env obj@ eval
1656
1657         fg cyan ." ; " print reset-term
1658     again
1659 ;
1660
1661 forth definitions
1662
1663 \ vim:fdm=marker