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 : initial? ( -- bool )
 279     nextchar [char] A >= nextchar [char] Z <= and if true exit then
 280     nextchar [char] a >= nextchar [char] z <= and if true exit then
 281     nextchar [char] * = if true exit then
 282     nextchar [char] / = if true exit then
 283     nextchar [char] > = if true exit then
 284     nextchar [char] < = if true exit then
 285     nextchar [char] = = if true exit then
 286     nextchar [char] ? = if true exit then
 287     nextchar [char] ! = if true exit then
 288     false
 289 ;
 290
 291 : symbol? ( -- bool )
 292     initial? if true exit then
 293     nextchar [char] + =
 294     nextchar [char] - = or if
 295         inc-parse-idx
 296         delim? if dec-parse-idx true exit then
 297         dec-parse-idx
 298     then
 299     false
 300 ;
 301
 302 : readnum ( -- num-atom )
 303     minus? dup if
 304         inc-parse-idx
 305     then
 306
 307     0
 308
 309     begin digit? while
 310         10 * nextchar [char] 0 - +
 311         inc-parse-idx
 312     repeat
 313
 314     swap if negate then
 315
 316     number-type
 317 ;
 318
 319 : readbool ( -- bool-atom )
 320     inc-parse-idx
 321
 322     nextchar [char] f = if
 323         false
 324     else
 325         true
 326     then
 327
 328     inc-parse-idx
 329
 330     boolean-type
 331 ;
 332
 333 : readchar ( -- char-atom )
 334     inc-parse-idx
 335     inc-parse-idx
 336
 337     S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
 338     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
 339     S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
 340
 341     nextchar character-type
 342
 343     inc-parse-idx
 344 ;
 345
 346 : readstring ( -- charlist )
 347     nextchar [char] " = if
 348         inc-parse-idx
 349
 350         delim? false = if
 351             bold fg red
 352             ." No delimiter following right double quote. Aborting." cr
 353             reset-term abort
 354         then
 355
 356         dec-parse-idx
 357
 358         0 nil-type exit
 359     then
 360
 361     nextchar [char] \ = if
 362         inc-parse-idx
 363         nextchar case
 364             [char] n of '\n' endof
 365             [char] " of [char] " endof
 366             [char] \
 367         endcase
 368     else
 369         nextchar
 370     then
 371     inc-parse-idx character-type
 372
 373     recurse
 374
 375     cons
 376 ;
 377
 378 : readsymbol ( -- charlist )
 379     delim? if nil exit then
 380
 381     nextchar inc-parse-idx character-type
 382
 383     recurse
 384
 385     cons
 386 ;
 387
 388 : charlist-equiv ( charlist charlist -- bool )
 389
 390     2over 2over
 391
 392     \ One or both nil
 393     nil? -rot 2drop
 394     if
 395         nil? -rot 2drop
 396         if
 397             2drop 2drop true exit
 398         else
 399             2drop 2drop false exit
 400         then
 401     else
 402         nil? -rot 2drop
 403         if
 404             2drop 2drop false exit
 405         then
 406     then
 407
 408     2over 2over
 409
 410     \ Neither nil
 411     car drop -rot car drop = if
 412             cdr 2swap cdr recurse
 413         else
 414             2drop 2drop false
 415     then
 416 ;
 417
 418 : charlist>symbol ( charlist -- symbol-obj )
 419
 420     symbol-table fetchobj
 421
 422     begin
 423         nil? false =
 424     while
 425         2over 2over
 426         car drop pair-type
 427         charlist-equiv if
 428             2swap 2drop
 429             car
 430             exit
 431         else
 432             cdr
 433         then
 434     repeat
 435
 436     2drop
 437     drop symbol-type 2dup
 438     symbol-table fetchobj cons
 439     symbol-table setobj
 440 ;
 441
 442 defer read
 443
 444 : readpair ( -- pairobj )
 445     eatspaces
 446
 447     \ Empty lists
 448     nextchar [char] ) = if
 449         inc-parse-idx
 450
 451         delim? false = if
 452             bold fg red
 453             ." No delimiter following right paren. Aborting." cr
 454             reset-term abort
 455         then
 456
 457         dec-parse-idx
 458
 459         0 nil-type exit
 460     then
 461
 462     \ Read first pair element
 463     read
 464
 465     \ Pairs
 466     eatspaces
 467     nextchar [char] . = if
 468         inc-parse-idx
 469
 470         delim? false = if
 471             bold fg red
 472             ." No delimiter following '.'. Aborting." cr
 473             reset-term abort
 474         then
 475
 476         eatspaces read
 477     else
 478         recurse
 479     then
 480
 481     eatspaces
 482
 483     cons
 484 ;
 485
 486 \ Parse a scheme expression
 487 :noname ( -- obj )
 488
 489     eatspaces
 490
 491     number? if
 492         readnum
 493         exit
 494     then
 495
 496     boolean? if
 497         readbool
 498         exit
 499     then
 500
 501     character? if
 502         readchar
 503         exit
 504     then
 505
 506     string? if
 507         inc-parse-idx
 508         readstring
 509         drop string-type
 510
 511         nextchar [char] " <> if
 512             bold red ." Missing closing double-quote." reset-term cr
 513             abort
 514         then
 515
 516         inc-parse-idx
 517         exit
 518     then
 519
 520     symbol? if
 521         readsymbol charlist>symbol
 522         exit
 523     then
 524
 525     pair? if
 526         inc-parse-idx
 527
 528         eatspaces
 529
 530         readpair
 531
 532         eatspaces
 533
 534         nextchar [char] ) <> if
 535             bold red ." Missing closing paren." reset-term cr
 536             abort
 537         then
 538
 539         inc-parse-idx
 540
 541         exit
 542     then
 543
 544     nextchar [char] ' = if
 545         inc-parse-idx
 546         quote recurse nil cons cons exit
 547     then
 548
 549     eof? if
 550         bold fg blue ." Moriturus te saluto." reset-term ."  ok" cr
 551         quit
 552     then
 553
 554     bold fg red ." Error parsing string starting at character '"
 555     nextchar emit
 556     ." '. Aborting." reset-term cr
 557     abort
 558
 559 ; is read
 560
 561 \ ---- Eval ----
 562
 563 : self-evaluating? ( obj -- obj bool )
 564     boolean-type istype? if true exit then
 565     number-type istype? if true exit then
 566     character-type istype? if true exit then
 567     string-type istype? if true exit then
 568     nil-type istype? if true exit then
 569
 570     false
 571 ;
 572
 573 : tagged-list? ( obj tag-obj -- obj bool )
 574     2over
 575     pair-type istype? false = if
 576         2drop 2drop false
 577     else
 578         car objeq?
 579     then ;
 580
 581 : quote? ( obj -- obj bool )
 582     quote tagged-list?  ;
 583
 584 : quote-body ( quote-obj -- quote-body-obj )
 585     cadr ;
 586
 587 : eval
 588     self-evaluating? if
 589         exit
 590     then
 591
 592     quote? if
 593         quote-body
 594         exit
 595     then
 596
 597     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
 598     abort
 599 ;
 600
 601 \ ---- Print ----
 602
 603 : printnum ( numobj -- ) drop 0 .R ;
 604
 605 : printbool ( numobj -- )
 606     drop if
 607         ." #t"
 608     else
 609         ." #f"
 610     then
 611 ;
 612
 613 : printchar ( charobj -- )
 614     drop
 615     case
 616         9 of ." #\tab" endof
 617         bl of ." #\space" endof
 618         '\n' of ." #\newline" endof
 619
 620         dup ." #\" emit
 621     endcase
 622 ;
 623
 624 : (printstring) ( stringobj -- )
 625     nil-type istype? if 2drop exit then
 626
 627     2dup car drop dup
 628     case
 629         '\n' of ." \n" drop endof
 630         [char] \ of ." \\" drop endof
 631         [char] " of [char] \ emit [char] " emit drop endof
 632         emit
 633     endcase
 634
 635     cdr recurse
 636 ;
 637 : printstring ( stringobj -- )
 638     [char] " emit
 639     (printstring)
 640     [char] " emit ;
 641
 642 : printsymbol ( symbolobj -- )
 643     nil-type istype? if 2drop exit then
 644
 645     2dup car drop emit
 646     cdr recurse
 647 ;
 648
 649 : printnil ( nilobj -- )
 650     2drop ." ()" ;
 651
 652 defer print
 653 : printpair ( pairobj -- )
 654     2dup
 655     car print
 656     cdr
 657     nil-type istype? if 2drop exit then
 658     pair-type istype? if space recurse exit then
 659     ."  . " print
 660 ;
 661
 662 :noname ( obj -- )
 663     number-type istype? if printnum exit then
 664     boolean-type istype? if printbool exit then
 665     character-type istype? if printchar exit then
 666     string-type istype? if printstring exit then
 667     symbol-type istype? if printsymbol exit then
 668     nil-type istype? if printnil exit then
 669     pair-type istype? if ." (" printpair ." )" exit then
 670
 671     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
 672     abort
 673 ; is print
 674
 675 \ ---- REPL ----
 676
 677 : repl
 678     cr ." Welcome to scheme.forth.jl!" cr
 679        ." Use Ctrl-D to exit." cr
 680
 681     empty-parse-str
 682
 683     begin
 684         cr bold fg green ." > " reset-term
 685         read
 686         eval
 687         fg cyan ." ; " print reset-term
 688     again
 689 ;
 690
 691 forth definitions