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 : stack
  23     create here 1+ , allot ;
  24
  25
  26 : push ( st v -- )
  27     over @ !
  28     1 swap +!
  29 ;
  30
  31 : pop ( st -- v )
  32     dup @       ( s0 sp )
  33     1-          ( so sp' )
  34
  35     2dup = abort" Stack underflow."
  36
  37     dup @       ( s0 sp' v )
  38     -rot swap   ( v sp' s0 )
  39     !
  40 ;
  41
  42 100 stack parse-stack
  43 variable parse-idx
  44 variable parse-str
  45
  46
  47 : inc-parse-idx parse-idx +! ;
  48 : dec-parse-idx parse-idx -! ;
  49
  50 : ?charavailable ( -- bool )
  51     parse-str @ @ parse-idx @ >
  52 ;
  53
  54 : nextchar ( -- char )
  55     ?charavailable if
  56         parse-str @ 1+ parse-idx @ + @
  57     else
  58         0
  59     then
  60 ;
  61
  62 : ?whitespace ( -- bool )
  63     nextchar BL =
  64     nextchar '\n' = or
  65 ;
  66
  67 : ?delim ( -- bool )
  68     ?whitespace
  69     nextchar [char] ( = or
  70     nextchar [char] ) = or
  71 ;
  72
  73 : eatspaces
  74     begin
  75         ?whitespace
  76     while
  77             1 parse-idx +!
  78     repeat
  79 ;
  80
  81 : parsebool
  82
  83     nextchar emit cr
  84     trace
  85
  86     false
  87     nextchar [char] # <> if exit then
  88
  89     1 inc-parse-idx
  90
  91     nextchar dup [char] t = swap [char] f = or
  92     not if
  93         1 dec-parse-idx
  94         exit
  95     then
  96
  97     1 inc-parse-idx
  98
  99     ?delim not if
 100         2 dec-parse-idx
 101         exit
 102     then
 103 ;
 104
 105 : parsetoken
 106
 107     eatspaces
 108
 109     \ Parens
 110
 111     nextchar [char] ( = if
 112         \ todo
 113         exit
 114     then
 115
 116     nextchar [char] ) = if
 117         \ todo
 118         exit
 119     then
 120
 121     parsebool if
 122         exit
 123     exit
 124 ;
 125
 126 \ Parse a counted string into a scheme expression
 127 : parseexp ( straddr n -- exp )
 128     0 parse-idx !
 129
 130     begin
 131         parsetoken
 132     nextchar 0 =
 133     until
 134 ;
 135
 136 \ ---- REPL ----
 137
 138 create repl-buffer 161 allot
 139
 140 : repl
 141     repl-buffer parse-str !
 142
 143     cr
 144
 145     begin
 146         bold fg green ." => " reset-term
 147
 148         repl-buffer 1+ 160 expect cr
 149         span @ repl-buffer !
 150
 151         parseexp
 152         \ eval
 153     again
 154 ;
 155
 156 forth definitions