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 : apply ( proc argvals -- result )
1234         2swap dup case
1235             primitive-proc-type of
1236                 drop execute
1237             endof
1238
1239             compound-proc-type of
1240                 2dup procedure-body ( argvals proc body )
1241                 -2rot 2dup procedure-params ( body argvals proc argnames )
1242                 -2rot procedure-env ( body argnames argvals procenv )
1243
1244                 -2rot 2swap
1245                 flatten-proc-args
1246                 2swap 2rot
1247
1248                 extend-env ( body env )
1249
1250                 eval-sequence
1251
1252                 R> drop ['] eval goto-deferred  \ Tail call optimization
1253             endof
1254
1255             bold fg red ." Object not applicable. Aborting." reset-term cr
1256             abort
1257         endcase
1258 ;
1259
1260 : macro-expand ( proc expbody -- result )
1261     2swap
1262     2dup procedure-body ( expbody proc procbody )
1263     -2rot 2dup procedure-params ( procbody expbody proc argnames )
1264     -2rot procedure-env ( procbody argnames expbody procenv )
1265
1266     -2rot 2swap
1267     flatten-proc-args
1268     2swap 2rot
1269
1270     extend-env eval-sequence eval
1271 ;
1272
1273 :noname ( obj env -- result )
1274     2swap
1275
1276     self-evaluating? if
1277         2swap 2drop
1278         exit
1279     then
1280
1281     quote? if
1282         quote-body
1283         2swap 2drop
1284         exit
1285     then
1286
1287     variable? if
1288         2swap lookup-var
1289         exit
1290     then
1291
1292     definition? if
1293         2swap eval-definition
1294         exit
1295     then
1296
1297     assignment? if
1298         2swap eval-assignment
1299         exit
1300     then
1301
1302     macro-definition? if
1303         2swap eval-define-macro
1304         exit
1305     then
1306
1307     if? if
1308         2over 2over
1309         if-predicate
1310         2swap eval
1311
1312         true? if
1313             if-consequent
1314         else
1315             if-alternative
1316         then
1317
1318         2swap
1319         ['] eval goto-deferred
1320     then
1321
1322     lambda? if
1323         2dup lambda-parameters
1324         2swap lambda-body
1325         2rot make-procedure
1326         exit
1327     then
1328
1329     begin? if
1330         begin-actions 2swap
1331         eval-sequence
1332         ['] eval goto-deferred
1333     then
1334
1335     application? if
1336
1337         2over 2over ( env exp env exp )
1338         operator ( env exp env opname )
1339
1340         2dup lookup-macro nil? false = if
1341              \ Macro function evaluation
1342
1343             ( env exp env opname mproc )
1344             2swap 2drop -2rot 2drop cdr ( env mproc body )
1345
1346             2dup print cr
1347             macro-expand
1348             2dup print cr
1349
1350             2swap
1351             ['] eval goto-deferred
1352         else
1353            \ Regular function application
1354
1355             2drop ( env exp env opname )
1356
1357             2swap eval ( env exp proc )
1358
1359             -2rot ( proc env exp )
1360             operands 2swap ( proc operands env )
1361             list-of-vals ( proc argvals )
1362
1363             apply
1364             exit
1365         then
1366     then
1367
1368     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
1369     abort
1370 ; is eval
1371
1372 \ }}}
1373
1374 \ ---- Print ---- {{{
1375
1376 : printfixnum ( fixnumobj -- ) drop 0 .R ;
1377
1378 : printrealnum ( realnumobj -- ) drop float-print ;
1379
1380 : printbool ( numobj -- )
1381     drop if
1382         ." #t"
1383     else
1384         ." #f"
1385     then
1386 ;
1387
1388 : printchar ( charobj -- )
1389     drop
1390     case
1391         9 of ." #\tab" endof
1392         bl of ." #\space" endof
1393         '\n' of ." #\newline" endof
1394
1395         dup ." #\" emit
1396     endcase
1397 ;
1398
1399 : (printstring) ( stringobj -- )
1400     nil-type istype? if 2drop exit then
1401
1402     2dup car drop dup
1403     case
1404         '\n' of ." \n" drop endof
1405         [char] \ of ." \\" drop endof
1406         [char] " of [char] \ emit [char] " emit drop endof
1407         emit
1408     endcase
1409
1410     cdr recurse
1411 ;
1412 : printstring ( stringobj -- )
1413     [char] " emit
1414     (printstring)
1415     [char] " emit ;
1416
1417 : printsymbol ( symbolobj -- )
1418     nil-type istype? if 2drop exit then
1419
1420     2dup car drop emit
1421     cdr recurse
1422 ;
1423
1424 : printnil ( nilobj -- )
1425     2drop ." ()" ;
1426
1427 : printpair ( pairobj -- )
1428     2dup
1429     car print
1430     cdr
1431     nil-type istype? if 2drop exit then
1432     pair-type istype? if space recurse exit then
1433     ."  . " print
1434 ;
1435
1436 : printprim ( primobj -- )
1437     2drop ." <primitive procedure>" ;
1438
1439 : printcomp ( primobj -- )
1440     2drop ." <compound procedure>" ;
1441
1442 : printnone ( noneobj -- )
1443     2drop ." Unspecified return value" ;
1444
1445 :noname ( obj -- )
1446     fixnum-type istype? if printfixnum exit then
1447     realnum-type istype? if printrealnum exit then
1448     boolean-type istype? if printbool exit then
1449     character-type istype? if printchar exit then
1450     string-type istype? if printstring exit then
1451     symbol-type istype? if printsymbol exit then
1452     nil-type istype? if printnil exit then
1453     pair-type istype? if ." (" printpair ." )" exit then
1454     primitive-proc-type istype? if printprim exit then
1455     compound-proc-type istype? if printcomp exit then
1456     none-type istype? if printnone exit then
1457
1458     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
1459     abort
1460 ; is print
1461
1462 \ }}}
1463
1464 \ ---- Garbage Collection ---- {{{
1465
1466 variable gc-enabled
1467 false gc-enabled !
1468
1469 variable gc-stack-depth
1470
1471 : enable-gc
1472     depth gc-stack-depth !
1473     true gc-enabled ! ;
1474
1475 : disable-gc
1476     false gc-enabled ! ;
1477
1478 : gc-enabled?
1479     gc-enabled @ ;
1480
1481 : pairlike? ( obj -- obj bool )
1482     pair-type istype? if true exit then
1483     string-type istype? if true exit then
1484     symbol-type istype? if true exit then
1485     compound-proc-type istype? if true exit then
1486
1487     false
1488 ;
1489
1490 : pairlike-marked? ( obj -- obj bool )
1491     over nextfrees + @ 0=
1492 ;
1493
1494 : mark-pairlike ( obj -- obj )
1495         over nextfrees + 0 swap !
1496 ;
1497
1498 : gc-unmark ( -- )
1499     scheme-memsize 0 do
1500         1 nextfrees i + !
1501     loop
1502 ;
1503
1504 : gc-mark-obj ( obj -- )
1505
1506     pairlike? invert if 2drop exit then
1507     pairlike-marked? if 2drop exit then
1508
1509     mark-pairlike
1510
1511     drop pair-type 2dup
1512
1513     car recurse
1514     cdr recurse
1515 ;
1516
1517 : gc-sweep
1518     scheme-memsize nextfree !
1519     0 scheme-memsize 1- do
1520         nextfrees i + @ 0<> if
1521             nextfree @ nextfrees i + !
1522             i nextfree !
1523         then
1524     -1 +loop
1525 ;
1526
1527 \ Following a GC, this gives the amount of free memory
1528 : gc-count-marked
1529     0
1530     scheme-memsize 0 do
1531         nextfrees i + @ 0= if 1+ then
1532     loop
1533 ;
1534
1535 \ Debugging word - helps spot memory that is retained
1536 : gc-zero-unmarked
1537     scheme-memsize 0 do
1538         nextfrees i + @ 0<> if
1539             0 car-cells i + !
1540             0 cdr-cells i + !
1541         then
1542     loop
1543 ;
1544
1545 :noname
1546     \ ." GC! "
1547
1548     gc-unmark
1549
1550     symbol-table obj@ gc-mark-obj
1551     macro-table obj@ gc-mark-obj
1552     global-env obj@ gc-mark-obj
1553
1554     depth gc-stack-depth @ do
1555         PSP0 i + 1 + @
1556         PSP0 i + 2 + @
1557
1558         gc-mark-obj
1559     2 +loop
1560
1561     gc-sweep
1562
1563     \ ." (" gc-count-marked . ." pairs marked as used.)" cr
1564 ; is collect-garbage
1565
1566 \ }}}
1567
1568 \ ---- Loading files ---- {{{
1569
1570 : charlist>cstr ( charlist addr -- n )
1571
1572     dup 2swap ( origaddr addr charlist )
1573
1574     begin
1575         nil? false =
1576     while
1577         2dup cdr 2swap car
1578         drop ( origaddr addr charlist char )
1579         -rot 2swap ( origaddr charlist addr char )
1580         over !
1581         1+ -rot ( origaddr nextaddr charlist )
1582     repeat
1583
1584     2drop ( origaddr finaladdr )
1585     swap -
1586 ;
1587
1588 : load ( addr n -- finalResult )
1589     open-input-file
1590
1591     empty-parse-str
1592
1593     ok-symbol ( port res )
1594
1595     begin
1596         2over read-port ( port res obj )
1597
1598         2dup EOF character-type objeq? if
1599             2drop 2swap close-port
1600             exit
1601         then
1602
1603         2swap 2drop ( port obj )
1604
1605         global-env obj@ eval ( port res )
1606     again
1607 ;
1608
1609 \ }}}
1610
1611 \ ---- Standard Library ---- {{{
1612
1613     include scheme-primitives.4th
1614
1615     s" scheme-library.scm" load 2drop
1616
1617 \ }}}
1618
1619 \ ---- REPL ----
1620
1621 : repl
1622     cr ." Welcome to scheme.forth.jl!" cr
1623        ." Use Ctrl-D to exit." cr
1624
1625     empty-parse-str
1626
1627     enable-gc
1628
1629     begin
1630         cr bold fg green ." > " reset-term
1631         read-console
1632
1633         2dup EOF character-type objeq? if
1634             2drop
1635             bold fg blue ." Moriturus te saluto." reset-term cr
1636             exit
1637         then
1638
1639         global-env obj@ eval
1640
1641         fg cyan ." ; " print reset-term
1642     again
1643 ;
1644
1645 forth definitions
1646
1647 \ vim:fdm=marker