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