scheme.4th

   1 \ Scheme interpreter
   2
   3 vocabulary scheme
   4 scheme definitions
   5
   6 include term-colours.4th
   7
   8 0 constant number-type
   9 1 constant boolean-type
  10 2 constant character-type
  11 : istype? ( obj -- obj b )
  12     over = ;
  13
  14 \ ---- Read ----
  15
  16 variable parse-idx
  17 variable stored-parse-idx
  18 create parse-str 161 allot
  19 variable parse-str-span
  20
  21 create parse-idx-stack 10 allot
  22 variable parse-idx-sp
  23 parse-idx-stack parse-idx-sp !
  24
  25 : push-parse-idx
  26     parse-idx @ parse-idx-sp @ !
  27     1 parse-idx-sp +!
  28 ;
  29
  30 : pop-parse-idx
  31     parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
  32
  33     1 parse-idx-sp -!
  34
  35     parse-idx-sp @ @ parse-idx ! ;
  36
  37
  38 : append-newline
  39     '\n' parse-str parse-str-span @ + !
  40     1 parse-str-span +! ;
  41
  42 : empty-parse-str
  43     0 parse-str-span !
  44     0 parse-idx ! ;
  45
  46 : getline
  47     parse-str 160 expect cr
  48     span @ parse-str-span !
  49     append-newline
  50     0 parse-idx ! ;
  51
  52 : inc-parse-idx
  53     1 parse-idx +! ;
  54
  55 : dec-parse-idx
  56     1 parse-idx -! ;
  57
  58 : charavailable? ( -- bool )
  59     parse-str-span @ parse-idx @ > ;
  60
  61 : nextchar ( -- char )
  62     charavailable? false = if getline then
  63     parse-str parse-idx @ + @ ;
  64
  65 : whitespace? ( -- bool )
  66     nextchar BL =
  67     nextchar '\n' = or ;
  68
  69 : eof? ( -- bool )
  70     nextchar 4 = ;
  71
  72 : delim? ( -- bool )
  73     whitespace?
  74     nextchar [char] ( = or
  75     nextchar [char] ) = or
  76 ;
  77
  78 : eatspaces
  79     begin
  80         whitespace?
  81     while
  82         inc-parse-idx
  83     repeat
  84 ;
  85
  86 : digit? ( -- bool )
  87     nextchar [char] 0 >=
  88     nextchar [char] 9 <=
  89     and ;
  90
  91 : minus? ( -- bool )
  92     nextchar [char] - = ;
  93
  94 : number? ( -- bool )
  95     digit? minus? or false = if
  96         false
  97         exit
  98     then
  99
 100     push-parse-idx
 101     inc-parse-idx
 102
 103     begin digit? while
 104         inc-parse-idx
 105     repeat
 106
 107     delim? if
 108         pop-parse-idx
 109         true
 110     else
 111         pop-parse-idx
 112         false
 113     then
 114 ;
 115
 116 : boolean? ( -- bool )
 117     nextchar [char] # <> if false exit then
 118
 119     push-parse-idx
 120     inc-parse-idx
 121
 122     nextchar [char] t <>
 123     nextchar [char] f <>
 124     and if pop-parse-idx false exit then
 125
 126     inc-parse-idx
 127     delim? if
 128         pop-parse-idx
 129         true
 130     else
 131         pop-parse-idx
 132         false
 133     then
 134 ;
 135
 136 : str-equiv? ( str -- bool )
 137
 138     push-parse-idx
 139
 140     true -rot
 141
 142     swap dup rot + swap
 143
 144     do
 145         i @ nextchar <> if
 146             drop false
 147             leave
 148         then
 149
 150         inc-parse-idx
 151     loop
 152
 153     delim? false = if drop false then
 154
 155     pop-parse-idx
 156 ;
 157
 158 : character? ( -- bool )
 159     nextchar [char] # <> if false exit then
 160
 161     push-parse-idx
 162     inc-parse-idx
 163
 164     nextchar [char] \ <> if pop-parse-idx false exit then
 165
 166     inc-parse-idx
 167
 168     S" newline" str-equiv? if true exit then
 169     S" space" str-equiv? if true exit then
 170     S" tab" str-equiv? if true exit then
 171
 172     charavailable? false = if pop-parse-idx false exit then
 173
 174     pop-parse-idx true
 175 ;
 176
 177 : readnum ( -- num-atom )
 178     minus? dup if
 179         inc-parse-idx
 180     then
 181
 182     0
 183
 184     begin digit? while
 185         10 * nextchar [char] 0 - +
 186         inc-parse-idx
 187     repeat
 188
 189     swap if negate then
 190
 191     number-type
 192 ;
 193
 194 : readbool ( -- bool-atom )
 195     inc-parse-idx
 196
 197     nextchar [char] f = if
 198         false
 199     else
 200         true
 201     then
 202
 203     inc-parse-idx
 204
 205     boolean-type
 206 ;
 207
 208 : readchar ( -- char-atom )
 209     inc-parse-idx
 210     inc-parse-idx
 211
 212     S" newline" str-equiv? if '\n' character-type exit then
 213     S" space" str-equiv? if bl character-type exit then
 214     S" tab" str-equiv? if 9 character-type exit then
 215
 216     nextchar character-type
 217
 218     inc-parse-idx
 219 ;
 220
 221 \ Parse a scheme expression
 222 : read ( -- obj )
 223
 224     eatspaces
 225
 226     number? if
 227         readnum
 228         exit
 229     then
 230
 231     boolean? if
 232         readbool
 233         exit
 234     then
 235
 236     character? if
 237         readchar
 238         exit
 239     then
 240
 241     eof? if
 242         bold fg blue ." Moriturus te saluto." reset-term ."  ok" cr
 243         quit
 244     then
 245
 246     bold fg red ." Error parsing string starting at character '"
 247     nextchar emit
 248     ." '. Aborting." reset-term cr
 249     abort
 250 ;
 251
 252 \ ---- Eval ----
 253
 254 : self-evaluating? ( obj -- obj bool )
 255     number-type istype? if true exit then
 256     boolean-type istype? if true exit then
 257     character-type istype? if true exit then
 258     false ;
 259
 260 : eval
 261     self-evaluating? if
 262         exit
 263     then
 264
 265     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
 266     abort
 267 ;
 268
 269 \ ---- Print ----
 270
 271 : printnum ( numobj -- ) drop . ;
 272
 273 : printbool ( numobj -- )
 274     drop if
 275         ." #t"
 276     else
 277         ." #f"
 278     then
 279 ;
 280
 281 : printchar ( charobj -- )
 282     drop
 283     case
 284         9 of ." #\tab" endof
 285         bl of ." #\space" endof
 286         '\n' of ." #\newline" endof
 287
 288         ." #\" emit
 289     endcase
 290
 291     trace
 292 ;
 293
 294 : print ( obj -- )
 295     ." ; "
 296     number-type istype? if printnum exit then
 297     boolean-type istype? if printbool exit then
 298     character-type istype? if printchar exit then
 299 ;
 300
 301 \ ---- REPL ----
 302
 303 : repl
 304     cr ." Welcome to scheme.forth.jl!" cr
 305        ." Use Ctrl-D to exit." cr
 306
 307     empty-parse-str
 308
 309     begin
 310         cr bold fg green ." > " reset-term
 311         read
 312         eval
 313         fg cyan print reset-term
 314     again
 315 ;
 316
 317 forth definitions