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