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