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