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