Commit | Line | Data |
---|---|---|
d44f31c2 C |
1 | require reader.fs |
2 | require printer.fs | |
3 | require core.fs | |
4 | ||
5 | core MalEnv. constant repl-env | |
6 | ||
d44f31c2 C |
7 | 99999999 constant TCO-eval |
8 | ||
9 | : read read-str ; | |
10 | : eval ( env obj ) | |
11 | begin | |
45c1894b | 12 | \ ." eval-> " dup pr-str safe-type cr |
d44f31c2 C |
13 | mal-eval |
14 | dup TCO-eval = | |
15 | while | |
16 | drop | |
17 | repeat ; | |
18 | ||
19 | \ ." Type: " dup mal-type @ type-name safe-type cr | |
20 | pr-str ; | |
21 | ||
22 | MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself | |
23 | ||
24 | MalKeyword | |
45c1894b | 25 | extend eval-invoke { env list kw -- val } |
d44f31c2 C |
26 | 0 kw env list MalList/start @ cell+ @ eval get |
27 | ?dup 0= if | |
28 | \ compute not-found value | |
29 | list MalList/count @ 1 > if | |
30 | env list MalList/start @ 2 cells + @ TCO-eval | |
31 | else | |
32 | mal-nil | |
33 | endif | |
34 | endif ;; | |
35 | drop | |
36 | ||
45c1894b C |
37 | \ eval all but the first item of list |
38 | : eval-rest { env list -- argv argc } | |
d44f31c2 | 39 | list MalList/start @ cell+ { expr-start } |
45c1894b C |
40 | list MalList/count @ 1- { argc } |
41 | argc cells allocate throw { target } | |
42 | argc 0 ?do | |
43 | env expr-start i cells + @ eval | |
44 | target i cells + ! | |
d44f31c2 | 45 | loop |
45c1894b | 46 | target argc ; |
d44f31c2 C |
47 | |
48 | MalNativeFn | |
45c1894b | 49 | extend eval-invoke ( env list this -- list ) |
d44f31c2 | 50 | MalNativeFn/xt @ { xt } |
45c1894b C |
51 | eval-rest ( argv argc ) |
52 | xt execute ( return-val ) ;; | |
d44f31c2 C |
53 | drop |
54 | ||
55 | SpecialOp | |
45c1894b | 56 | extend eval-invoke ( env list this -- list ) |
d44f31c2 C |
57 | SpecialOp/xt @ execute ;; |
58 | drop | |
59 | ||
60 | : install-special ( symbol xt ) | |
61 | SpecialOp. repl-env env/set ; | |
62 | ||
63 | : defspecial | |
64 | parse-allot-name MalSymbol. | |
65 | ['] install-special | |
66 | :noname | |
67 | ; | |
68 | ||
69 | defspecial quote ( env list -- form ) | |
70 | nip MalList/start @ cell+ @ ;; | |
71 | ||
72 | defspecial def! { env list -- val } | |
73 | list MalList/start @ cell+ { arg0 } | |
74 | arg0 @ ( key ) | |
75 | env arg0 cell+ @ eval dup { val } ( key val ) | |
45c1894b | 76 | env env/set val ;; |
d44f31c2 C |
77 | |
78 | defspecial let* { old-env list -- val } | |
79 | old-env MalEnv. { env } | |
80 | list MalList/start @ cell+ dup { arg0 } | |
81 | @ to-list | |
82 | dup MalList/start @ { bindings-start } ( list ) | |
83 | MalList/count @ 0 +do | |
84 | bindings-start i cells + dup @ swap cell+ @ ( sym expr ) | |
85 | env swap eval | |
86 | env env/set | |
87 | 2 +loop | |
88 | env arg0 cell+ @ TCO-eval | |
89 | \ TODO: dec refcount of env | |
90 | ;; | |
91 | ||
92 | defspecial do { env list -- val } | |
93 | list MalList/start @ { start } | |
94 | list MalList/count @ dup 1- { last } 1 ?do | |
95 | env start i cells + @ | |
96 | i last = if | |
97 | TCO-eval | |
98 | else | |
99 | eval drop | |
100 | endif | |
101 | loop ;; | |
102 | ||
103 | defspecial if { env list -- val } | |
104 | list MalList/start @ cell+ { arg0 } | |
105 | env arg0 @ eval ( test-val ) | |
106 | dup mal-false = if | |
107 | drop -1 | |
108 | else | |
109 | mal-nil = | |
110 | endif | |
111 | if | |
112 | \ branch to false | |
113 | list MalList/count @ 3 > if | |
114 | env arg0 cell+ cell+ @ TCO-eval | |
115 | else | |
116 | mal-nil | |
117 | endif | |
118 | else | |
119 | \ branch to true | |
120 | env arg0 cell+ @ TCO-eval | |
121 | endif ;; | |
122 | ||
123 | s" &" MalSymbol. constant &-sym | |
124 | ||
125 | MalUserFn | |
45c1894b C |
126 | extend eval-invoke { call-env list mal-fn -- list } |
127 | call-env list eval-rest { argv argc } | |
d44f31c2 C |
128 | |
129 | mal-fn MalUserFn/formal-args @ { f-args-list } | |
130 | mal-fn MalUserFn/env @ MalEnv. { env } | |
131 | ||
132 | f-args-list MalList/start @ { f-args } | |
133 | f-args-list MalList/count @ ?dup 0= if else | |
134 | \ pass nil for last arg, unless overridden below | |
135 | 1- cells f-args + @ mal-nil env env/set | |
136 | endif | |
137 | argc 0 ?do | |
138 | f-args i cells + @ | |
139 | dup &-sym m= if | |
140 | drop | |
141 | f-args i 1+ cells + @ ( more-args-symbol ) | |
142 | MalList new ( sym more-args ) | |
143 | argc i - dup { c } over MalList/count ! | |
144 | c cells allocate throw dup { start } over MalList/start ! | |
145 | argv i cells + start c cells cmove | |
146 | env env/set | |
147 | leave | |
148 | endif | |
149 | argv i cells + @ | |
150 | env env/set | |
151 | loop | |
152 | ||
45c1894b C |
153 | env mal-fn MalUserFn/body @ TCO-eval ;; |
154 | drop | |
d44f31c2 C |
155 | |
156 | defspecial fn* { env list -- val } | |
157 | list MalList/start @ cell+ { arg0 } | |
158 | MalUserFn new | |
159 | env over MalUserFn/env ! | |
160 | arg0 @ to-list over MalUserFn/formal-args ! | |
161 | arg0 cell+ @ over MalUserFn/body ! ;; | |
162 | ||
163 | MalSymbol | |
164 | extend mal-eval { env sym -- val } | |
a631063f | 165 | sym env env/get-addr |
d44f31c2 C |
166 | dup 0= if |
167 | drop | |
a631063f | 168 | ." Symbol '" sym pr-str safe-type ." ' not found." cr |
d44f31c2 | 169 | 1 throw |
a631063f C |
170 | else |
171 | @ | |
d44f31c2 C |
172 | endif ;; |
173 | drop | |
174 | ||
175 | : eval-ast { env list -- list } | |
176 | here | |
177 | list MalList/start @ { expr-start } | |
178 | list MalList/count @ 0 ?do | |
179 | env expr-start i cells + @ eval , | |
180 | loop | |
181 | here>MalList ; | |
182 | ||
183 | MalList | |
184 | extend mal-eval { env list -- val } | |
185 | env list MalList/start @ @ eval | |
45c1894b | 186 | env list rot eval-invoke ;; |
d44f31c2 C |
187 | drop |
188 | ||
189 | MalVector | |
190 | extend mal-eval ( env vector -- vector ) | |
191 | MalVector/list @ eval-ast | |
192 | MalVector new swap over MalVector/list ! ;; | |
193 | drop | |
194 | ||
195 | MalMap | |
196 | extend mal-eval ( env map -- map ) | |
197 | MalMap/list @ eval-ast | |
198 | MalMap new swap over MalMap/list ! ;; | |
199 | drop | |
200 | ||
45c1894b | 201 | : rep ( str-addr str-len -- str-addr str-len ) |
d44f31c2 C |
202 | read |
203 | repl-env swap eval | |
204 | print ; | |
205 | ||
206 | create buff 128 allot | |
207 | 77777777777 constant stack-leak-detect | |
208 | ||
209 | : read-lines | |
210 | begin | |
211 | ." user> " | |
212 | stack-leak-detect | |
213 | buff 128 stdin read-line throw | |
45c1894b C |
214 | while ( num-bytes-read ) |
215 | buff swap ( str-addr str-len ) | |
d44f31c2 C |
216 | ['] rep |
217 | \ execute safe-type | |
218 | catch ?dup 0= if safe-type else ." Caught error " . endif | |
219 | cr | |
220 | stack-leak-detect <> if ." --stack leak--" cr endif | |
221 | repeat ; | |
222 | ||
223 | read-lines | |
224 | cr | |
225 | bye |