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 : definition-var ( obj -- var )
1026     cdr car
1027     symbol-type istype? false = if car then
1028 ;
1029
1030 : definition-val ( obj -- val )
1031     2dup cdr car symbol-type istype? if
1032         2drop
1033         cdr cdr car
1034     else
1035         cdr 2swap cdr cdr
1036         make-lambda
1037     then
1038 ;
1039
1040 : assignment? ( obj -- obj bool )
1041     set!-symbol tagged-list? ;
1042
1043 : assignment-var ( obj -- var )
1044     cdr car ;
1045
1046 : assignment-val ( obj -- val )
1047     cdr cdr car ;
1048
1049 : eval-definition ( obj env -- res )
1050     2swap
1051     2over 2over ( env obj env obj )
1052     definition-val 2swap ( env obj valexp env )
1053     eval  ( env obj val )
1054
1055     2swap definition-var 2swap ( env var val )
1056
1057     2rot ( var val env )
1058     define-var
1059
1060     ok-symbol
1061 ;
1062
1063 : eval-assignment ( obj env -- res )
1064     2swap
1065     2over 2over ( env obj env obj )
1066     assignment-val 2swap ( env obj valexp env )
1067     eval  ( env obj val )
1068
1069     2swap assignment-var 2swap ( env var val )
1070
1071     2rot ( var val env )
1072     set-var
1073
1074     ok-symbol
1075 ;
1076
1077 : macro-definition? ( obj -- obj bool )
1078     define-macro-symbol tagged-list? ;
1079
1080 : macro-definition-name ( exp -- mname )
1081     cdr car car ;
1082
1083 : macro-definition-params ( exp -- params )
1084     cdr car cdr ;
1085
1086 : macro-definition-body ( exp -- body )
1087     cdr cdr ;
1088
1089 objvar env
1090 : eval-define-macro ( obj env -- res )
1091     env obj!
1092
1093     2dup macro-definition-name 2swap ( name obj )
1094     2dup macro-definition-params 2swap ( name params obj )
1095     macro-definition-body ( name params body )
1096
1097     env obj@ ( name params body env )
1098
1099     make-macro
1100
1101     ok-symbol
1102 ;
1103 hide env
1104
1105 : if? ( obj -- obj bool )
1106     if-symbol tagged-list? ;
1107
1108 : if-predicate ( ifobj -- pred )
1109     cdr car ;
1110
1111 : if-consequent ( ifobj -- conseq )
1112     cdr cdr car ;
1113
1114 : if-alternative ( ifobj -- alt|false )
1115     cdr cdr cdr
1116     nil? if
1117         2drop false
1118     else
1119         car
1120     then ;
1121
1122 : false? ( boolobj -- boolean )
1123     boolean-type istype? if
1124         false boolean-type objeq?
1125     else
1126         2drop false
1127     then
1128 ;
1129
1130 : true? ( boolobj -- bool )
1131     false? invert ;
1132
1133 : lambda? ( obj -- obj bool )
1134     lambda-symbol tagged-list? ;
1135
1136 : lambda-parameters ( obj -- params )
1137     cdr car ;
1138
1139 : lambda-body ( obj -- body )
1140     cdr cdr ;
1141
1142 : begin? ( obj -- obj bool )
1143     begin-symbol tagged-list? ;
1144
1145 : begin-actions ( obj -- actions )
1146     cdr ;
1147
1148 : eval-sequence ( explist env -- finalexp env )
1149     ( Evaluates all bar the final expressions in
1150       an an expression list. The final expression
1151       is returned to allow for tail optimization. )
1152
1153     2swap ( env explist )
1154
1155     \ Abort on empty list
1156     nil? if
1157         2drop none
1158         2swap exit
1159     then
1160
1161     begin
1162         2dup cdr ( env explist nextexplist )
1163         nil? false =
1164     while
1165         -2rot car 2over ( nextexplist env exp env )
1166         eval
1167         2drop \ discard result
1168         2swap ( env nextexplist )
1169     repeat
1170
1171     2drop car 2swap ( finalexp env )
1172 ;
1173
1174 : application? ( obj -- obj bool )
1175     pair-type istype? ;
1176
1177 : operator ( obj -- operator )
1178     car ;
1179
1180 : operands ( obj -- operands )
1181     cdr ;
1182
1183 : nooperands? ( operands -- bool )
1184     nil objeq? ;
1185
1186 : first-operand ( operands -- operand )
1187     car ;
1188
1189 : rest-operands ( operands -- other-operands )
1190     cdr ;
1191
1192 : list-of-vals ( args env -- vals )
1193     2swap
1194
1195     2dup nooperands? if
1196         2swap 2drop
1197     else
1198         2over 2over first-operand 2swap eval
1199         -2rot rest-operands 2swap recurse
1200         cons
1201     then
1202 ;
1203
1204 : procedure-params ( proc -- params )
1205     drop pair-type car ;
1206
1207 : procedure-body ( proc -- body )
1208     drop pair-type cdr car ;
1209
1210 : procedure-env ( proc -- body )
1211     drop pair-type cdr cdr car ;
1212
1213 ( Ensure terminating symbol arg name is handled
1214   specially to allow for variadic procedures. )
1215 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1216     nil? if exit then
1217
1218     symbol-type istype? if
1219         nil cons
1220         2swap
1221         nil cons
1222         2swap
1223         exit
1224     then
1225
1226     2over cdr 2over cdr
1227     recurse ( argvals argnames argvals'' argnames'' )
1228     2rot car 2swap cons  ( argvals argvals'' argnames' )
1229     2rot car 2rot cons ( argnames' argvals' )
1230     2swap
1231 ;
1232
1233 :noname
1234     \ Dummy apply procedure
1235     \ Should never actually run!
1236     ." Error: Dummy apply procedure executed!" cr
1237 ; dup make-primitive apply
1238 objvar dummy-apply-proc
1239 primitive-proc-type dummy-apply-proc obj!
1240
1241 : apply ( proc argvals -- result )
1242         2swap dup case
1243             primitive-proc-type of
1244                 drop execute
1245             endof
1246
1247             compound-proc-type of
1248                 2dup procedure-body ( argvals proc body )
1249                 -2rot 2dup procedure-params ( body argvals proc argnames )
1250                 -2rot procedure-env ( body argnames argvals procenv )
1251
1252                 -2rot 2swap
1253                 flatten-proc-args
1254                 2swap 2rot
1255
1256                 extend-env ( body env )
1257
1258                 eval-sequence
1259
1260                 R> drop ['] eval goto-deferred  \ Tail call optimization
1261             endof
1262
1263             bold fg red ." Object not applicable. Aborting." reset-term cr
1264             abort
1265         endcase
1266 ;
1267
1268 : macro-expand ( proc expbody -- result )
1269     2swap
1270     2dup procedure-body ( expbody proc procbody )
1271     -2rot 2dup procedure-params ( procbody expbody proc argnames )
1272     -2rot procedure-env ( procbody argnames expbody procenv )
1273
1274     -2rot 2swap
1275     flatten-proc-args
1276     2swap 2rot
1277
1278     extend-env eval-sequence eval
1279 ;
1280
1281 :noname ( obj env -- result )
1282     2swap
1283
1284     self-evaluating? if
1285         2swap 2drop
1286         exit
1287     then
1288
1289     quote? if
1290         quote-body
1291         2swap 2drop
1292         exit
1293     then
1294
1295     variable? if
1296         2swap lookup-var
1297         exit
1298     then
1299
1300     definition? if
1301         2swap eval-definition
1302         exit
1303     then
1304
1305     assignment? if
1306         2swap eval-assignment
1307         exit
1308     then
1309
1310     macro-definition? if
1311         2swap eval-define-macro
1312         exit
1313     then
1314
1315     if? if
1316         2over 2over
1317         if-predicate
1318         2swap eval
1319
1320         true? if
1321             if-consequent
1322         else
1323             if-alternative
1324         then
1325
1326         2swap
1327         ['] eval goto-deferred
1328     then
1329
1330     lambda? if
1331         2dup lambda-parameters
1332         2swap lambda-body
1333         2rot make-procedure
1334         exit
1335     then
1336
1337     begin? if
1338         begin-actions 2swap
1339         eval-sequence
1340         ['] eval goto-deferred
1341     then
1342
1343     application? if
1344
1345         2over 2over ( env exp env exp )
1346         operator ( env exp env opname )
1347
1348         2dup lookup-macro nil? false = if
1349              \ Macro function evaluation
1350
1351             ( env exp env opname mproc )
1352             2swap 2drop -2rot 2drop cdr ( env mproc body )
1353
1354             2dup print cr
1355             macro-expand
1356             2dup print cr
1357
1358             2swap
1359             ['] eval goto-deferred
1360         then
1361
1362        \ Regular function application
1363
1364         2drop ( env exp env opname )
1365
1366         2swap eval ( env exp proc )
1367
1368         2dup dummy-apply-proc obj@ objeq? if
1369             2drop ( env exp )
1370             cdr 2over 2over car ( env expbody env real-opname )
1371             2swap eval ( env expbody proc )
1372
1373             2swap cdr
1374             nil? false = if car then ( env proc real-operand )
1375
1376             2rot eval ( proc argvals )
1377
1378             pair-type istype? false = if
1379                 bold fg red ." Error: apply requires a list of operand arguments." cr
1380                 reset-term abort
1381             then
1382
1383             apply
1384             exit
1385         then
1386
1387         -2rot ( proc env exp )
1388         operands 2swap ( proc operands env )
1389         list-of-vals ( proc argvals )
1390
1391         apply
1392         exit
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