forked from kanaka/mal
-
Notifications
You must be signed in to change notification settings - Fork 0
/
step9_try.el
251 lines (228 loc) · 8.4 KB
/
step9_try.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
;; -*- lexical-binding: t; -*-
(defun load-relative (file)
(let* ((current-file (or load-file-name buffer-file-name))
(current-file-directory (file-name-directory current-file)))
(load (expand-file-name file current-file-directory) nil t)))
(load-relative "types.el")
(load-relative "env.el")
(load-relative "func.el")
(load-relative "reader.el")
(load-relative "printer.el")
(load-relative "core.el")
(defvar repl-env (mal-env))
(dolist (binding core-ns)
(let ((symbol (car binding))
(fn (cdr binding)))
(mal-env-set repl-env symbol fn)))
(defun mal-pair-p (mal-object)
(let ((type (mal-type mal-object))
(value (mal-value mal-object)))
(if (and (or (eq type 'list) (eq type 'vector))
(not (zerop (length value))))
t
nil)))
(defun quasiquote (ast)
(if (not (mal-pair-p ast))
(mal-list (list (mal-symbol 'quote) ast))
(let* ((a (mal-listify ast))
(a0 (car a))
(a0... (cdr a))
(a1 (cadr a)))
(cond
((eq (mal-value a0) 'unquote)
a1)
((and (mal-pair-p a0)
(eq (mal-value (car (mal-value a0)))
'splice-unquote))
(mal-list (list (mal-symbol 'concat)
(cadr (mal-value a0))
(quasiquote (mal-list a0...)))))
(t
(mal-list (list (mal-symbol 'cons)
(quasiquote a0)
(quasiquote (mal-list a0...)))))))))
(defun macro-call-p (ast env)
(when (mal-list-p ast)
(let ((a0 (car (mal-value ast))))
(when (mal-symbol-p a0)
(let ((value (mal-env-find env (mal-value a0))))
(when (and (mal-func-p value)
(mal-func-macro-p value))
t))))))
(defun MACROEXPAND (ast env)
(while (macro-call-p ast env)
(let* ((a (mal-value ast))
(a0* (mal-value (car a)))
(a0... (cdr a))
(macro (mal-env-find env a0*)))
(setq ast (apply (mal-value (mal-func-fn macro)) a0...))))
ast)
(defun READ (input)
(read-str input))
(defun EVAL (ast env)
(catch 'return
(while t
(when (not (mal-list-p ast))
(throw 'return (eval-ast ast env)))
(setq ast (MACROEXPAND ast env))
(when (or (not (mal-list-p ast)) (not (mal-value ast)))
(throw 'return (eval-ast ast env)))
(let* ((a (mal-value ast))
(a0 (car a))
(a0* (mal-value a0))
(a1 (cadr a))
(a2 (nth 2 a))
(a3 (nth 3 a)))
(cond
((eq a0* 'def!)
(let* ((identifier (mal-value a1))
(value (EVAL a2 env)))
(throw 'return (mal-env-set env identifier value))))
((eq a0* 'let*)
(let* ((env* (mal-env env))
(bindings (mal-value a1))
(form a2))
(when (vectorp bindings)
(setq bindings (append bindings nil)))
(while bindings
(let ((key (mal-value (pop bindings)))
(value (EVAL (pop bindings) env*)))
(mal-env-set env* key value)))
(setq env env*
ast form))) ; TCO
((eq a0* 'quote)
(throw 'return a1))
((eq a0* 'quasiquote)
(setq ast (quasiquote a1))) ; TCO
((eq a0* 'defmacro!)
(let ((identifier (mal-value a1))
(value (EVAL a2 env)))
(setf (aref (aref value 1) 4) t)
(throw 'return (mal-env-set env identifier value))))
((eq a0* 'macroexpand)
(throw 'return (MACROEXPAND a1 env)))
((eq a0* 'try*)
(condition-case err
(throw 'return (EVAL a1 env))
(error
(if (and a2 (eq (mal-value (car (mal-value a2))) 'catch*))
(let* ((a2* (mal-value a2))
(identifier (mal-value (cadr a2*)))
(form (nth 2 a2*))
(err* (if (eq (car err) 'mal-custom)
;; throw
(cadr err)
;; normal error
(mal-string (error-message-string err))))
(env* (mal-env env (list identifier) (list err*))))
(throw 'return (EVAL form env*)))
(apply 'signal err)))))
((eq a0* 'do)
(let* ((a0... (cdr a))
(butlast (butlast a0...))
(last (car (last a0...))))
(when butlast
(eval-ast (mal-list butlast) env))
(setq ast last))) ; TCO
((eq a0* 'if)
(let* ((condition (EVAL a1 env))
(condition-type (mal-type condition))
(then a2)
(else a3))
(if (and (not (eq condition-type 'false))
(not (eq condition-type 'nil)))
(setq ast then) ; TCO
(if else
(setq ast else) ; TCO
(throw 'return (mal-nil))))))
((eq a0* 'fn*)
(let* ((binds (mapcar 'mal-value (mal-value a1)))
(body a2)
(fn (mal-fn
(lambda (&rest args)
(let ((env* (mal-env env binds args)))
(EVAL body env*))))))
(throw 'return (mal-func body binds env fn))))
(t
;; not a special form
(let* ((ast* (mal-value (eval-ast ast env)))
(fn (car ast*))
(args (cdr ast*)))
(if (mal-func-p fn)
(let ((env* (mal-env (mal-func-env fn)
(mal-func-params fn)
args)))
(setq env env*
ast (mal-func-ast fn))) ; TCO
;; built-in function
(let ((fn* (mal-value fn)))
(throw 'return (apply fn* args)))))))))))
(defun eval-ast (ast env)
(let ((type (mal-type ast))
(value (mal-value ast)))
(cond
((eq type 'symbol)
(let ((definition (mal-env-get env value)))
(or definition (error "Definition not found"))))
((eq type 'list)
(mal-list (mapcar (lambda (item) (EVAL item env)) value)))
((eq type 'vector)
(mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value))))
((eq type 'map)
(let ((map (copy-hash-table value)))
(maphash (lambda (key value)
(puthash key (EVAL value env) map))
map)
(mal-map map)))
(t
;; return as is
ast))))
(mal-env-set repl-env 'eval (mal-fn (let ((env repl-env)) (lambda (form) (EVAL form env)))))
(mal-env-set repl-env '*ARGV* (mal-list (mapcar 'mal-string (cdr argv))))
(defun PRINT (input)
(pr-str input t))
(defun rep (input)
(PRINT (EVAL (READ input) repl-env)))
(rep "(def! not (fn* (a) (if a false true)))")
(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
(rep "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))")
(rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))")
(defun readln (prompt)
;; C-d throws an error
(ignore-errors (read-from-minibuffer prompt)))
(defun println (format-string &rest args)
(if (not args)
(princ format-string)
(princ (apply 'format format-string args)))
(terpri))
(defmacro with-error-handling (&rest body)
`(condition-case err
(progn ,@body)
(end-of-token-stream
;; empty input, carry on
)
(unterminated-sequence
(let* ((type (cadr err))
(end
(cond
((eq type 'string) ?\")
((eq type 'list) ?\))
((eq type 'vector) ?\])
((eq type 'map) ?}))))
(princ (format "Expected '%c', got EOF\n" end))))
(error ; catch-all
(println (error-message-string err)))))
(defun main ()
(if argv
(with-error-handling
(rep (format "(load-file \"%s\")" (car argv))))
(let (eof)
(while (not eof)
(let ((input (readln "user> ")))
(if input
(with-error-handling
(println (rep input)))
(setq eof t)
;; print final newline
(terpri)))))))
(main)