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