scheme.4th

   1 vocabulary scheme
   2 scheme definitions
   3
   4 include term-colours.4th
   5
   6 0 constant number-type
   7 1 constant boolean-type
   8 2 constant character-type
   9 : istype? ( obj -- obj b )
  10     over = ;
  11
  12 \ ---- Read ----
  13
  14 variable parse-idx
  15 variable stored-parse-idx
  16 create parse-str 161 allot
  17 variable parse-str-span
  18
  19 create parse-idx-stack 10 allot
  20 variable parse-idx-sp
  21 parse-idx-stack parse-idx-sp !
  22
  23 : push-parse-idx
  24     parse-idx @ parse-idx-sp @ !
  25     1 parse-idx-sp +!
  26 ;
  27
  28 : pop-parse-idx
  29     parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
  30
  31     1 parse-idx-sp -!
  32
  33     parse-idx-sp @ @ parse-idx ! ;
  34
  35
  36 : append-newline
  37     '\n' parse-str parse-str-span @ + !
  38     1 parse-str-span +! ;
  39
  40 : empty-parse-str
  41     0 parse-str-span !
  42     0 parse-idx ! ;
  43
  44 : getline
  45     parse-str 160 expect cr
  46     span @ parse-str-span !
  47     append-newline
  48     0 parse-idx ! ;
  49
  50 : inc-parse-idx
  51     1 parse-idx +! ;
  52
  53 : dec-parse-idx
  54     1 parse-idx -! ;
  55
  56 : charavailable? ( -- bool )
  57     parse-str-span @ parse-idx @ > ;
  58
  59 : nextchar ( -- char )
  60     charavailable? false = if getline then
  61     parse-str parse-idx @ + @ ;
  62
  63 : whitespace? ( -- bool )
  64     nextchar BL =
  65     nextchar '\n' = or ;
  66
  67 : eof? ( -- bool )
  68     nextchar 4 = ;
  69
  70 : delim? ( -- bool )
  71     whitespace?
  72     nextchar [char] ( = or
  73     nextchar [char] ) = or
  74 ;
  75
  76 : eatspaces
  77     begin
  78         whitespace?
  79     while
  80         inc-parse-idx
  81     repeat
  82 ;
  83
  84 : digit? ( -- bool )
  85     nextchar [char] 0 >=
  86     nextchar [char] 9 <=
  87     and ;
  88
  89 : minus? ( -- bool )
  90     nextchar [char] - = ;
  91
  92 : number? ( -- bool )
  93     digit? minus? or false = if
  94         false
  95         exit
  96     then
  97
  98     push-parse-idx
  99     inc-parse-idx
 100
 101     begin digit? while
 102         inc-parse-idx
 103     repeat
 104
 105     delim? if
 106         pop-parse-idx
 107         true
 108     else
 109         pop-parse-idx
 110         false
 111     then
 112 ;
 113
 114 : boolean? ( -- bool )
 115     nextchar [char] # <> if false exit then
 116
 117     push-parse-idx
 118     inc-parse-idx
 119
 120     nextchar [char] t <>
 121     nextchar [char] f <>
 122     and if pop-parse-idx false exit then
 123
 124     inc-parse-idx
 125     delim? if
 126         pop-parse-idx
 127         true
 128     else
 129         pop-parse-idx
 130         false
 131     then
 132 ;
 133
 134 : str-equiv? ( str -- bool )
 135
 136     push-parse-idx
 137
 138     true -rot
 139
 140     swap dup rot + swap
 141
 142     do
 143         i @ nextchar <> if
 144             drop false
 145             leave
 146         then
 147
 148         inc-parse-idx
 149     loop
 150
 151     delim? false = 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 pop-parse-idx true exit then
 167     S" space" str-equiv? if pop-parse-idx true exit then
 168     S" tab" str-equiv? if pop-parse-idx 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 7 parse-idx +! '\n' character-type exit then
 211     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
 212     S" tab" str-equiv? if 3 parse-idx +! 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     character-type istype? if true exit then
 256     false ;
 257
 258 : eval
 259     self-evaluating? if
 260         exit
 261     then
 262
 263     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
 264     abort
 265 ;
 266
 267 \ ---- Print ----
 268
 269 : printnum ( numobj -- ) drop . ;
 270
 271 : printbool ( numobj -- )
 272     drop if
 273         ." #t"
 274     else
 275         ." #f"
 276     then
 277 ;
 278
 279 : printchar ( charobj -- )
 280     drop
 281     case
 282         9 of ." #\tab" endof
 283         bl of ." #\space" endof
 284         '\n' of ." #\newline" endof
 285
 286         dup ." #\" emit
 287     endcase
 288 ;
 289
 290 : print ( obj -- )
 291     ." ; "
 292     number-type istype? if printnum exit then
 293     boolean-type istype? if printbool exit then
 294     character-type istype? if printchar exit then
 295 ;
 296
 297 \ ---- REPL ----
 298
 299 : repl
 300     cr ." Welcome to scheme.forth.jl!" cr
 301        ." Use Ctrl-D to exit." cr
 302
 303     empty-parse-str
 304
 305     begin
 306         cr bold fg green ." > " reset-term
 307         read
 308         eval
 309         fg cyan print reset-term
 310     again
 311 ;
 312
 313 forth definitions