scheme.4th

   1 \ Scheme interpreter
   2
   3 vocabulary scheme
   4 scheme definitions
   5
   6 \ Cons cell memory
   7 1000 constant memsize
   8 create car memsize allot
   9 create cdr memsize allot
  10 create types memsize allot
  11
  12 0 constant symbol-type
  13 1 constant int-type
  14 2 constant list-type
  15 3 constant bool-type
  16
  17 variable nextfree
  18 0 nextfree !
  19
  20 : stack
  21     create here 1+ , allot ;
  22
  23
  24 : push ( st v -- )
  25     over @ !
  26     1 swap +!
  27 ;
  28
  29 : pop ( st -- v )
  30     dup @       ( s0 sp )
  31     1-          ( so sp' )
  32
  33     2dup = abort" Stack underflow."
  34
  35     dup @       ( s0 sp' v )
  36     -rot swap   ( v sp' s0 )
  37     !
  38 ;
  39
  40 100 stack parse-stack
  41 variable parse-idx
  42 variable parse-str
  43
  44
  45 : inc-parse-idx parse-idx +! ;
  46 : dec-parse-idx parse-idx -! ;
  47
  48 : ?charavailable ( -- bool )
  49     parse-str @ @ parse-idx @ >
  50 ;
  51
  52 : nextchar ( -- char )
  53     ?charavailable if
  54         parse-str @ 1+ parse-idx @ + @
  55     else
  56         0
  57     then
  58 ;
  59
  60 : ?whitespace ( -- bool )
  61     nextchar BL =
  62     nextchar '\n' = or
  63 ;
  64
  65 : ?delim ( -- bool )
  66     ?whitespace
  67     nextchar [char] ( = or
  68     nextchar [char] ) = or
  69 ;
  70
  71 : eatspaces
  72     begin
  73         ?whitespace
  74     while
  75             1 parse-idx +!
  76     repeat
  77 ;
  78
  79 : parsebool
  80
  81     nextchar emit cr
  82     trace
  83
  84     false
  85     nextchar [char] # <> if exit then
  86
  87     1 inc-parse-idx
  88
  89     nextchar dup [char] t = swap [char] f = or
  90     not if
  91         1 dec-parse-idx
  92         exit
  93     then
  94
  95     1 inc-parse-idx
  96
  97     ?delim not if
  98         2 dec-parse-idx
  99         exit
 100     then
 101 ;
 102
 103 : parsetoken
 104
 105     eatspaces
 106
 107     \ Parens
 108
 109     nextchar [char] ( = if
 110         \ todo
 111         exit
 112     then
 113
 114     nextchar [char] ) = if
 115         \ todo
 116         exit
 117     then
 118
 119     parsebool if
 120         exit
 121     exit
 122 ;
 123
 124 \ Parse a counted string into a scheme expression
 125 : parseexp ( straddr n -- exp )
 126     0 parse-idx !
 127
 128     begin
 129         parsetoken
 130     nextchar 0 =
 131     until
 132 ;
 133
 134 \ ---- REPL ----
 135
 136 : escape 27 emit [char] [ emit ;
 137 : escape-end [char] m emit ;
 138
 139 : set-term-colour
 140     escape [char] 3 emit [char] 0 + emit escape-end
 141 ;
 142
 143 : reset-term
 144     escape [char] 0 escape-end
 145 ;
 146
 147 : colour
 148     create ,
 149 does>
 150     @ set-term-colour
 151 ;
 152
 153 1 colour red
 154 2 colour green
 155 3 colour yellow
 156 4 colour blue
 157 5 colour magenta
 158 6 colour cyan
 159 7 colour white
 160
 161 create repl-buffer 161 allot
 162
 163 : repl
 164     repl-buffer parse-str !
 165
 166     cr
 167
 168     begin
 169         green ." => " white
 170
 171         repl-buffer 1+ 160 expect cr
 172         span @ repl-buffer !
 173
 174         parseexp
 175         \ eval
 176     again
 177 ;
 178
 179 forth definitions