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