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