scheme.4th

   1 vocabulary scheme
   2 scheme definitions
   3
   4 include term-colours.4th
   5 include defer-is.4th
   6
   7 0 constant number-type
   8 1 constant boolean-type
   9 2 constant character-type
  10 3 constant string-type
  11 4 constant nil-type
  12 5 constant pair-type
  13 6 constant symbol-type
  14 : istype? ( obj -- obj b )
  15     over = ;
  16
  17 100 constant N
  18 create car-cells N allot
  19 create car-type-cells N allot
  20 create cdr-cells N allot
  21 create cdr-type-cells N allot
  22
  23 variable nextfree
  24 0 nextfree !
  25
  26 : cons ( car-obj cdr-obj -- pair-obj )
  27     cdr-type-cells nextfree @ + !
  28     cdr-cells nextfree @ + !
  29     car-type-cells nextfree @ + !
  30     car-cells nextfree @ + !
  31
  32     nextfree @ pair-type
  33
  34     1 nextfree +!
  35 ;
  36
  37 : car ( pair-obj -- car-obj )
  38     drop
  39     dup car-cells + @ swap
  40     car-type-cells + @
  41 ;
  42
  43 : cdr ( pair-obj -- car-obj )
  44     drop
  45     dup cdr-cells + @ swap
  46     cdr-type-cells + @
  47 ;
  48
  49
  50 \ ---- Read ----
  51
  52 variable parse-idx
  53 variable stored-parse-idx
  54 create parse-str 161 allot
  55 variable parse-str-span
  56
  57 create parse-idx-stack 10 allot
  58 variable parse-idx-sp
  59 parse-idx-stack parse-idx-sp !
  60
  61 : push-parse-idx
  62     parse-idx @ parse-idx-sp @ !
  63     1 parse-idx-sp +!
  64 ;
  65
  66 : pop-parse-idx
  67     parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
  68
  69     1 parse-idx-sp -!
  70
  71     parse-idx-sp @ @ parse-idx ! ;
  72
  73
  74 : append-newline
  75     '\n' parse-str parse-str-span @ + !
  76     1 parse-str-span +! ;
  77
  78 : empty-parse-str
  79     0 parse-str-span !
  80     0 parse-idx ! ;
  81
  82 : getline
  83     parse-str 160 expect cr
  84     span @ parse-str-span !
  85     append-newline
  86     0 parse-idx ! ;
  87
  88 : inc-parse-idx
  89     1 parse-idx +! ;
  90
  91 : dec-parse-idx
  92     1 parse-idx -! ;
  93
  94 : charavailable? ( -- bool )
  95     parse-str-span @ parse-idx @ > ;
  96
  97 : nextchar ( -- char )
  98     charavailable? false = if getline then
  99     parse-str parse-idx @ + @ ;
 100
 101 : whitespace? ( -- bool )
 102     nextchar BL =
 103     nextchar '\n' = or ;
 104
 105 : eof? ( -- bool )
 106     nextchar 4 = ;
 107
 108 : delim? ( -- bool )
 109     whitespace?
 110     nextchar [char] ( = or
 111     nextchar [char] ) = or
 112 ;
 113
 114 : eatspaces
 115     begin
 116         whitespace?
 117     while
 118         inc-parse-idx
 119     repeat
 120 ;
 121
 122 : digit? ( -- bool )
 123     nextchar [char] 0 >=
 124     nextchar [char] 9 <=
 125     and ;
 126
 127 : minus? ( -- bool )
 128     nextchar [char] - = ;
 129
 130 : number? ( -- bool )
 131     digit? minus? or false = if
 132         false
 133         exit
 134     then
 135
 136     push-parse-idx
 137     inc-parse-idx
 138
 139     begin digit? while
 140         inc-parse-idx
 141     repeat
 142
 143     delim? if
 144         pop-parse-idx
 145         true
 146     else
 147         pop-parse-idx
 148         false
 149     then
 150 ;
 151
 152 : boolean? ( -- bool )
 153     nextchar [char] # <> if false exit then
 154
 155     push-parse-idx
 156     inc-parse-idx
 157
 158     nextchar [char] t <>
 159     nextchar [char] f <>
 160     and if pop-parse-idx false exit then
 161
 162     inc-parse-idx
 163     delim? if
 164         pop-parse-idx
 165         true
 166     else
 167         pop-parse-idx
 168         false
 169     then
 170 ;
 171
 172 : str-equiv? ( str -- bool )
 173
 174     push-parse-idx
 175
 176     true -rot
 177
 178     swap dup rot + swap
 179
 180     do
 181         i @ nextchar <> if
 182             drop false
 183             leave
 184         then
 185
 186         inc-parse-idx
 187     loop
 188
 189     delim? false = if drop false then
 190
 191     pop-parse-idx
 192 ;
 193
 194 : character? ( -- bool )
 195     nextchar [char] # <> if false exit then
 196
 197     push-parse-idx
 198     inc-parse-idx
 199
 200     nextchar [char] \ <> if pop-parse-idx false exit then
 201
 202     inc-parse-idx
 203
 204     S" newline" str-equiv? if pop-parse-idx true exit then
 205     S" space" str-equiv? if pop-parse-idx true exit then
 206     S" tab" str-equiv? if pop-parse-idx true exit then
 207
 208     charavailable? false = if pop-parse-idx false exit then
 209
 210     pop-parse-idx true
 211 ;
 212
 213 : pair? ( -- bool )
 214     nextchar [char] ( = ;
 215
 216 : string? ( -- bool )
 217     nextchar [char] " = ;
 218
 219 : readnum ( -- num-atom )
 220     minus? dup if
 221         inc-parse-idx
 222     then
 223
 224     0
 225
 226     begin digit? while
 227         10 * nextchar [char] 0 - +
 228         inc-parse-idx
 229     repeat
 230
 231     swap if negate then
 232
 233     number-type
 234 ;
 235
 236 : readbool ( -- bool-atom )
 237     inc-parse-idx
 238
 239     nextchar [char] f = if
 240         false
 241     else
 242         true
 243     then
 244
 245     inc-parse-idx
 246
 247     boolean-type
 248 ;
 249
 250 : readchar ( -- char-atom )
 251     inc-parse-idx
 252     inc-parse-idx
 253
 254     S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
 255     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
 256     S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
 257
 258     nextchar character-type
 259
 260     inc-parse-idx
 261 ;
 262
 263 : readstring ( -- str-obj )
 264     nextchar [char] " = if
 265         inc-parse-idx
 266
 267         delim? false = if
 268             bold fg red
 269             ." No delimiter following right double quote. Aborting." cr
 270             reset-term abort
 271         then
 272
 273         dec-parse-idx
 274
 275         0 nil-type exit
 276     then
 277
 278     nextchar [char] \ = if
 279         inc-parse-idx
 280         nextchar case
 281             [char] n of '\n' endof
 282             [char] " of [char] " endof
 283             [char] \
 284         endcase
 285     else
 286         nextchar
 287     then
 288     inc-parse-idx character-type
 289
 290     recurse
 291
 292     cons
 293 ;
 294
 295 defer read
 296
 297 : readpair ( -- obj )
 298     eatspaces
 299
 300     \ Empty lists
 301     nextchar [char] ) = if
 302         inc-parse-idx
 303
 304         delim? false = if
 305             bold fg red
 306             ." No delimiter following right paren. Aborting." cr
 307             reset-term abort
 308         then
 309
 310         dec-parse-idx
 311
 312         0 nil-type exit
 313     then
 314
 315     \ Read first pair element
 316     read
 317
 318     \ Pairs
 319     eatspaces
 320     nextchar [char] . = if
 321         inc-parse-idx
 322
 323         delim? false = if
 324             bold fg red
 325             ." No delimiter following '.'. Aborting." cr
 326             reset-term abort
 327         then
 328
 329         eatspaces read
 330     else
 331         recurse
 332     then
 333
 334     eatspaces
 335
 336     cons
 337 ;
 338
 339 \ Parse a scheme expression
 340 :noname ( -- obj )
 341
 342     eatspaces
 343
 344     number? if
 345         readnum
 346         exit
 347     then
 348
 349     boolean? if
 350         readbool
 351         exit
 352     then
 353
 354     character? if
 355         readchar
 356         exit
 357     then
 358
 359     string? if
 360         inc-parse-idx
 361         readstring
 362         drop string-type
 363
 364         nextchar [char] " <> if
 365             bold red ." Missing closing double-quote." reset-term cr
 366             abort
 367         then
 368
 369         inc-parse-idx
 370         exit
 371     then
 372
 373     pair? if
 374         inc-parse-idx
 375
 376         eatspaces
 377
 378         readpair
 379
 380         eatspaces
 381
 382         nextchar [char] ) <> if
 383             bold red ." Missing closing paren." reset-term cr
 384             abort
 385         then
 386
 387         inc-parse-idx
 388
 389         exit
 390     then
 391
 392     eof? if
 393         bold fg blue ." Moriturus te saluto." reset-term ."  ok" cr
 394         quit
 395     then
 396
 397     bold fg red ." Error parsing string starting at character '"
 398     nextchar emit
 399     ." '. Aborting." reset-term cr
 400     abort
 401
 402 ; is read
 403
 404 \ ---- Eval ----
 405
 406 : self-evaluating? ( obj -- obj bool )
 407     number-type istype? if true exit then
 408     boolean-type istype? if true exit then
 409     character-type istype? if true exit then
 410     string-type istype? if true exit then
 411     nil-type istype? if true exit then
 412     false ;
 413
 414 : eval
 415     \ self-evaluating? if
 416     \     exit
 417     \ then
 418     exit
 419
 420     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
 421     abort
 422 ;
 423
 424 \ ---- Print ----
 425
 426 : printnum ( numobj -- ) drop 0 .R ;
 427
 428 : printbool ( numobj -- )
 429     drop if
 430         ." #t"
 431     else
 432         ." #f"
 433     then
 434 ;
 435
 436 : printchar ( charobj -- )
 437     drop
 438     case
 439         9 of ." #\tab" endof
 440         bl of ." #\space" endof
 441         '\n' of ." #\newline" endof
 442
 443         dup ." #\" emit
 444     endcase
 445 ;
 446
 447 : (printstring) ( stringobj -- )
 448     nil-type istype? if 2drop exit then
 449
 450     2dup car drop dup
 451     case
 452         '\n' of ." \n" drop endof
 453         [char] \ of ." \\" drop endof
 454         [char] " of [char] \ emit [char] " emit drop endof
 455         emit
 456     endcase
 457
 458     cdr recurse
 459 ;
 460 : printstring ( stringobj -- )
 461     [char] " emit
 462     (printstring)
 463     [char] " emit ;
 464
 465 : printnil ( nilobj -- )
 466     2drop ." ()" ;
 467
 468 defer print
 469 : printpair ( pairobj -- )
 470     2dup
 471     car print
 472     cdr
 473     nil-type istype? if 2drop exit then
 474     pair-type istype? if space recurse exit then
 475     ."  . " print
 476 ;
 477
 478 :noname ( obj -- )
 479     number-type istype? if printnum exit then
 480     boolean-type istype? if printbool exit then
 481     character-type istype? if printchar exit then
 482     string-type istype? if printstring exit then
 483     nil-type istype? if printnil exit then
 484     pair-type istype? if ." (" printpair ." )" exit then
 485
 486     bold fg red ." Error printing expression - unrecognized type. Aborting" reset-term cr
 487     abort
 488 ; is print
 489
 490 \ ---- REPL ----
 491
 492 : repl
 493     cr ." Welcome to scheme.forth.jl!" cr
 494        ." Use Ctrl-D to exit." cr
 495
 496     empty-parse-str
 497
 498     begin
 499         cr bold fg green ." > " reset-term
 500         read
 501         eval
 502         fg cyan ." ; " print reset-term
 503     again
 504 ;
 505
 506 forth definitions