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 : append-newline
  22     1 parse-str-span +!
  23     '\n' parse-str parse-str-span @ + ! ;
  24
  25 : getline
  26     parse-str 160 expect
  27     span @ parse-str-span !
  28     append-newline
  29     0 parse-idx ! ;
  30
  31 : inc-parse-idx
  32     1 parse-idx +! ;
  33
  34 : dec-parse-idx
  35     1 parse-idx -! ;
  36
  37 : store-parse-idx
  38     parse-idx @ stored-parse-idx !  ;
  39
  40 : restore-parse-idx
  41     stored-parse-idx @ parse-idx !  ;
  42
  43
  44 : charavailable? ( -- bool )
  45     parse-str-span @ parse-idx @ >
  46 ;
  47
  48 : nextchar ( -- char )
  49     charavailable? false = if getline then
  50     parse-str parse-idx @ + @ ;
  51
  52 : whitespace? ( -- bool )
  53     nextchar BL =
  54     nextchar '\n' = or
  55 ;
  56
  57 : delim? ( -- bool )
  58     whitespace?
  59     nextchar [char] ( = or
  60     nextchar [char] ) = or
  61 ;
  62
  63 : eatspaces
  64     begin
  65         whitespace?
  66     while
  67         inc-parse-idx
  68     repeat
  69 ;
  70
  71 : digit? ( -- bool )
  72     nextchar [char] 0 >=
  73     nextchar [char] 9 <=
  74     and ;
  75
  76 : minus? ( -- bool )
  77     nextchar [char] - = ;
  78
  79 : number? ( -- bool )
  80     digit? minus? or false = if
  81         false
  82         exit
  83     then
  84
  85     store-parse-idx
  86     inc-parse-idx
  87
  88     begin digit? while
  89         inc-parse-idx
  90     repeat
  91
  92     delim? charavailable? false = or if
  93         restore-parse-idx
  94         true
  95     else
  96         restore-parse-idx
  97         false
  98     then
  99 ;
 100
 101 : boolean? ( -- bool )
 102     nextchar [char] # <> if false exit then
 103
 104     store-parse-idx
 105     inc-parse-idx
 106
 107     nextchar [char] t <>
 108     nextchar [char] f <>
 109     and if restore-parse-idx false exit then
 110
 111     restore-parse-idx
 112     true
 113 ;
 114
 115 : character? ( -- bool )
 116     nextchar [char] # <> if false exit then
 117
 118     store-parse-idx
 119     inc-parse-idx
 120
 121     nextchar [char] \ <> if restore-parse-idx false exit then
 122
 123     inc-parse-idx
 124
 125     charavailable? false = if restore-parse-idx false exit then
 126
 127     restore-parse-idx true
 128 ;
 129
 130 : readnum ( -- num-atom )
 131     minus? dup if
 132         inc-parse-idx
 133     then
 134
 135     0
 136
 137     begin digit? while
 138         10 * nextchar [char] 0 - +
 139         inc-parse-idx
 140     repeat
 141
 142     swap if negate then
 143
 144     number-type
 145 ;
 146
 147 : readbool ( -- bool-atom )
 148     inc-parse-idx
 149
 150     nextchar [char] f = if
 151         false
 152     else
 153         true
 154     then
 155
 156     boolean-type
 157 ;
 158
 159 \ Parse a scheme expression
 160 : read ( -- obj )
 161
 162     eatspaces
 163
 164     number? if
 165         readnum
 166         exit
 167     then
 168
 169     boolean? if
 170         readbool
 171         exit
 172     then
 173
 174     bold fg red ." Error parsing string starting at character '"
 175     nextchar emit
 176     ." '. Aborting." reset-term cr
 177     abort
 178 ;
 179
 180 \ ---- Eval ----
 181
 182 : self-evaluating? ( obj -- obj bool )
 183     number-type istype? if true exit then
 184     boolean-type istype? if true exit then
 185     false ;
 186
 187 : eval
 188     self-evaluating? if
 189         exit
 190     then
 191
 192     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
 193     abort
 194 ;
 195
 196 \ ---- Print ----
 197
 198 : printnum ( numobj -- ) drop . ;
 199
 200 : printbool ( numobj -- )
 201     drop if
 202         ." #t"
 203     else
 204         ." #f"
 205     then
 206 ;
 207
 208 : print ( obj -- )
 209     ." ; "
 210     number-type istype? if ." => " printnum exit then
 211     boolean-type istype? if ." => " printbool exit then
 212 ;
 213
 214 \ ---- REPL ----
 215
 216 : repl
 217     cr ." Welcome to scheme.forth.jl!" cr
 218        ." Use Ctrl-D to exit." cr
 219
 220     begin
 221         cr bold fg green ." > " reset-term
 222         read
 223         eval
 224         fg cyan print reset-term
 225     again
 226 ;
 227
 228 forth definitions