scheme.4th

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