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