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