src/scheme.4th

   1 vocabulary scheme
   2 scheme definitions
   3
   4 include term-colours.4th
   5 include defer-is.4th
   6 include goto.4th
   7 include catch-throw.4th
   8 include integer.4th
   9 include float.4th
  10
  11 include debugging.4th
  12
  13 defer read
  14 defer expand
  15 defer analyze
  16 defer eval
  17 defer print
  18
  19 defer collect-garbage
  20
  21 \ ---- Types ---- {{{
  22
  23 variable nexttype
  24 0 nexttype !
  25 : make-type
  26     create nexttype @ ,
  27     1 nexttype +!
  28     does> @ ;
  29
  30 make-type fixnum-type
  31 make-type flonum-type
  32 make-type ratnum-type
  33 make-type boolean-type
  34 make-type character-type
  35 make-type string-type
  36 make-type nil-type
  37 make-type none-type
  38 make-type pair-type
  39 make-type symbol-type
  40 make-type primitive-proc-type
  41 make-type compound-proc-type
  42 make-type continuation-type
  43 make-type port-type
  44 : istype? ( obj type -- obj bool )
  45     over = ;
  46
  47 \ }}}
  48
  49 \ ---- Exceptions ---- {{{
  50
  51 variable nextexception
  52 1 nextexception !
  53 : make-exception
  54     create nextexception @ ,
  55     1 nextexception +!
  56     does> @ ;
  57
  58 : except-message:
  59     bold fg red
  60     ." Exception: "
  61 ;
  62
  63 make-exception recoverable-exception
  64 make-exception unrecoverable-exception
  65
  66 : throw reset-term cr throw ;
  67
  68 \ }}}
  69
  70 \ ---- List-structured memory ---- {{{
  71
  72 20000 constant scheme-memsize
  73
  74 create car-cells scheme-memsize allot
  75 create car-type-cells scheme-memsize allot
  76 create cdr-cells scheme-memsize allot
  77 create cdr-type-cells scheme-memsize allot
  78
  79 create nextfrees scheme-memsize allot
  80 :noname
  81     scheme-memsize 0 do
  82         i 1+ nextfrees i + !
  83     loop
  84 ; execute
  85
  86 variable nextfree
  87 0 nextfree !
  88
  89 : inc-nextfree
  90     nextfrees nextfree @ + @
  91     nextfree !
  92
  93     nextfree @ scheme-memsize >= if
  94       collect-garbage
  95     then
  96
  97     nextfree @ scheme-memsize >= if
  98         except-message: ." Out of memory!" unrecoverable-exception throw
  99     then
 100 ;
 101
 102 : cons ( car-obj cdr-obj -- pair-obj )
 103     cdr-type-cells nextfree @ + !
 104     cdr-cells nextfree @ + !
 105     car-type-cells nextfree @ + !
 106     car-cells nextfree @ + !
 107
 108     nextfree @ pair-type
 109     inc-nextfree
 110 ;
 111
 112 : car ( pair-obj -- car-obj )
 113     drop
 114     dup car-cells + @ swap
 115     car-type-cells + @
 116 ;
 117
 118 : cdr ( pair-obj -- car-obj )
 119     drop
 120     dup cdr-cells + @ swap
 121     cdr-type-cells + @
 122 ;
 123
 124 : set-car! ( obj pair-obj -- )
 125     drop dup
 126     rot swap  car-type-cells + !
 127     car-cells + !
 128 ;
 129
 130 : set-cdr! ( obj pair-obj -- )
 131     drop dup
 132     rot swap  cdr-type-cells + !
 133     cdr-cells + !
 134 ;
 135
 136 variable object-stack-base
 137 : init-object-stack-base
 138   depth object-stack-base ! ;
 139
 140 : nil 0 nil-type ;
 141 : nil? nil-type istype? ;
 142
 143 : none 0 none-type ;
 144 : none? none-type istype? ;
 145
 146 : objvar create nil swap , , ;
 147
 148 : value@ ( objvar -- val ) @ ;
 149 : type@ ( objvar -- type ) 1+ @ ;
 150 : value! ( newval objvar -- ) ! ;
 151 : type! ( newtype objvar -- ) 1+ ! ;
 152 : obj! ( newobj objvar -- ) dup rot swap 1+ ! ! ;
 153 : obj@ ( objvar -- obj ) dup @ swap 1+ @ ;
 154
 155 : objeq? ( obj obj -- bool )
 156     rot = -rot = and ;
 157
 158 : 2rot ( a1 a2 b1 b2 c1 c2 -- b1 b2 c1 c2 a1 a2 )
 159     >R >R ( a1 a2 b1 b2 )
 160     2swap ( b1 b2 a1 a2 )
 161     R> R> ( b1 b2 a1 a2 c1 c2 )
 162     2swap
 163 ;
 164
 165 : -2rot ( a1 a2 b1 b2 c1 c2 -- c1 c2 a1 a2 b1 b2 )
 166     2swap ( a1 a2 c1 c2 b1 b2 )
 167     >R >R ( a1 a2 c1 c2 )
 168     2swap ( c1 c2 a1 a2 )
 169     R> R>
 170 ;
 171
 172 : 2pick ( an bn an-1 bn-1 ... a0 b0 n -- an bn an-1 bn-1 ... a0 b0 an bn )
 173     2* 1+ dup
 174     >R pick R> pick ;
 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 quasiquote        quasiquote-symbol
 267 create-symbol unquote           unquote-symbol
 268 create-symbol unquote-splicing  unquote-splicing-symbol
 269 create-symbol define            define-symbol
 270 create-symbol define-macro      define-macro-symbol
 271 create-symbol set!              set!-symbol
 272 create-symbol ok                ok-symbol
 273 create-symbol if                if-symbol
 274 create-symbol lambda            lambda-symbol
 275 create-symbol λ                 λ-symbol
 276 create-symbol eof               eof-symbol
 277 create-symbol no-match          no-match-symbol
 278
 279 \ Symbol to be bound to welcome message procedure by library
 280 create-symbol welcome           welcome-symbol
 281
 282 \ }}}
 283
 284 \ ---- Port I/O ----  {{{
 285
 286 ( Ports are pairs with the fid in the car and the peek buffer in the cdr. )
 287
 288 : fileport>fid ( fileport -- fid )
 289     drop pair-type car drop ;
 290
 291 : get-last-peek ( fileport -- char/nil )
 292     drop pair-type cdr ;
 293
 294 : set-last-peek ( char/nil fileport -- )
 295     drop pair-type set-cdr!
 296 ;
 297
 298 : fid>fileport ( fid -- fileport )
 299     fixnum-type nil cons drop port-type ;
 300
 301 : open-input-file ( addr n -- fileport )
 302     r/o open-file drop fid>fileport
 303 ;
 304
 305 : close-port ( fileport -- )
 306     fileport>fid close-file drop
 307 ;
 308
 309 objvar console-i/o-port
 310 0 fixnum-type nil cons drop port-type console-i/o-port obj!
 311
 312 objvar current-input-port
 313 console-i/o-port obj@ current-input-port obj!
 314
 315 : read-char ( port -- char )
 316     2dup get-last-peek nil? if
 317         2drop
 318         2dup console-i/o-port obj@ objeq? if
 319             2drop
 320             key character-type
 321         else
 322             fileport>fid pad 1 rot read-file 0= if
 323                 eof-symbol
 324             else
 325                 pad @ character-type
 326             then
 327         then
 328     else
 329         nil 2rot set-cdr!
 330     then
 331 ;
 332
 333 : peek-char ( port -- char )
 334     2dup get-last-peek nil? if
 335         2drop 2dup read-char
 336         2dup 2rot set-last-peek
 337     else
 338         2swap 2drop
 339     then
 340 ;
 341
 342 variable read-line-buffer-span
 343 variable read-line-buffer-offset
 344
 345 ( Hack to save original read-line while we transition to new one. )
 346 : orig-read-line immediate
 347     ['] read-line , ;
 348
 349 : read-line ( port -- string )
 350
 351     2dup get-last-peek
 352     nil? if
 353         2drop
 354         0 read-line-buffer-offset !
 355     else
 356         2over nil 2swap set-last-peek
 357         2dup drop '\n' = if
 358             2drop nil nil cons exit
 359         else
 360             drop pad !
 361             1 read-line-buffer-offset !
 362         then
 363     then
 364
 365     2dup console-i/o-port obj@ objeq? if
 366         2drop
 367         pad read-line-buffer-offset @ + 200 expect cr
 368         span @ read-line-buffer-offset @ + read-line-buffer-span !
 369     else
 370         pad read-line-buffer-offset @ + 200 2over fileport>fid orig-read-line
 371         drop swap read-line-buffer-offset @ + read-line-buffer-span !
 372     then
 373
 374     nil
 375
 376     begin
 377         read-line-buffer-span @ 0>
 378     while
 379         pad read-line-buffer-span @ 1- + @ character-type 2swap cons
 380         -1 read-line-buffer-span +!
 381     repeat
 382
 383     nil? if
 384         nil cons drop string-type
 385     else
 386         drop string-type
 387     then
 388 ;
 389
 390 : read-port ( fileport -- obj )
 391     current-input-port obj!
 392     read ;
 393
 394 : read-console ( -- obj )
 395     console-i/o-port obj@ read-port ;
 396
 397 \ }}}
 398
 399 \ ---- Environments ---- {{{
 400
 401 : enclosing-env ( env -- env )
 402     cdr ;
 403
 404 : first-frame ( env -- frame )
 405     car ;
 406
 407 : make-frame ( vars vals -- frame )
 408     cons ;
 409
 410 : add-frame-to-env ( frame env -- env )
 411     cons ;
 412
 413 : frame-vars ( frame -- vars )
 414     car ;
 415
 416 : frame-vals ( frame -- vals )
 417     cdr ;
 418
 419 : add-binding ( var val frame -- )
 420     2swap 2over frame-vals cons
 421     2over set-cdr!
 422     2swap 2over frame-vars cons
 423     2swap set-car!
 424 ;
 425
 426 : extend-env ( vars vals env -- env )
 427     -2rot make-frame
 428     2swap add-frame-to-env
 429 ;
 430
 431 : get-vals-frame ( var frame -- vals | nil )
 432     2dup frame-vars
 433     2swap frame-vals ( var vars vals )
 434
 435     begin
 436         nil? false =
 437     while
 438
 439         -2rot ( vals var vars )
 440         2over 2over car objeq? if
 441             2drop 2drop
 442             exit
 443         then
 444
 445         cdr 2rot cdr
 446     repeat
 447
 448     2drop 2drop 2drop
 449     nil
 450 ;
 451
 452 : get-vals ( var env -- vals | nil )
 453
 454     begin
 455         nil? false =
 456     while
 457         2over 2over first-frame
 458         get-vals-frame nil? false = if
 459             2swap 2drop 2swap 2drop
 460             exit
 461         then
 462
 463         2drop
 464
 465         enclosing-env
 466     repeat
 467
 468     2swap 2drop
 469 ;
 470
 471 objvar var \ Used only for error messages
 472 : lookup-var ( var env -- val )
 473     2over var obj!
 474
 475     get-vals nil? if
 476         except-message: ." tried to read unbound variable '" var obj@ print ." '."
 477         recoverable-exception throw
 478     then
 479
 480     car
 481 ;
 482
 483 : set-var ( var val env -- )
 484     2rot 2dup var obj! ( val env var )
 485     2swap ( val var env )
 486     get-vals nil? if
 487         except-message: ." tried to set unbound variable '" var obj@ print ." '."
 488         recoverable-exception throw
 489     else
 490         ( val vals )
 491         set-car!
 492     then
 493 ;
 494 hide var
 495
 496 : define-var ( var val env -- )
 497     first-frame ( var val frame )
 498     2rot 2swap 2over 2over ( val var frame var frame )
 499
 500     get-vals-frame nil? if
 501         2drop
 502         -2rot 2swap 2rot
 503         add-binding
 504     else
 505         ( val var frame vals )
 506         2swap 2drop 2swap 2drop
 507         set-car!
 508     then
 509 ;
 510
 511 : make-procedure ( params body env -- proc )
 512     nil
 513     cons cons cons
 514     drop compound-proc-type
 515 ;
 516
 517 objvar global-env
 518 nil nil nil extend-env
 519 global-env obj!
 520
 521 \ }}}
 522
 523 \ ---- Continuations ---- {{{
 524
 525 : cons-return-stack ( -- listobj )
 526   rsp@ 1- rsp0  = if
 527     nil exit
 528   then
 529
 530   nil rsp@ 1- rsp0 do
 531     i 1+ @ fixnum-type 2swap cons
 532   loop
 533
 534   rsp@ 1- rsp0 - fixnum-type 2swap cons
 535 ;
 536
 537 : cons-param-stack ( -- listobj )
 538   nil
 539
 540   depth 2- object-stack-base @ = if
 541     exit
 542   then
 543
 544   depth 2- object-stack-base @ do
 545         PSP0 i + 1 + @
 546         PSP0 i + 2 + @
 547
 548         2swap cons
 549     2 +loop
 550
 551   depth 2- fixnum-type 2swap cons
 552 ;
 553
 554 : make-continuation
 555
 556   cons-param-stack
 557   cons-return-stack
 558   cons drop continuation-type
 559 ;
 560
 561 : continuation->pstack-list
 562   drop pair-type car ;
 563
 564 : continuation->rstack-list
 565   drop pair-type cdr ;
 566
 567 : restore-param-stack ( continuation -- obj_stack continuation )
 568
 569   continuation->pstack-list
 570   2dup >R >R
 571
 572   ( Allocate stack space first using psp!,
 573     then copy objects from list. )
 574
 575   car drop
 576   object-stack-base @ psp0 + + psp!
 577
 578   R> R> 2dup cdr
 579   2swap
 580   car drop 2- 0 swap do
 581
 582       2dup car
 583       PSP0 object-stack-base @ + i + 2 + !
 584       PSP0 object-stack-base @ + i + 1 + !
 585       cdr
 586
 587   -2 +loop
 588
 589   2drop
 590
 591 ;
 592
 593 : restore-continuation
 594   \ TODO: replace current parameter and return stacks with
 595   \ contents of continuation object.
 596 ;
 597
 598 \ }}}
 599
 600 \ ---- Primitives ---- {{{
 601
 602 : make-primitive ( cfa -- )
 603     bl word
 604     count
 605
 606     cstr>charlist
 607     charlist>symbol
 608
 609     rot primitive-proc-type ( var prim )
 610     global-env obj@ define-var
 611 ;
 612
 613 : ensure-arg-count ( args n -- )
 614     dup 0= if
 615         drop nil objeq? false = if
 616             except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
 617         then
 618     else
 619         -rot nil? if
 620             except-message: ." Too few arguments for primitive procedure." recoverable-exception  throw
 621         then
 622
 623         cdr rot 1- recurse
 624     then
 625 ;
 626
 627 : ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- )
 628     dup 0= if
 629         drop nil objeq? false = if
 630             except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
 631         then
 632     else
 633         -rot nil? if
 634             except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
 635         then
 636
 637         2dup cdr 2swap car ( ... t1 n args' arg1 )
 638         2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 )
 639         istype? false = if
 640             except-message: ." Incorrect type for primitive procedure." recoverable-exception throw
 641         then
 642
 643         2drop recurse
 644     then
 645
 646 ;
 647
 648 : push-args-to-stack ( args -- arg1 arg2 ... argn )
 649     begin
 650         nil? false =
 651     while
 652         2dup car 2swap cdr
 653     repeat
 654
 655     2drop
 656 ;
 657
 658 : add-fa-checks ( cfa n -- cfa' )
 659     here current @ 1+ dup @ , !
 660     0 ,
 661     here -rot
 662     docol ,
 663     ['] 2dup , ['] lit , , ['] ensure-arg-count ,
 664     ['] push-args-to-stack ,
 665     ['] lit , , ['] execute ,
 666     ['] exit ,
 667 ;
 668
 669 : add-fa-type-checks ( cfa t1 t2 ... tn n -- cfa' )
 670     here current @ 1+ dup @ , !
 671     0 ,
 672     here >R
 673     docol ,
 674     ['] 2dup ,
 675     ['] >R , ['] >R ,
 676
 677     dup ( cfa t1 t2 ... tn n m )
 678
 679     begin
 680         ?dup 0>
 681     while
 682         rot ['] lit , , ( cfa t1 t2 ... tn-1 n m )
 683         1-
 684     repeat
 685
 686     ['] R> , ['] R> ,
 687
 688     ['] lit , , ['] ensure-arg-type-and-count ,
 689
 690     ['] push-args-to-stack ,
 691     ['] lit , , ['] execute ,
 692     ['] exit ,
 693
 694     R>
 695 ;
 696
 697 : make-fa-primitive ( cfa n -- )
 698     add-fa-checks make-primitive ;
 699
 700 : make-fa-type-primitive ( cfa t1 t2 ... tn n -- )
 701     add-fa-type-checks make-primitive ;
 702
 703 : arg-type-error
 704             bold fg red ." Incorrect argument type." reset-term cr
 705             abort
 706 ;
 707
 708 : ensure-arg-type ( arg type -- arg )
 709     istype? false = if
 710         except-message: ." Incorrect argument type for primitive procedure." recoverable-exception throw
 711     then
 712 ;
 713
 714
 715 \ }}}
 716
 717 \ ---- Macros ---- {{{
 718
 719 objvar macro-table
 720
 721 ( Look up macro in macro table. Returns nil if
 722   no macro is found. )
 723 : lookup-macro ( name_symbol -- proc )
 724
 725     symbol-type istype? invert if
 726         \ Early exit if argument is not a symbol
 727         2drop nil exit
 728     then
 729
 730     macro-table obj@
 731
 732     begin
 733         nil? false =
 734     while
 735         2over 2over
 736         car car objeq? if
 737             2swap 2drop
 738             car cdr
 739             exit
 740         then
 741
 742         cdr
 743     repeat
 744
 745     2swap 2drop
 746 ;
 747
 748 : make-macro ( name_symbol params body env -- )
 749     make-procedure
 750
 751     2swap ( proc name_symbol )
 752
 753     macro-table obj@
 754
 755     begin
 756         nil? false =
 757     while
 758         2over 2over ( proc name table name table )
 759         car car objeq? if
 760             2swap 2drop ( proc table )
 761             car ( proc entry )
 762             set-cdr!
 763             exit
 764         then
 765
 766         cdr
 767     repeat
 768
 769     2drop
 770
 771     2swap cons
 772     macro-table obj@ cons
 773     macro-table obj!
 774 ;
 775
 776 \ }}}
 777
 778 \ ---- Read ---- {{{
 779
 780 variable parse-idx
 781 variable stored-parse-idx
 782 create parse-str 161 allot
 783 variable parse-str-span
 784
 785 create parse-idx-stack 10 allot
 786 variable parse-idx-sp
 787 parse-idx-stack parse-idx-sp !
 788
 789 : push-parse-idx
 790     parse-idx @ parse-idx-sp @ !
 791     1 parse-idx-sp +!
 792 ;
 793
 794 : pop-parse-idx
 795     parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
 796
 797     1 parse-idx-sp -!
 798
 799     parse-idx-sp @ @ parse-idx ! ;
 800
 801
 802 : append-newline
 803     '\n' parse-str parse-str-span @ + !
 804     1 parse-str-span +! ;
 805
 806 : append-eof
 807     4 parse-str parse-str-span @ + !
 808     1 parse-str-span +!  ;
 809
 810 : empty-parse-str
 811     0 parse-str-span !
 812     0 parse-idx ! ;
 813
 814 : getline
 815     current-input-port obj@ console-i/o-port obj@ objeq? if
 816         parse-str 160 expect cr
 817         span @ parse-str-span !
 818     else
 819         parse-str 160 current-input-port obj@ fileport>fid orig-read-line
 820         drop swap parse-str-span !
 821
 822         parse-str-span @ 0= and if append-eof then
 823     then
 824     append-newline
 825     0 parse-idx ! ;
 826
 827 : inc-parse-idx
 828     1 parse-idx +! ;
 829
 830 : dec-parse-idx
 831     1 parse-idx -! ;
 832
 833 : charavailable? ( -- bool )
 834     parse-str-span @ parse-idx @ > ;
 835
 836 : nextchar ( -- char )
 837     charavailable? false = if getline then
 838     parse-str parse-idx @ + @ ;
 839
 840 : '\t' 9 ;
 841 : whitespace? ( -- bool )
 842     nextchar BL =
 843     nextchar '\n' =
 844     nextchar '\t' =
 845     or or ;
 846
 847 : EOF 4 ;
 848 : eof? ( -- bool )
 849     nextchar EOF = ;
 850
 851 : delim? ( -- bool )
 852     whitespace?
 853     nextchar [char] ( = or
 854     nextchar [char] ) = or
 855 ;
 856
 857 : commentstart? ( -- bool )
 858     nextchar [char] ; = ;
 859
 860 : eatspaces
 861
 862     false \ Indicates whether or not we're eating a comment
 863
 864     begin
 865         dup whitespace? or commentstart? or
 866     while
 867         dup nextchar '\n' = and if
 868             invert \ Stop eating comment
 869         else
 870             dup false = commentstart? and if
 871                 invert \ Begin eating comment
 872             then
 873         then
 874
 875         inc-parse-idx
 876     repeat
 877     drop
 878 ;
 879
 880 : digit? ( -- bool )
 881     nextchar [char] 0 >=
 882     nextchar [char] 9 <=
 883     and ;
 884
 885 : minus? ( -- bool )
 886     nextchar [char] - = ;
 887
 888 : plus? ( -- bool )
 889     nextchar [char] + = ;
 890
 891 : fixnum? ( -- bool )
 892     minus? plus? or if
 893         inc-parse-idx
 894
 895         delim? if
 896             dec-parse-idx
 897             false exit
 898         else
 899             dec-parse-idx
 900         then
 901     else
 902         digit? false = if
 903             false exit
 904         then
 905     then
 906
 907     push-parse-idx
 908     inc-parse-idx
 909
 910     begin digit? while
 911         inc-parse-idx
 912     repeat
 913
 914     delim? pop-parse-idx
 915 ;
 916
 917 : flonum? ( -- bool )
 918     push-parse-idx
 919
 920     minus? plus? or if
 921         inc-parse-idx
 922     then
 923
 924     \ Record starting parse idx:
 925     \ Want to detect whether any characters (following +/-) were eaten.
 926     parse-idx @
 927
 928     begin digit? while
 929             inc-parse-idx
 930     repeat
 931
 932     [char] . nextchar = if
 933         inc-parse-idx
 934         begin digit? while
 935                 inc-parse-idx
 936         repeat
 937     then
 938
 939     [char] e nextchar = [char] E nextchar = or if
 940         inc-parse-idx
 941
 942         minus? plus? or if
 943             inc-parse-idx
 944         then
 945
 946         digit? invert if
 947             drop pop-parse-idx false exit
 948         then
 949
 950         begin digit? while
 951                 inc-parse-idx
 952         repeat
 953     then
 954
 955     \ This is a real number if characters were
 956     \ eaten and the next characer is a delimiter.
 957     parse-idx @ < delim? and
 958
 959     pop-parse-idx
 960 ;
 961
 962 : ratnum? ( -- bool )
 963     push-parse-idx
 964
 965     minus? plus? or if
 966         inc-parse-idx
 967     then
 968
 969     digit? invert if
 970         pop-parse-idx false exit
 971     else
 972         inc-parse-idx
 973     then
 974
 975     begin digit? while
 976         inc-parse-idx
 977     repeat
 978
 979     [char] / nextchar <> if
 980         pop-parse-idx false exit
 981     else
 982         inc-parse-idx
 983     then
 984
 985     digit? invert if
 986         pop-parse-idx false exit
 987     else
 988         inc-parse-idx
 989     then
 990
 991     begin digit? while
 992         inc-parse-idx
 993     repeat
 994
 995     delim? pop-parse-idx
 996 ;
 997
 998 : boolean? ( -- bool )
 999     nextchar [char] # <> if false exit then
1000
1001     push-parse-idx
1002     inc-parse-idx
1003
1004     nextchar [char] t <>
1005     nextchar [char] f <>
1006     and if pop-parse-idx false exit then
1007
1008     inc-parse-idx
1009     delim? if
1010         pop-parse-idx
1011         true
1012     else
1013         pop-parse-idx
1014         false
1015     then
1016 ;
1017
1018 : str-equiv? ( str -- bool )
1019
1020     push-parse-idx
1021
1022     true -rot
1023
1024     swap dup rot + swap
1025
1026     do
1027         i @ nextchar <> if
1028             drop false
1029             leave
1030         then
1031
1032         inc-parse-idx
1033     loop
1034
1035     delim? false = if drop false then
1036
1037     pop-parse-idx
1038 ;
1039
1040 : character? ( -- bool )
1041     nextchar [char] # <> if false exit then
1042
1043     push-parse-idx
1044     inc-parse-idx
1045
1046     nextchar [char] \ <> if pop-parse-idx false exit then
1047
1048     inc-parse-idx
1049
1050     S" newline" str-equiv? if pop-parse-idx true exit then
1051     S" space" str-equiv? if pop-parse-idx true exit then
1052     S" tab" str-equiv? if pop-parse-idx true exit then
1053
1054     charavailable? false = if pop-parse-idx false exit then
1055
1056     pop-parse-idx true
1057 ;
1058
1059 : pair? ( -- bool )
1060     nextchar [char] ( = ;
1061
1062 : string? ( -- bool )
1063     nextchar [char] " = ;
1064
1065 : readfixnum ( -- fixnum )
1066     plus? minus? or if
1067         minus?
1068         inc-parse-idx
1069     else
1070         false
1071     then
1072
1073     0
1074
1075     begin digit? while
1076         10 * nextchar [char] 0 - +
1077         inc-parse-idx
1078     repeat
1079
1080     swap if negate then
1081
1082     fixnum-type
1083 ;
1084
1085 : readflonum ( -- flonum )
1086     readfixnum drop
1087     dup 0< swap abs i->f
1088
1089     [char] . nextchar = if
1090         inc-parse-idx
1091
1092         10.0 ( f exp )
1093
1094         begin digit? while
1095             nextchar [char] 0 - i->f ( f exp d )
1096             over f/ rot f+ ( exp f' )
1097             swap 10.0 f* ( f' exp' )
1098             inc-parse-idx
1099         repeat
1100
1101         drop
1102     then
1103
1104     [char] e nextchar = [char] E nextchar = or if
1105         inc-parse-idx
1106         10.0
1107         readfixnum drop i->f
1108         f^ f*
1109     then
1110
1111     swap if
1112         -1.0 f*
1113     then
1114
1115     flonum-type
1116 ;
1117
1118 : make-rational ( fixnum fixnum -- ratnum|fixnum )
1119     drop swap drop
1120     simplify
1121
1122     dup 1 = if
1123         drop fixnum-type
1124     else
1125         fixnum-type swap fixnum-type
1126         cons drop ratnum-type
1127     then
1128 ;
1129
1130 : readratnum ( -- ratnum )
1131     readfixnum inc-parse-idx readfixnum
1132     make-rational
1133 ;
1134
1135 : readbool ( -- bool-obj )
1136     inc-parse-idx
1137
1138     nextchar [char] f = if
1139         false
1140     else
1141         true
1142     then
1143
1144     inc-parse-idx
1145
1146     boolean-type
1147 ;
1148
1149 : readchar ( -- char-obj )
1150     inc-parse-idx
1151     inc-parse-idx
1152
1153     S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
1154     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
1155     S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
1156
1157     nextchar character-type
1158
1159     inc-parse-idx
1160 ;
1161
1162 : readstring ( -- charlist )
1163
1164     nil nil
1165
1166     begin
1167         nextchar [char] " <>
1168     while
1169         nextchar [char] \ = if
1170             inc-parse-idx
1171             nextchar case
1172                 [char] n of '\n' endof
1173                 [char] " of [char] " endof
1174                 [char] \
1175             endcase
1176         else
1177             nextchar
1178         then
1179         inc-parse-idx character-type
1180         nil cons
1181
1182         ( firstchar prevchar thischar )
1183
1184         2swap nil? if
1185             2drop 2swap 2drop 2dup  ( thischar thischar )
1186         else
1187             ( firstchar thischar prevchar )
1188             2over 2swap  set-cdr! ( firstchar thischar )
1189         then
1190     repeat
1191
1192     \ Discard previous character
1193     2drop
1194
1195     inc-parse-idx
1196     delim? false = if
1197         bold fg red
1198         ." No delimiter following right double quote. Aborting." cr
1199         reset-term abort
1200     then
1201
1202     dec-parse-idx
1203
1204     nil? if
1205         nil cons
1206     then
1207     drop string-type
1208 ;
1209
1210 : readsymbol ( -- charlist )
1211     delim? if nil exit then
1212
1213     nextchar inc-parse-idx character-type
1214
1215     recurse
1216
1217     cons
1218 ;
1219
1220 : readpair ( -- pairobj )
1221     eatspaces
1222
1223     \ Empty lists
1224     nextchar [char] ) = if
1225         inc-parse-idx
1226
1227         delim? false = if
1228             bold fg red
1229             ." No delimiter following right paren. Aborting." cr
1230             reset-term abort
1231         then
1232
1233         dec-parse-idx
1234
1235         0 nil-type exit
1236     then
1237
1238     \ Read first pair element
1239     read
1240
1241     \ Pairs
1242     eatspaces
1243     nextchar [char] . = if
1244         inc-parse-idx
1245
1246         delim? false = if
1247             bold fg red
1248             ." No delimiter following '.'. Aborting." cr
1249             reset-term abort
1250         then
1251
1252         eatspaces read
1253     else
1254         recurse
1255     then
1256
1257     eatspaces
1258
1259     cons
1260 ;
1261
1262 \ Parse a scheme expression
1263 :noname ( -- obj )
1264
1265     eatspaces
1266
1267     fixnum? if
1268         readfixnum
1269         exit
1270     then
1271
1272     flonum? if
1273         readflonum
1274         exit
1275     then
1276
1277     ratnum? if
1278         readratnum
1279         exit
1280     then
1281
1282     boolean? if
1283         readbool
1284         exit
1285     then
1286
1287     character? if
1288         readchar
1289         exit
1290     then
1291
1292     string? if
1293         inc-parse-idx
1294
1295         readstring
1296
1297         nextchar [char] " <> if
1298             bold red ." Missing closing double-quote." reset-term cr
1299             abort
1300         then
1301
1302         inc-parse-idx
1303
1304         exit
1305     then
1306
1307     pair? if
1308         inc-parse-idx
1309
1310         eatspaces
1311
1312         readpair
1313
1314         eatspaces
1315
1316         nextchar [char] ) <> if
1317             bold red ." Missing closing paren." reset-term cr
1318             abort
1319         then
1320
1321         inc-parse-idx
1322
1323         exit
1324     then
1325
1326     nextchar [char] ' = if
1327         inc-parse-idx
1328         quote-symbol recurse nil cons cons exit
1329     then
1330
1331     nextchar [char] ` = if
1332         inc-parse-idx
1333         quasiquote-symbol recurse nil cons cons exit
1334     then
1335
1336     nextchar [char] , = if
1337         inc-parse-idx
1338         nextchar [char] @ = if
1339             inc-parse-idx
1340             unquote-splicing-symbol recurse nil cons cons exit
1341         else
1342             unquote-symbol recurse nil cons cons exit
1343         then
1344     then
1345
1346     eof? if
1347         EOF character-type
1348         inc-parse-idx
1349         exit
1350     then
1351
1352     nextchar [char] ) = if
1353         inc-parse-idx
1354         except-message: ." unmatched closing parenthesis." recoverable-exception throw
1355     then
1356
1357     \ Anything else is parsed as a symbol
1358     readsymbol charlist>symbol
1359
1360     \ Replace λ with lambda
1361     2dup λ-symbol objeq? if
1362         2drop lambda-symbol
1363     then
1364
1365
1366 ; is read
1367
1368 \ }}}
1369
1370 \ ---- Syntax ---- {{{
1371
1372 : self-evaluating? ( obj -- obj bool )
1373     boolean-type istype? if true exit then
1374     fixnum-type istype? if true exit then
1375     flonum-type istype? if true exit then
1376     ratnum-type istype? if true exit then
1377     character-type istype? if true exit then
1378     string-type istype? if true exit then
1379     nil-type istype? if true exit then
1380     none-type istype? if true exit then
1381
1382     false
1383 ;
1384
1385 : tagged-list? ( obj tag-obj -- obj bool )
1386     2over
1387     pair-type istype? false = if
1388         2drop 2drop false
1389     else
1390         car objeq?
1391     then ;
1392
1393 : quote? ( obj -- obj bool )
1394     quote-symbol tagged-list?  ;
1395
1396 : quote-body ( quote-obj -- quote-body-obj )
1397     cdr car ;
1398
1399 : variable? ( obj -- obj bool )
1400     symbol-type istype? ;
1401
1402 : definition? ( obj -- obj bool )
1403     define-symbol tagged-list? ;
1404
1405 : definition-var ( obj -- var )
1406     cdr car ;
1407
1408 : definition-val ( obj -- val )
1409     cdr cdr car ;
1410
1411 : assignment? ( obj -- obj bool )
1412     set!-symbol tagged-list? ;
1413
1414 : assignment-var ( obj -- var )
1415     cdr car ;
1416
1417 : assignment-val ( obj -- val )
1418     cdr cdr car ;
1419
1420 : macro-definition? ( obj -- obj bool )
1421     define-macro-symbol tagged-list? ;
1422
1423 : macro-definition-name ( exp -- mname )
1424     cdr car car ;
1425
1426 : macro-definition-params ( exp -- params )
1427     cdr car cdr ;
1428
1429 : macro-definition-body ( exp -- body )
1430     cdr cdr ;
1431
1432 : if? ( obj -- obj bool )
1433     if-symbol tagged-list? ;
1434
1435 : if-predicate ( ifobj -- pred )
1436     cdr car ;
1437
1438 : if-consequent ( ifobj -- conseq )
1439     cdr cdr car ;
1440
1441 : if-alternative ( ifobj -- alt|none )
1442     cdr cdr cdr
1443     nil? if
1444         2drop none
1445     else
1446         car
1447     then ;
1448
1449 : false? ( boolobj -- boolean )
1450     boolean-type istype? if
1451         false boolean-type objeq?
1452     else
1453         2drop false
1454     then
1455 ;
1456
1457 : true? ( boolobj -- bool )
1458     false? invert ;
1459
1460 : lambda? ( obj -- obj bool )
1461     lambda-symbol tagged-list? ;
1462
1463 : lambda-parameters ( obj -- params )
1464     cdr car ;
1465
1466 : lambda-body ( obj -- body )
1467     cdr cdr ;
1468
1469 : application? ( obj -- obj bool )
1470     pair-type istype? ;
1471
1472 : operator ( obj -- operator )
1473     car ;
1474
1475 : operands ( obj -- operands )
1476     cdr ;
1477
1478 : nooperands? ( operands -- bool )
1479     nil objeq? ;
1480
1481 : first-operand ( operands -- operand )
1482     car ;
1483
1484 : rest-operands ( operands -- other-operands )
1485     cdr ;
1486
1487 : procedure-params ( proc -- params )
1488     drop pair-type car ;
1489
1490 : procedure-body ( proc -- body )
1491     drop pair-type cdr car ;
1492
1493 : procedure-env ( proc -- body )
1494     drop pair-type cdr cdr car ;
1495
1496 ( Ensure terminating symbol arg name is handled
1497   specially to allow for variadic procedures. )
1498 : flatten-proc-args ( argvals argnames -- argvals' argnames' )
1499     nil? if
1500         2over nil? false = if
1501             except-message: ." Too many arguments for compound procedure." recoverable-exception throw
1502         else
1503             2drop
1504         then
1505         exit
1506     then
1507
1508     symbol-type istype? if
1509         nil cons
1510         2swap
1511         nil cons
1512         2swap
1513         exit
1514     then
1515
1516     2over
1517     nil? if
1518         except-message: ." Too few arguments for compound procedure." recoverable-exception throw
1519     else
1520         cdr
1521     then
1522
1523     2over cdr
1524
1525     recurse ( argvals argnames argvals'' argnames'' )
1526     2rot car 2swap cons  ( argvals argvals'' argnames' )
1527     2rot car 2rot cons ( argnames' argvals' )
1528     2swap
1529 ;
1530
1531 \ }}}
1532
1533 \ ---- Analyze ---- {{{
1534
1535 : evaluate-eproc ( eproc env --- res )
1536
1537     >R >R
1538
1539     begin
1540         nil? invert
1541     while
1542         2dup car
1543         2swap cdr
1544     repeat
1545
1546     2drop \ get rid of null
1547
1548     R> R> 2swap
1549
1550     \ Final element of eproc list is primitive procedure
1551     drop \ dump type signifier
1552
1553     goto \ jump straight to primitive procedure (executor)
1554 ;
1555
1556 : self-evaluating-executor ( exp env -- exp )
1557     2drop ;
1558
1559 : analyze-self-evaluating ( exp --- eproc )
1560     ['] self-evaluating-executor primitive-proc-type
1561     nil cons cons
1562 ;
1563
1564 : quote-executor ( exp env -- exp )
1565     2drop ;
1566
1567 : analyze-quoted ( exp -- eproc )
1568     quote-body
1569
1570     ['] quote-executor primitive-proc-type
1571     nil cons cons
1572 ;
1573
1574 : variable-executor ( var env -- val )
1575     lookup-var ;
1576
1577 : analyze-variable ( exp -- eproc )
1578     ['] variable-executor primitive-proc-type
1579     nil cons cons
1580 ;
1581
1582 : definition-executor ( var val-eproc env -- ok )
1583     2swap 2over ( var env val-eproc env )
1584     evaluate-eproc 2swap ( var val env )
1585     define-var
1586     ok-symbol
1587 ;
1588
1589 : analyze-definition ( exp -- eproc )
1590     2dup definition-var
1591     2swap definition-val analyze
1592
1593     ['] definition-executor primitive-proc-type
1594     nil cons cons cons
1595 ;
1596
1597 : assignment-executor ( var val-eproc env -- ok )
1598     2swap 2over ( var env val-eproc env )
1599     evaluate-eproc 2swap ( var val env )
1600     set-var
1601     ok-symbol
1602 ;
1603
1604 : analyze-assignment ( exp -- eproc )
1605     2dup assignment-var
1606     2swap assignment-val analyze ( var val-eproc )
1607
1608     ['] assignment-executor primitive-proc-type
1609     nil cons cons cons
1610 ;
1611
1612 : sequence-executor ( eproc-list env -- res )
1613     2swap
1614
1615     begin
1616         2dup cdr ( env elist elist-rest)
1617         nil? invert
1618     while
1619         -2rot car 2over ( elist-rest env elist-head env )
1620         evaluate-eproc  ( elist-rest env head-res )
1621         2drop 2swap     ( env elist-rest )
1622     repeat
1623
1624     2drop car 2swap
1625     ['] evaluate-eproc goto
1626 ;
1627
1628
1629 : (analyze-sequence) ( explist -- eproc-list )
1630     nil? if exit then
1631
1632     2dup car analyze
1633     2swap cdr recurse
1634
1635     cons
1636 ;
1637
1638 : analyze-sequence ( explist -- eproc )
1639     (analyze-sequence)
1640     ['] sequence-executor primitive-proc-type
1641     nil cons cons
1642 ;
1643
1644
1645 : macro-definition-executor  ( name params bproc env -- ok )
1646     make-macro ok-symbol
1647 ;
1648
1649 : analyze-macro-definition ( exp -- eproc )
1650     2dup macro-definition-name
1651     2swap 2dup macro-definition-params
1652     2swap macro-definition-body analyze-sequence
1653
1654     ['] macro-definition-executor primitive-proc-type
1655     nil cons cons cons cons
1656 ;
1657
1658 : if-executor ( cproc aproc pproc env -- res )
1659     2swap 2over ( cproc aproc env pproc env -- res )
1660     evaluate-eproc
1661
1662     true? if
1663         2swap 2drop
1664     else
1665         2rot 2drop
1666     then
1667
1668     ['] evaluate-eproc goto
1669 ;
1670
1671 : analyze-if ( exp -- eproc )
1672     2dup if-consequent analyze
1673     2swap 2dup if-alternative analyze
1674     2swap if-predicate analyze
1675
1676     ['] if-executor primitive-proc-type
1677     nil cons cons cons cons
1678 ;
1679
1680 : lambda-executor ( params bproc env -- res )
1681     make-procedure
1682     ( Although this is packaged up as a regular compound procedure,
1683       the "body" element contains an _eproc_ to be evaluated in an
1684       environment resulting from extending env with the parameter
1685       bindings. )
1686 ;
1687
1688 : analyze-lambda ( exp -- eproc )
1689     2dup lambda-parameters
1690     2swap lambda-body
1691
1692     nil? if
1693         except-message: ." encountered lambda with an empty body." recoverable-exception throw
1694     then
1695
1696     analyze-sequence
1697
1698     ['] lambda-executor primitive-proc-type
1699     nil cons cons cons
1700 ;
1701
1702 : operand-eproc-list ( operands -- eprocs )
1703     nil? invert if
1704         2dup car analyze
1705         2swap cdr recurse
1706         cons
1707     then
1708 ;
1709
1710 : evaluate-operand-eprocs ( env aprocs -- vals )
1711     nil? if
1712         2swap 2drop
1713     else
1714         2over 2over car 2swap evaluate-eproc ( env aprocs thisval )
1715         -2rot cdr recurse ( thisval restvals )
1716         cons
1717     then
1718 ;
1719
1720 : apply ( vals proc )
1721     dup case
1722         primitive-proc-type of
1723             drop execute
1724         endof
1725
1726         compound-proc-type of
1727                 2dup procedure-body ( argvals proc bproc )
1728                 -2rot 2dup procedure-params ( bproc argvals proc argnames )
1729                 -2rot procedure-env ( bproc argnames argvals procenv )
1730
1731                 -2rot 2swap
1732                 flatten-proc-args
1733                 2swap 2rot
1734
1735                 extend-env ( bproc env )
1736
1737                ['] evaluate-eproc goto
1738         endof
1739
1740         continuation-type of
1741           \ TODO: Apply continuation
1742         endof
1743
1744         except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
1745     endcase
1746 ;
1747
1748 : application-executor ( operator-proc arg-procs env -- res )
1749     2rot 2over ( aprocs env fproc env )
1750     evaluate-eproc ( aprocs env proc )
1751
1752     -2rot 2swap ( proc env aprocs )
1753     evaluate-operand-eprocs ( proc vals )
1754
1755     2swap ( vals proc )
1756
1757     ['] apply goto
1758 ;
1759
1760 : analyze-application ( exp -- eproc )
1761     2dup operator analyze
1762     2swap operands operand-eproc-list
1763
1764     ['] application-executor primitive-proc-type
1765     nil cons cons cons
1766 ;
1767
1768 :noname ( exp --- eproc )
1769
1770     self-evaluating? if analyze-self-evaluating exit then
1771
1772     quote? if analyze-quoted exit then
1773
1774     variable? if analyze-variable exit then
1775
1776     definition? if analyze-definition exit then
1777
1778     assignment? if analyze-assignment exit then
1779
1780     macro-definition? if analyze-macro-definition exit then
1781
1782     if? if analyze-if exit then
1783
1784     lambda? if analyze-lambda exit then
1785
1786     application? if analyze-application exit then
1787
1788     except-message: ." tried to analyze unknown expression type." recoverable-exception throw
1789
1790 ; is analyze
1791
1792 \ }}}
1793
1794 \ ---- Macro Expansion ---- {{{
1795
1796 ( Simply evaluates the given procedure with expbody as its argument. )
1797 : macro-eval ( proc expbody -- result )
1798     2swap
1799     2dup procedure-body ( expbody proc bproc )
1800     -2rot 2dup procedure-params ( bproc expbody proc argnames )
1801     -2rot procedure-env ( bproc argnames expbody procenv )
1802
1803     -2rot 2swap
1804     flatten-proc-args
1805     2swap 2rot
1806
1807     extend-env ( bproc env )
1808
1809     ['] evaluate-eproc goto
1810 ;
1811
1812 : expand-macro ( exp -- result )
1813     pair-type istype? invert if exit then
1814
1815     2dup car symbol-type istype? invert if 2drop exit then
1816
1817     lookup-macro nil? if 2drop exit then
1818
1819     2over cdr macro-eval
1820
1821     2dup no-match-symbol objeq? if
1822         2drop exit
1823     else
1824         2swap 2drop
1825     then
1826
1827     R> drop ['] expand goto-deferred
1828 ;
1829
1830 : expand-definition ( exp -- result )
1831     define-symbol 2swap
1832
1833     2dup definition-var
1834     2swap definition-val expand
1835     nil ( define var val' nil )
1836
1837     cons cons cons ;
1838
1839 : expand-assignment ( exp -- result )
1840     set!-symbol 2swap
1841
1842     2dup assignment-var
1843     2swap assignment-val expand
1844     nil ( define var val' nil )
1845
1846     cons cons cons ;
1847
1848 : expand-list ( exp -- res )
1849     nil? if exit then
1850
1851     2dup car expand
1852     2swap cdr recurse
1853
1854     cons ;
1855
1856 : macro-definition-nameparams
1857     cdr car ;
1858
1859 : expand-define-macro ( exp -- res )
1860     define-macro-symbol 2swap
1861     2dup macro-definition-nameparams
1862     2swap macro-definition-body expand-list
1863
1864     cons cons ;
1865
1866 : expand-lambda ( exp -- res )
1867     lambda-symbol 2swap
1868     2dup lambda-parameters
1869     2swap lambda-body expand-list
1870
1871     cons cons ;
1872
1873 : expand-if ( exp -- res )
1874     if-symbol 2swap
1875
1876     2dup if-predicate expand
1877     2swap 2dup if-consequent expand
1878     2swap if-alternative none? if
1879         2drop nil
1880     else
1881         expand nil cons
1882     then
1883
1884     cons cons cons ;
1885
1886 : expand-application ( exp -- res )
1887     2dup operator expand
1888     2swap operands expand-list
1889
1890     cons ;
1891
1892 :noname ( exp -- result )
1893     expand-macro
1894
1895     self-evaluating? if exit then
1896
1897     quote? if exit then
1898
1899     definition? if expand-definition exit then
1900
1901     assignment? if expand-assignment exit then
1902
1903     macro-definition? if expand-define-macro exit then
1904
1905     lambda? if expand-lambda exit then
1906
1907     if? if expand-if exit then
1908
1909     application? if expand-application exit then
1910
1911 ; is expand
1912
1913 \ }}}
1914
1915 :noname ( exp env -- res )
1916     2swap expand analyze 2swap evaluate-eproc
1917 ; is eval
1918
1919 \ ---- Print ---- {{{
1920
1921 : printfixnum ( fixnum -- ) drop 0 .R ;
1922
1923 : printflonum ( flonum -- ) drop f. ;
1924
1925 : printratnum ( ratnum -- )
1926     drop pair-type 2dup
1927     car print ." /" cdr print
1928 ;
1929
1930 : printbool ( bool -- )
1931     drop if
1932         ." #t"
1933     else
1934         ." #f"
1935     then
1936 ;
1937
1938 : printchar ( charobj -- )
1939     drop
1940     case
1941         9 of ." #\tab" endof
1942         bl of ." #\space" endof
1943         '\n' of ." #\newline" endof
1944
1945         dup ." #\" emit
1946     endcase
1947 ;
1948
1949 : (printstring) ( stringobj -- )
1950     nil? if 2drop exit then
1951
1952     2dup car drop dup
1953     case
1954         '\n' of ." \n" drop endof
1955         [char] \ of ." \\" drop endof
1956         [char] " of [char] \ emit [char] " emit drop endof
1957         emit
1958     endcase
1959
1960     cdr recurse
1961 ;
1962 : printstring ( stringobj -- )
1963     [char] " emit
1964     (printstring)
1965     [char] " emit ;
1966
1967 : printsymbol ( symbolobj -- )
1968     nil-type istype? if 2drop exit then
1969
1970     2dup car drop emit
1971     cdr recurse
1972 ;
1973
1974 : printnil ( nilobj -- )
1975     2drop ." ()" ;
1976
1977 : printpair ( pairobj -- )
1978     2dup
1979     car print
1980     cdr
1981     nil-type istype? if 2drop exit then
1982     pair-type istype? if space recurse exit then
1983     ."  . " print
1984 ;
1985
1986 : printprim ( primobj -- )
1987     2drop ." <primitive procedure>" ;
1988
1989 : printcomp ( primobj -- )
1990     2drop ." <compound procedure>" ;
1991
1992 : printcont ( primobj --)
1993     2drop ." <continuation>" ;
1994
1995 : printnone ( noneobj -- )
1996     2drop ." Unspecified return value" ;
1997
1998 : printport ( port -- )
1999     2drop ." <port>" ;
2000
2001 :noname ( obj -- )
2002     fixnum-type istype? if printfixnum exit then
2003     flonum-type istype? if printflonum exit then
2004     ratnum-type istype? if printratnum exit then
2005     boolean-type istype? if printbool exit then
2006     character-type istype? if printchar exit then
2007     string-type istype? if printstring exit then
2008     symbol-type istype? if printsymbol exit then
2009     nil-type istype? if printnil exit then
2010     pair-type istype? if ." (" printpair ." )" exit then
2011     primitive-proc-type istype? if printprim exit then
2012     compound-proc-type istype? if printcomp exit then
2013     continuation-type istype? if printcont exit then
2014     none-type istype? if printnone exit then
2015     port-type istype? if printport exit then
2016
2017     except-message: ." tried to print object with unknown type." recoverable-exception throw
2018 ; is print
2019
2020 \ }}}
2021
2022 \ ---- Garbage Collection ---- {{{
2023
2024 ( Notes on garbage collection:
2025   This is a mark-sweep garbage collector, invoked by cons.
2026   The roots of the object tree used by the marking routine
2027   include all objects in the parameter stack, and several
2028   other fixed roots such as global-env, symbol-table, macro-table,
2029   and the console-i/o-port.
2030
2031   NO OTHER OBJECTS WILL BE MARKED!
2032
2033   This places implicit restrictions on when cons can be invoked.
2034   Invoking cons when live objects are stored on the return stack
2035   or in other variables than the above will result in possible
2036   memory corruption if the cons triggers the GC. )
2037
2038
2039 : pairlike? ( obj -- obj bool )
2040     pair-type istype? if true exit then
2041     string-type istype? if true exit then
2042     symbol-type istype? if true exit then
2043     compound-proc-type istype? if true exit then
2044     port-type istype? if true exit then
2045
2046     false
2047 ;
2048
2049 : pairlike-marked? ( obj -- obj bool )
2050     over nextfrees + @ 0=
2051 ;
2052
2053 : mark-pairlike ( obj -- obj )
2054         over nextfrees + 0 swap !
2055 ;
2056
2057 : gc-unmark ( -- )
2058     scheme-memsize 0 do
2059         1 nextfrees i + !
2060     loop
2061 ;
2062
2063 : gc-mark-obj ( obj -- )
2064
2065     pairlike? invert if 2drop exit then
2066     pairlike-marked? if 2drop exit then
2067
2068     mark-pairlike
2069
2070     drop pair-type 2dup
2071
2072     car recurse
2073     cdr recurse
2074 ;
2075
2076 : gc-sweep
2077     scheme-memsize nextfree !
2078     0 scheme-memsize 1- do
2079         nextfrees i + @ 0<> if
2080             nextfree @ nextfrees i + !
2081             i nextfree !
2082         then
2083     -1 +loop
2084 ;
2085
2086 \ Following a GC, this gives the amount of free memory
2087 : gc-count-marked
2088     0
2089     scheme-memsize 0 do
2090         nextfrees i + @ 0= if 1+ then
2091     loop
2092 ;
2093
2094 \ Debugging word - helps spot memory that is retained
2095 : gc-zero-unmarked
2096     scheme-memsize 0 do
2097         nextfrees i + @ 0<> if
2098             0 car-cells i + !
2099             0 cdr-cells i + !
2100         then
2101     loop
2102 ;
2103
2104 :noname
2105     \ ." GC! "
2106
2107     gc-unmark
2108
2109     symbol-table obj@ gc-mark-obj
2110     macro-table obj@ gc-mark-obj
2111     console-i/o-port obj@ gc-mark-obj
2112     global-env obj@ gc-mark-obj
2113
2114     depth object-stack-base @ do
2115         PSP0 i + 1 + @
2116         PSP0 i + 2 + @
2117
2118         gc-mark-obj
2119     2 +loop
2120
2121     gc-sweep
2122
2123     \ ." (" gc-count-marked . ." pairs marked as used.)" cr
2124 ; is collect-garbage
2125
2126 \ }}}
2127
2128 xxxx
2129
2130 \ ---- Loading files ---- {{{
2131
2132 : load ( addr n -- finalResult )
2133     open-input-file
2134
2135     empty-parse-str
2136
2137     ok-symbol ( port res )
2138
2139     begin
2140         \ DEBUG
2141         \ bold fg blue ." READ from " 2over drop . ." ==> " reset-term
2142
2143         2over read-port ( port res obj )
2144
2145         \ DEBUG
2146         \ 2dup print cr
2147
2148         2dup EOF character-type objeq? if
2149             2drop 2swap close-port
2150             exit
2151         then
2152
2153         2swap 2drop ( port obj )
2154
2155         global-env obj@ eval ( port res )
2156     again
2157 ;
2158
2159 \ }}}
2160
2161 \ ---- Standard Library ---- {{{
2162
2163     include scheme-primitives.4th
2164
2165     init-object-stack-base
2166     s" scheme-library.scm" load 2drop
2167
2168 \ }}}
2169
2170 \ ---- REPL ----
2171
2172 ( REPL calls REPL-BODY in a loop until repl-body returns true. )
2173 : repl-body ( -- bool )
2174     cr bold fg green ." > " reset-term
2175
2176     read-console
2177
2178     2dup EOF character-type objeq? if
2179         2drop
2180         bold fg blue ." Moriturus te saluto." reset-term cr
2181         true exit
2182     then
2183
2184     global-env obj@ eval
2185
2186     fg cyan ." ; " print reset-term
2187
2188     false
2189 ;
2190
2191 : repl
2192     empty-parse-str
2193
2194     init-object-stack-base
2195
2196     \ Display welcome message
2197     welcome-symbol nil cons global-env obj@ eval 2drop
2198
2199     begin
2200         ['] repl-body catch
2201         case
2202             recoverable-exception of false endof
2203             unrecoverable-exception of true endof
2204
2205             throw false
2206         endcase
2207     until
2208 ;
2209
2210 forth definitions
2211
2212 \ vim:fdm=marker