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     push-parse-idx
 138
 139     true
 140
 141     swap dup rot + swap
 142     do
 143         i @ nextchar <> if
 144             drop false
 145             leave
 146         then
 147
 148         inc-parse-idx
 149     loop
 150
 151     delim? <> if drop false then
 152
 153     pop-parse-idx
 154 ;
 155
 156 : character? ( -- bool )
 157     nextchar [char] # <> if false exit then
 158
 159     push-parse-idx
 160     inc-parse-idx
 161
 162     nextchar [char] \ <> if pop-parse-idx false exit then
 163
 164     inc-parse-idx
 165
 166     S" newline" str-equiv? if true exit then
 167     S" space" str-equiv? if true exit then
 168     S" tab" str-equiv? if true exit then
 169
 170     charavailable? false = if pop-parse-idx false exit then
 171
 172     pop-parse-idx true
 173 ;
 174
 175 : readnum ( -- num-atom )
 176     minus? dup if
 177         inc-parse-idx
 178     then
 179
 180     0
 181
 182     begin digit? while
 183         10 * nextchar [char] 0 - +
 184         inc-parse-idx
 185     repeat
 186
 187     swap if negate then
 188
 189     number-type
 190 ;
 191
 192 : readbool ( -- bool-atom )
 193     inc-parse-idx
 194
 195     nextchar [char] f = if
 196         false
 197     else
 198         true
 199     then
 200
 201     inc-parse-idx
 202
 203     boolean-type
 204 ;
 205
 206 : readchar ( -- char-atom )
 207     inc-parse-idx
 208     inc-parse-idx
 209
 210     S" newline" str-equiv? if '\n' character-type exit then
 211     S" space" str-equiv? if bl character-type exit then
 212     S" tab" str-equiv? if 9 character-type exit then
 213
 214     nextchar character-type
 215
 216     inc-parse-idx
 217 ;
 218
 219 \ Parse a scheme expression
 220 : read ( -- obj )
 221
 222     eatspaces
 223
 224     number? if
 225         readnum
 226         exit
 227     then
 228
 229     boolean? if
 230         readbool
 231         exit
 232     then
 233
 234     character? if
 235         readchar
 236         exit
 237     then
 238
 239     eof? if
 240         bold fg blue ." Moriturus te saluto." reset-term ."  ok" cr
 241         quit
 242     then
 243
 244     bold fg red ." Error parsing string starting at character '"
 245     nextchar emit
 246     ." '. Aborting." reset-term cr
 247     abort
 248 ;
 249
 250 \ ---- Eval ----
 251
 252 : self-evaluating? ( obj -- obj bool )
 253     number-type istype? if true exit then
 254     boolean-type istype? if true exit then
 255     false ;
 256
 257 : eval
 258     self-evaluating? if
 259         exit
 260     then
 261
 262     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
 263     abort
 264 ;
 265
 266 \ ---- Print ----
 267
 268 : printnum ( numobj -- ) drop . ;
 269
 270 : printbool ( numobj -- )
 271     drop if
 272         ." #t"
 273     else
 274         ." #f"
 275     then
 276 ;
 277
 278 : printchar ( charobj -- )
 279     drop
 280     case
 281         9 of ." #\tab" endof
 282         bl of ." #\space" endof
 283         '\n' of ." #\newline" endof
 284     endcase
 285 ;
 286
 287 : print ( obj -- )
 288     ." ; "
 289     number-type istype? if printnum exit then
 290     boolean-type istype? if printbool exit then
 291     character-type istype? if printchar exit then
 292 ;
 293
 294 \ ---- REPL ----
 295
 296 : repl
 297     cr ." Welcome to scheme.forth.jl!" cr
 298        ." Use Ctrl-D to exit." cr
 299
 300     empty-parse-str
 301
 302     begin
 303         cr bold fg green ." > " reset-term
 304         read
 305         eval
 306         fg cyan print reset-term
 307     again
 308 ;
 309
 310 forth definitions