scheme.4th

   1 vocabulary scheme
   2 scheme definitions
   3
   4 include term-colours.4th
   5 include defer-is.4th
   6
   7 \ ------ Types ------
   8
   9 0 constant number-type
  10 1 constant boolean-type
  11 2 constant character-type
  12 3 constant string-type
  13 4 constant nil-type
  14 5 constant pair-type
  15 6 constant symbol-type
  16 : istype? ( obj type -- obj bool )
  17     over = ;
  18
  19 \ ------ Cons cell memory ------ {{{
  20
  21 1000 constant N
  22 create car-cells N allot
  23 create car-type-cells N allot
  24 create cdr-cells N allot
  25 create cdr-type-cells N allot
  26
  27 variable nextfree
  28 0 nextfree !
  29
  30 : cons ( car-obj cdr-obj -- pair-obj )
  31     cdr-type-cells nextfree @ + !
  32     cdr-cells nextfree @ + !
  33     car-type-cells nextfree @ + !
  34     car-cells nextfree @ + !
  35
  36     nextfree @ pair-type
  37
  38     1 nextfree +!
  39 ;
  40
  41 : car ( pair-obj -- car-obj )
  42     drop
  43     dup car-cells + @ swap
  44     car-type-cells + @
  45 ;
  46
  47 : cdr ( pair-obj -- car-obj )
  48     drop
  49     dup cdr-cells + @ swap
  50     cdr-type-cells + @
  51 ;
  52
  53 : set-car! ( obj pair-obj -- )
  54     drop dup
  55     rot swap  car-type-cells + !
  56     car-cells + !
  57 ;
  58
  59 : set-cdr! ( obj pair-obj -- )
  60     drop dup
  61     rot swap  cdr-type-cells + !
  62     cdr-cells + !
  63 ;
  64
  65 : caar car car ;
  66 : cadr cdr car ;
  67 : cdar car cdr ;
  68 : cddr cdr cdr ;
  69
  70 : nil 0 nil-type ;
  71 : nil? nil-type istype? ;
  72
  73 : objvar create nil swap , , ;
  74
  75 : value@ ( objvar -- val ) @ ;
  76 : type@ ( objvar -- type ) 1+ @ ;
  77 : value! ( newval objvar -- ) ! ;
  78 : type! ( newtype objvar -- ) 1+ ! ;
  79 : setobj ( newobj objvar -- ) dup rot swap 1+ ! ! ;
  80 : fetchobj ( objvar -- obj ) dup @ swap 1+ @ ;
  81
  82 : objeq? ( obj obj -- bool )
  83     rot = -rot = and ;
  84
  85 \ }}}
  86
  87 \ ---- Pre-defined symbols ---- {{{
  88
  89 objvar symbol-table
  90
  91 : (create-symbol) ( addr n -- symbol-obj )
  92     dup 0= if
  93         2drop nil
  94     else
  95         2dup drop @ character-type 2swap
  96         swap 1+ swap 1-
  97         recurse
  98
  99         cons
 100     then
 101 ;
 102
 103 : create-symbol ( -- )
 104     bl word
 105     count
 106
 107     (create-symbol)
 108     drop symbol-type
 109
 110     2dup
 111
 112     symbol-table fetchobj
 113     cons
 114     symbol-table setobj
 115
 116     create swap , ,
 117     does> dup @ swap 1+ @
 118 ;
 119
 120 create-symbol quote     quote-symbol
 121 create-symbol define    define-symbol
 122 create-symbol set!      set!-symbol
 123 create-symbol ok        ok-symbol
 124 create-symbol if        if-symbol
 125
 126 \ }}}
 127
 128 \ ---- Environments ---- {{{
 129
 130 : enclosing-env ( env -- env )
 131     cdr ;
 132
 133 : first-frame ( env -- frame )
 134     car ;
 135
 136 : make-frame ( vars vals -- frame )
 137     cons ;
 138
 139 : frame-vars ( frame -- vars )
 140     car ;
 141
 142 : frame-vals ( frame -- vals )
 143     cdr ;
 144
 145 : add-binding ( var val frame -- )
 146     2swap 2over frame-vals cons
 147     2over set-cdr!
 148     2swap 2over frame-vars cons
 149     2swap set-car!
 150 ;
 151
 152 : extend-env ( vars vals env -- env )
 153     >R >R
 154     make-frame
 155     R> R>
 156     cons
 157 ;
 158
 159 objvar vars
 160 objvar vals
 161
 162 : get-vars-vals-frame ( var frame -- bool )
 163     2dup frame-vars vars setobj
 164     frame-vals vals setobj
 165
 166     begin
 167         vars fetchobj nil objeq? false =
 168     while
 169         2dup vars fetchobj car objeq? if
 170             2drop true
 171             exit
 172         then
 173
 174         vars fetchobj cdr vars setobj
 175         vals fetchobj cdr vals setobj
 176     repeat
 177
 178     2drop false
 179 ;
 180
 181 : get-vars-vals ( var env -- vars? vals? bool )
 182
 183     begin
 184         2dup nil objeq? false =
 185     while
 186         2over 2over first-frame
 187         get-vars-vals-frame if
 188             2drop 2drop
 189             vars fetchobj vals fetchobj true
 190             exit
 191         then
 192
 193         enclosing-env
 194     repeat
 195
 196     2drop 2drop
 197     false
 198 ;
 199
 200 hide vars
 201 hide vals
 202
 203 : lookup-var ( var env -- val )
 204     get-vars-vals if
 205         2swap 2drop car
 206     else
 207         bold fg red ." Tried to read unbound variable." reset-term cr abort
 208     then
 209 ;
 210
 211 : set-var ( var val env -- )
 212     >R >R 2swap R> R> ( val var env )
 213     get-vars-vals if
 214         2swap 2drop ( val vals )
 215         set-car!
 216     else
 217         bold fg red ." Tried to set unbound variable." reset-term cr abort
 218     then
 219 ;
 220
 221 objvar env
 222
 223 : define-var ( var val env -- )
 224     env setobj
 225
 226     2over env fetchobj ( var val var env )
 227     get-vars-vals if
 228         2swap 2drop ( var val vals )
 229         set-car!
 230         2drop
 231     else
 232         env fetchobj
 233         first-frame ( var val frame )
 234         add-binding
 235     then
 236 ;
 237
 238 hide env
 239
 240 objvar global-env
 241 nil nil nil extend-env
 242 global-env setobj
 243
 244 \ }}}
 245
 246 \ ---- Read ---- {{{
 247
 248 variable parse-idx
 249 variable stored-parse-idx
 250 create parse-str 161 allot
 251 variable parse-str-span
 252
 253 create parse-idx-stack 10 allot
 254 variable parse-idx-sp
 255 parse-idx-stack parse-idx-sp !
 256
 257 : push-parse-idx
 258     parse-idx @ parse-idx-sp @ !
 259     1 parse-idx-sp +!
 260 ;
 261
 262 : pop-parse-idx
 263     parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
 264
 265     1 parse-idx-sp -!
 266
 267     parse-idx-sp @ @ parse-idx ! ;
 268
 269
 270 : append-newline
 271     '\n' parse-str parse-str-span @ + !
 272     1 parse-str-span +! ;
 273
 274 : empty-parse-str
 275     0 parse-str-span !
 276     0 parse-idx ! ;
 277
 278 : getline
 279     parse-str 160 expect cr
 280     span @ parse-str-span !
 281     append-newline
 282     0 parse-idx ! ;
 283
 284 : inc-parse-idx
 285     1 parse-idx +! ;
 286
 287 : dec-parse-idx
 288     1 parse-idx -! ;
 289
 290 : charavailable? ( -- bool )
 291     parse-str-span @ parse-idx @ > ;
 292
 293 : nextchar ( -- char )
 294     charavailable? false = if getline then
 295     parse-str parse-idx @ + @ ;
 296
 297 : whitespace? ( -- bool )
 298     nextchar BL =
 299     nextchar '\n' = or ;
 300
 301 : eof? ( -- bool )
 302     nextchar 4 = ;
 303
 304 : delim? ( -- bool )
 305     whitespace?
 306     nextchar [char] ( = or
 307     nextchar [char] ) = or
 308 ;
 309
 310 : eatspaces
 311     begin
 312         whitespace?
 313     while
 314         inc-parse-idx
 315     repeat
 316 ;
 317
 318 : digit? ( -- bool )
 319     nextchar [char] 0 >=
 320     nextchar [char] 9 <=
 321     and ;
 322
 323 : minus? ( -- bool )
 324     nextchar [char] - = ;
 325
 326 : number? ( -- bool )
 327     digit? minus? or false = if
 328         false
 329         exit
 330     then
 331
 332     push-parse-idx
 333     inc-parse-idx
 334
 335     begin digit? while
 336         inc-parse-idx
 337     repeat
 338
 339     delim? if
 340         pop-parse-idx
 341         true
 342     else
 343         pop-parse-idx
 344         false
 345     then
 346 ;
 347
 348 : boolean? ( -- bool )
 349     nextchar [char] # <> if false exit then
 350
 351     push-parse-idx
 352     inc-parse-idx
 353
 354     nextchar [char] t <>
 355     nextchar [char] f <>
 356     and if pop-parse-idx false exit then
 357
 358     inc-parse-idx
 359     delim? if
 360         pop-parse-idx
 361         true
 362     else
 363         pop-parse-idx
 364         false
 365     then
 366 ;
 367
 368 : str-equiv? ( str -- bool )
 369
 370     push-parse-idx
 371
 372     true -rot
 373
 374     swap dup rot + swap
 375
 376     do
 377         i @ nextchar <> if
 378             drop false
 379             leave
 380         then
 381
 382         inc-parse-idx
 383     loop
 384
 385     delim? false = if drop false then
 386
 387     pop-parse-idx
 388 ;
 389
 390 : character? ( -- bool )
 391     nextchar [char] # <> if false exit then
 392
 393     push-parse-idx
 394     inc-parse-idx
 395
 396     nextchar [char] \ <> if pop-parse-idx false exit then
 397
 398     inc-parse-idx
 399
 400     S" newline" str-equiv? if pop-parse-idx true exit then
 401     S" space" str-equiv? if pop-parse-idx true exit then
 402     S" tab" str-equiv? if pop-parse-idx true exit then
 403
 404     charavailable? false = if pop-parse-idx false exit then
 405
 406     pop-parse-idx true
 407 ;
 408
 409 : pair? ( -- bool )
 410     nextchar [char] ( = ;
 411
 412 : string? ( -- bool )
 413     nextchar [char] " = ;
 414
 415 : readnum ( -- num-atom )
 416     minus? dup if
 417         inc-parse-idx
 418     then
 419
 420     0
 421
 422     begin digit? while
 423         10 * nextchar [char] 0 - +
 424         inc-parse-idx
 425     repeat
 426
 427     swap if negate then
 428
 429     number-type
 430 ;
 431
 432 : readbool ( -- bool-atom )
 433     inc-parse-idx
 434
 435     nextchar [char] f = if
 436         false
 437     else
 438         true
 439     then
 440
 441     inc-parse-idx
 442
 443     boolean-type
 444 ;
 445
 446 : readchar ( -- char-atom )
 447     inc-parse-idx
 448     inc-parse-idx
 449
 450     S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
 451     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
 452     S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
 453
 454     nextchar character-type
 455
 456     inc-parse-idx
 457 ;
 458
 459 : readstring ( -- charlist )
 460     nextchar [char] " = if
 461         inc-parse-idx
 462
 463         delim? false = if
 464             bold fg red
 465             ." No delimiter following right double quote. Aborting." cr
 466             reset-term abort
 467         then
 468
 469         dec-parse-idx
 470
 471         0 nil-type exit
 472     then
 473
 474     nextchar [char] \ = if
 475         inc-parse-idx
 476         nextchar case
 477             [char] n of '\n' endof
 478             [char] " of [char] " endof
 479             [char] \
 480         endcase
 481     else
 482         nextchar
 483     then
 484     inc-parse-idx character-type
 485
 486     recurse
 487
 488     cons
 489 ;
 490
 491 : readsymbol ( -- charlist )
 492     delim? if nil exit then
 493
 494     nextchar inc-parse-idx character-type
 495
 496     recurse
 497
 498     cons
 499 ;
 500
 501 : charlist-equiv ( charlist charlist -- bool )
 502
 503     2over 2over
 504
 505     \ One or both nil
 506     nil? -rot 2drop
 507     if
 508         nil? -rot 2drop
 509         if
 510             2drop 2drop true exit
 511         else
 512             2drop 2drop false exit
 513         then
 514     else
 515         nil? -rot 2drop
 516         if
 517             2drop 2drop false exit
 518         then
 519     then
 520
 521     2over 2over
 522
 523     \ Neither nil
 524     car drop -rot car drop = if
 525             cdr 2swap cdr recurse
 526         else
 527             2drop 2drop false
 528     then
 529 ;
 530
 531 : charlist>symbol ( charlist -- symbol-obj )
 532
 533     symbol-table fetchobj
 534
 535     begin
 536         nil? false =
 537     while
 538         2over 2over
 539         car drop pair-type
 540         charlist-equiv if
 541             2swap 2drop
 542             car
 543             exit
 544         else
 545             cdr
 546         then
 547     repeat
 548
 549     2drop
 550     drop symbol-type 2dup
 551     symbol-table fetchobj cons
 552     symbol-table setobj
 553 ;
 554
 555 defer read
 556
 557 : readpair ( -- pairobj )
 558     eatspaces
 559
 560     \ Empty lists
 561     nextchar [char] ) = if
 562         inc-parse-idx
 563
 564         delim? false = if
 565             bold fg red
 566             ." No delimiter following right paren. Aborting." cr
 567             reset-term abort
 568         then
 569
 570         dec-parse-idx
 571
 572         0 nil-type exit
 573     then
 574
 575     \ Read first pair element
 576     read
 577
 578     \ Pairs
 579     eatspaces
 580     nextchar [char] . = if
 581         inc-parse-idx
 582
 583         delim? false = if
 584             bold fg red
 585             ." No delimiter following '.'. Aborting." cr
 586             reset-term abort
 587         then
 588
 589         eatspaces read
 590     else
 591         recurse
 592     then
 593
 594     eatspaces
 595
 596     cons
 597 ;
 598
 599 \ Parse a scheme expression
 600 :noname ( -- obj )
 601
 602     eatspaces
 603
 604     number? if
 605         readnum
 606         exit
 607     then
 608
 609     boolean? if
 610         readbool
 611         exit
 612     then
 613
 614     character? if
 615         readchar
 616         exit
 617     then
 618
 619     string? if
 620         inc-parse-idx
 621
 622         readstring
 623         drop string-type
 624
 625         nextchar [char] " <> if
 626             bold red ." Missing closing double-quote." reset-term cr
 627             abort
 628         then
 629
 630         inc-parse-idx
 631
 632         exit
 633     then
 634
 635     pair? if
 636         inc-parse-idx
 637
 638         eatspaces
 639
 640         readpair
 641
 642         eatspaces
 643
 644         nextchar [char] ) <> if
 645             bold red ." Missing closing paren." reset-term cr
 646             abort
 647         then
 648
 649         inc-parse-idx
 650
 651         exit
 652     then
 653
 654     nextchar [char] ' = if
 655         inc-parse-idx
 656         quote-symbol recurse nil cons cons exit
 657     then
 658
 659     eof? if
 660         bold fg blue ." Moriturus te saluto." reset-term ."  ok" cr
 661         quit
 662     then
 663
 664     \ Anything else is parsed as a symbol
 665     readsymbol charlist>symbol
 666
 667 ; is read
 668
 669 \ }}}
 670
 671 \ ---- Eval ---- {{{
 672
 673 defer eval
 674
 675 : self-evaluating? ( obj -- obj bool )
 676     boolean-type istype? if true exit then
 677     number-type istype? if true exit then
 678     character-type istype? if true exit then
 679     string-type istype? if true exit then
 680     nil-type istype? if true exit then
 681
 682     false
 683 ;
 684
 685 : tagged-list? ( obj tag-obj -- obj bool )
 686     2over
 687     pair-type istype? false = if
 688         2drop 2drop false
 689     else
 690         car objeq?
 691     then ;
 692
 693 : quote? ( obj -- obj bool )
 694     quote-symbol tagged-list?  ;
 695
 696 : quote-body ( quote-obj -- quote-body-obj )
 697     cadr ;
 698
 699 : variable? ( obj -- obj bool )
 700     symbol-type istype? ;
 701
 702 : definition? ( obj -- obj bool )
 703     define-symbol tagged-list? ;
 704
 705 : definition-var ( obj -- var )
 706     cdr car ;
 707
 708 : definition-val ( obj -- val )
 709     cdr cdr car ;
 710
 711 : assignment? ( obj -- obj bool )
 712     set!-symbol tagged-list? ;
 713
 714 : assignment-var ( obj -- var )
 715     cdr car ;
 716
 717 : assignment-val ( obj -- val )
 718     cdr cdr car ;
 719
 720 : eval-definition ( obj env -- res )
 721     2swap
 722     2over 2over ( env obj env obj )
 723     definition-val 2swap ( env obj valexp env )
 724     eval  ( env obj val )
 725
 726     2swap definition-var 2swap ( env var val )
 727
 728     >R >R 2swap R> R> 2swap ( var val env )
 729     define-var
 730
 731     ok-symbol
 732 ;
 733
 734 : eval-assignment ( obj env -- res )
 735     2swap
 736     2over 2over ( env obj env obj )
 737     assignment-val 2swap ( env obj valexp env )
 738     eval  ( env obj val )
 739
 740     2swap assignment-var 2swap ( env var val )
 741
 742     >R >R 2swap R> R> 2swap ( var val env )
 743     set-var
 744
 745     ok-symbol
 746 ;
 747
 748 : if? ( obj -- obj bool )
 749     if-symbol tagged-list? ;
 750
 751 : if-predicate ( ifobj -- pred )
 752     cdr car ;
 753
 754 : if-consequent ( ifobj -- conseq )
 755     cdr cdr car ;
 756
 757 : if-alternative ( ifobj -- alt|false )
 758     cdr cdr cdr
 759     2dup nil objeq? if
 760         2drop false
 761     else
 762         car
 763     then ;
 764
 765 : false? ( boolobj -- boolean )
 766     boolean-type istype? if
 767         false boolean-type objeq?
 768     else
 769         2drop false
 770     then
 771 ;
 772
 773 : true? ( boolobj -- boolean )
 774     false? invert ;
 775
 776 :noname ( obj env -- result )
 777     2swap
 778
 779     self-evaluating? if
 780         2swap 2drop
 781         exit
 782     then
 783
 784     quote? if
 785         quote-body
 786         2swap 2drop
 787         exit
 788     then
 789
 790     variable? if
 791         2swap lookup-var
 792         exit
 793     then
 794
 795     definition? if
 796         2swap eval-definition
 797         exit
 798     then
 799
 800     assignment? if
 801         2swap eval-assignment
 802         exit
 803     then
 804
 805     if? if
 806         2over 2over
 807         if-predicate
 808         2swap eval
 809
 810         true? if
 811             if-consequent
 812         else
 813             if-alternative
 814         then
 815
 816         2swap ['] eval goto
 817     then
 818
 819     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
 820     abort
 821 ; is eval
 822
 823 \ }}}
 824
 825 \ ---- Print ---- {{{
 826
 827 : printnum ( numobj -- ) drop 0 .R ;
 828
 829 : printbool ( numobj -- )
 830     drop if
 831         ." #t"
 832     else
 833         ." #f"
 834     then
 835 ;
 836
 837 : printchar ( charobj -- )
 838     drop
 839     case
 840         9 of ." #\tab" endof
 841         bl of ." #\space" endof
 842         '\n' of ." #\newline" endof
 843
 844         dup ." #\" emit
 845     endcase
 846 ;
 847
 848 : (printstring) ( stringobj -- )
 849     nil-type istype? if 2drop exit then
 850
 851     2dup car drop dup
 852     case
 853         '\n' of ." \n" drop endof
 854         [char] \ of ." \\" drop endof
 855         [char] " of [char] \ emit [char] " emit drop endof
 856         emit
 857     endcase
 858
 859     cdr recurse
 860 ;
 861 : printstring ( stringobj -- )
 862     [char] " emit
 863     (printstring)
 864     [char] " emit ;
 865
 866 : printsymbol ( symbolobj -- )
 867     nil-type istype? if 2drop exit then
 868
 869     2dup car drop emit
 870     cdr recurse
 871 ;
 872
 873 : printnil ( nilobj -- )
 874     2drop ." ()" ;
 875
 876 defer print
 877 : printpair ( pairobj -- )
 878     2dup
 879     car print
 880     cdr
 881     nil-type istype? if 2drop exit then
 882     pair-type istype? if space recurse exit then
 883     ."  . " print
 884 ;
 885
 886 :noname ( obj -- )
 887     number-type istype? if printnum exit then
 888     boolean-type istype? if printbool exit then
 889     character-type istype? if printchar exit then
 890     string-type istype? if printstring exit then
 891     symbol-type istype? if printsymbol exit then
 892     nil-type istype? if printnil exit then
 893     pair-type istype? if ." (" printpair ." )" exit then
 894
 895     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
 896     abort
 897 ; is print
 898
 899 \ }}}
 900
 901 \ ---- REPL ----
 902
 903 : repl
 904     cr ." Welcome to scheme.forth.jl!" cr
 905        ." Use Ctrl-D to exit." cr
 906
 907     empty-parse-str
 908
 909     begin
 910         cr bold fg green ." > " reset-term
 911         read
 912         global-env fetchobj eval
 913         fg cyan ." ; " print reset-term
 914     again
 915 ;
 916
 917 forth definitions
 918
 919 \ vim:fdm=marker