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