scheme.4th

   1 vocabulary scheme
   2 scheme definitions
   3
   4 include term-colours.4th
   5
   6 0 constant number-type
   7 1 constant boolean-type
   8 2 constant character-type
   9 3 constant nil-type
  10 : istype? ( obj -- obj b )
  11     over = ;
  12
  13 \ ---- Read ----
  14
  15 variable parse-idx
  16 variable stored-parse-idx
  17 create parse-str 161 allot
  18 variable parse-str-span
  19
  20 create parse-idx-stack 10 allot
  21 variable parse-idx-sp
  22 parse-idx-stack parse-idx-sp !
  23
  24 : push-parse-idx
  25     parse-idx @ parse-idx-sp @ !
  26     1 parse-idx-sp +!
  27 ;
  28
  29 : pop-parse-idx
  30     parse-idx-sp @ parse-idx-stack <= abort" Parse index stack underflow."
  31
  32     1 parse-idx-sp -!
  33
  34     parse-idx-sp @ @ parse-idx ! ;
  35
  36
  37 : append-newline
  38     '\n' parse-str parse-str-span @ + !
  39     1 parse-str-span +! ;
  40
  41 : empty-parse-str
  42     0 parse-str-span !
  43     0 parse-idx ! ;
  44
  45 : getline
  46     parse-str 160 expect cr
  47     span @ parse-str-span !
  48     append-newline
  49     0 parse-idx ! ;
  50
  51 : inc-parse-idx
  52     1 parse-idx +! ;
  53
  54 : dec-parse-idx
  55     1 parse-idx -! ;
  56
  57 : charavailable? ( -- bool )
  58     parse-str-span @ parse-idx @ > ;
  59
  60 : nextchar ( -- char )
  61     charavailable? false = if getline then
  62     parse-str parse-idx @ + @ ;
  63
  64 : whitespace? ( -- bool )
  65     nextchar BL =
  66     nextchar '\n' = or ;
  67
  68 : eof? ( -- bool )
  69     nextchar 4 = ;
  70
  71 : delim? ( -- bool )
  72     whitespace?
  73     nextchar [char] ( = or
  74     nextchar [char] ) = or
  75 ;
  76
  77 : eatspaces
  78     begin
  79         whitespace?
  80     while
  81         inc-parse-idx
  82     repeat
  83 ;
  84
  85 : digit? ( -- bool )
  86     nextchar [char] 0 >=
  87     nextchar [char] 9 <=
  88     and ;
  89
  90 : minus? ( -- bool )
  91     nextchar [char] - = ;
  92
  93 : number? ( -- bool )
  94     digit? minus? or false = if
  95         false
  96         exit
  97     then
  98
  99     push-parse-idx
 100     inc-parse-idx
 101
 102     begin digit? while
 103         inc-parse-idx
 104     repeat
 105
 106     delim? if
 107         pop-parse-idx
 108         true
 109     else
 110         pop-parse-idx
 111         false
 112     then
 113 ;
 114
 115 : boolean? ( -- bool )
 116     nextchar [char] # <> if false exit then
 117
 118     push-parse-idx
 119     inc-parse-idx
 120
 121     nextchar [char] t <>
 122     nextchar [char] f <>
 123     and if pop-parse-idx false exit then
 124
 125     inc-parse-idx
 126     delim? if
 127         pop-parse-idx
 128         true
 129     else
 130         pop-parse-idx
 131         false
 132     then
 133 ;
 134
 135 : str-equiv? ( str -- bool )
 136
 137     push-parse-idx
 138
 139     true -rot
 140
 141     swap dup rot + swap
 142
 143     do
 144         i @ nextchar <> if
 145             drop false
 146             leave
 147         then
 148
 149         inc-parse-idx
 150     loop
 151
 152     delim? false = if drop false then
 153
 154     pop-parse-idx
 155 ;
 156
 157 : character? ( -- bool )
 158     nextchar [char] # <> if false exit then
 159
 160     push-parse-idx
 161     inc-parse-idx
 162
 163     nextchar [char] \ <> if pop-parse-idx false exit then
 164
 165     inc-parse-idx
 166
 167     S" newline" str-equiv? if pop-parse-idx true exit then
 168     S" space" str-equiv? if pop-parse-idx true exit then
 169     S" tab" str-equiv? if pop-parse-idx true exit then
 170
 171     charavailable? false = if pop-parse-idx false exit then
 172
 173     pop-parse-idx true
 174 ;
 175
 176 : empty-list? ( -- bool )
 177     nextchar [char] ( <> if false exit then
 178     push-parse-idx
 179     inc-parse-idx
 180     eatspaces
 181     nextchar [char] ) <> if pop-parse-idx false exit then
 182     pop-parse-idx true ;
 183
 184
 185 : readnum ( -- num-atom )
 186     minus? dup if
 187         inc-parse-idx
 188     then
 189
 190     0
 191
 192     begin digit? while
 193         10 * nextchar [char] 0 - +
 194         inc-parse-idx
 195     repeat
 196
 197     swap if negate then
 198
 199     number-type
 200 ;
 201
 202 : readbool ( -- bool-atom )
 203     inc-parse-idx
 204
 205     nextchar [char] f = if
 206         false
 207     else
 208         true
 209     then
 210
 211     inc-parse-idx
 212
 213     boolean-type
 214 ;
 215
 216 : readchar ( -- char-atom )
 217     inc-parse-idx
 218     inc-parse-idx
 219
 220     S" newline" str-equiv? if 7 parse-idx +! '\n' character-type exit then
 221     S" space" str-equiv? if 5 parse-idx +! bl character-type exit then
 222     S" tab" str-equiv? if 3 parse-idx +! 9 character-type exit then
 223
 224     nextchar character-type
 225
 226     inc-parse-idx
 227 ;
 228
 229 : readnil ( -- nil-atom )
 230     inc-parse-idx
 231     eatspaces
 232     inc-parse-idx
 233
 234     nil-type
 235 ;
 236
 237 \ Parse a scheme expression
 238 : read ( -- obj )
 239
 240     eatspaces
 241
 242     number? if
 243         readnum
 244         exit
 245     then
 246
 247     boolean? if
 248         readbool
 249         exit
 250     then
 251
 252     character? if
 253         readchar
 254         exit
 255     then
 256
 257     empty-list? if
 258         readnil
 259         exit
 260     then
 261
 262     eof? if
 263         bold fg blue ." Moriturus te saluto." reset-term ."  ok" cr
 264         quit
 265     then
 266
 267     bold fg red ." Error parsing string starting at character '"
 268     nextchar emit
 269     ." '. Aborting." reset-term cr
 270     abort
 271 ;
 272
 273 \ ---- Eval ----
 274
 275 : self-evaluating? ( obj -- obj bool )
 276     number-type istype? if true exit then
 277     boolean-type istype? if true exit then
 278     character-type istype? if true exit then
 279     nil-type istype? if true exit then
 280     false ;
 281
 282 : eval
 283     self-evaluating? if
 284         exit
 285     then
 286
 287     bold fg red ." Error evaluating expression - unrecognized type. Aborting." reset-term cr
 288     abort
 289 ;
 290
 291 \ ---- Print ----
 292
 293 : printnum ( numobj -- ) drop . ;
 294
 295 : printbool ( numobj -- )
 296     drop if
 297         ." #t"
 298     else
 299         ." #f"
 300     then
 301 ;
 302
 303 : printchar ( charobj -- )
 304     drop
 305     case
 306         9 of ." #\tab" endof
 307         bl of ." #\space" endof
 308         '\n' of ." #\newline" endof
 309
 310         dup ." #\" emit
 311     endcase
 312 ;
 313
 314 : printnil ( nilobj -- )
 315     drop ." ()" ;
 316
 317 : print ( obj -- )
 318     ." ; "
 319     number-type istype? if printnum exit then
 320     boolean-type istype? if printbool exit then
 321     character-type istype? if printchar exit then
 322     nil-type istype? if printnil exit then
 323 ;
 324
 325 \ ---- REPL ----
 326
 327 : repl
 328     cr ." Welcome to scheme.forth.jl!" cr
 329        ." Use Ctrl-D to exit." cr
 330
 331     empty-parse-str
 332
 333     begin
 334         cr bold fg green ." > " reset-term
 335         read
 336         eval
 337         fg cyan print reset-term
 338     again
 339 ;
 340
 341 forth definitions