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