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