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