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