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