Commit | Line | Data |
---|---|---|
0da79691 VS |
1 | ;; -*- lexical-binding: t; -*- |
2 | ||
b5df0de6 | 3 | (setq debug-on-error t) |
c2b12e5b VS |
4 | (require 'mal/types) |
5 | (require 'mal/func) | |
6 | (require 'mal/env) | |
7 | (require 'mal/reader) | |
8 | (require 'mal/printer) | |
9 | (require 'mal/core) | |
0da79691 VS |
10 | |
11 | (defvar repl-env (mal-env)) | |
12 | ||
13 | (dolist (binding core-ns) | |
14 | (let ((symbol (car binding)) | |
15 | (fn (cdr binding))) | |
16 | (mal-env-set repl-env symbol fn))) | |
17 | ||
18 | (defun READ (input) | |
19 | (read-str input)) | |
20 | ||
21 | (defun EVAL (ast env) | |
22 | (catch 'return | |
23 | (while t | |
ecb8de2d | 24 | (if (and (mal-list-p ast) (mal-value ast)) |
0da79691 VS |
25 | (let* ((a (mal-value ast)) |
26 | (a0 (car a)) | |
27 | (a0* (mal-value a0)) | |
28 | (a1 (cadr a)) | |
29 | (a2 (nth 2 a)) | |
30 | (a3 (nth 3 a))) | |
31 | (cond | |
32 | ((eq a0* 'def!) | |
33 | (let ((identifier (mal-value a1)) | |
34 | (value (EVAL a2 env))) | |
35 | (throw 'return (mal-env-set env identifier value)))) | |
36 | ((eq a0* 'let*) | |
37 | (let* ((env* (mal-env env)) | |
38 | (bindings (mal-value a1)) | |
39 | (form a2)) | |
40 | (when (vectorp bindings) | |
41 | (setq bindings (append bindings nil))) | |
42 | (while bindings | |
43 | (let ((key (mal-value (pop bindings))) | |
44 | (value (EVAL (pop bindings) env*))) | |
45 | (mal-env-set env* key value))) | |
46 | (setq env env* | |
47 | ast form))) ; TCO | |
48 | ((eq a0* 'do) | |
49 | (let* ((a0... (cdr a)) | |
50 | (butlast (butlast a0...)) | |
51 | (last (car (last a0...)))) | |
52 | (when butlast | |
53 | (eval-ast (mal-list butlast) env)) | |
54 | (setq ast last))) ; TCO | |
55 | ((eq a0* 'if) | |
56 | (let* ((condition (EVAL a1 env)) | |
57 | (condition-type (mal-type condition)) | |
58 | (then a2) | |
59 | (else a3)) | |
60 | (if (and (not (eq condition-type 'false)) | |
61 | (not (eq condition-type 'nil))) | |
62 | (setq ast then) ; TCO | |
63 | (if else | |
64 | (setq ast else) ; TCO | |
c347c874 | 65 | (throw 'return mal-nil))))) |
0da79691 VS |
66 | ((eq a0* 'fn*) |
67 | (let* ((binds (mapcar 'mal-value (mal-value a1))) | |
68 | (body a2) | |
69 | (fn (mal-fn | |
70 | (lambda (&rest args) | |
71 | (let ((env* (mal-env env binds args))) | |
72 | (EVAL body env*)))))) | |
73 | (throw 'return (mal-func body binds env fn)))) | |
74 | (t | |
75 | ;; not a special form | |
76 | (let* ((ast* (mal-value (eval-ast ast env))) | |
77 | (fn (car ast*)) | |
78 | (args (cdr ast*))) | |
79 | (if (mal-func-p fn) | |
80 | (let ((env* (mal-env (mal-func-env fn) | |
81 | (mal-func-params fn) | |
82 | args))) | |
83 | (setq env env* | |
84 | ast (mal-func-ast fn))) ; TCO | |
85 | (let ((fn* (if (mal-fn-p fn) | |
86 | ;; unbox user-defined function | |
87 | (mal-value fn) | |
88 | ;; use built-in function | |
89 | fn))) | |
90 | (throw 'return (apply fn* args)))))))) | |
91 | (throw 'return (eval-ast ast env)))))) | |
92 | ||
93 | (defun eval-ast (ast env) | |
94 | (let ((type (mal-type ast)) | |
95 | (value (mal-value ast))) | |
96 | (cond | |
97 | ((eq type 'symbol) | |
98 | (let ((definition (mal-env-get env value))) | |
99 | (or definition (error "Definition not found")))) | |
100 | ((eq type 'list) | |
101 | (mal-list (mapcar (lambda (item) (EVAL item env)) value))) | |
102 | ((eq type 'vector) | |
103 | (mal-vector (vconcat (mapcar (lambda (item) (EVAL item env)) value)))) | |
104 | ((eq type 'map) | |
105 | (let ((map (copy-hash-table value))) | |
106 | (maphash (lambda (key value) | |
107 | (puthash key (EVAL value env) map)) | |
108 | map) | |
109 | (mal-map map))) | |
110 | (t | |
111 | ;; return as is | |
112 | ast)))) | |
113 | ||
114 | (defun PRINT (input) | |
115 | (pr-str input t)) | |
116 | ||
117 | (defun rep (input) | |
118 | (PRINT (EVAL (READ input) repl-env))) | |
119 | ||
120 | (rep "(def! not (fn* (a) (if a false true)))") | |
121 | ||
122 | (defun readln (prompt) | |
123 | ;; C-d throws an error | |
124 | (ignore-errors (read-from-minibuffer prompt))) | |
125 | ||
126 | (defun println (format-string &rest args) | |
127 | (if (not args) | |
128 | (princ format-string) | |
129 | (princ (apply 'format format-string args))) | |
130 | (terpri)) | |
131 | ||
132 | (defun main () | |
133 | (let (eof) | |
134 | (while (not eof) | |
135 | (let ((input (readln "user> "))) | |
136 | (if input | |
137 | (condition-case err | |
138 | (println (rep input)) | |
139 | (end-of-token-stream | |
140 | ;; empty input, carry on | |
141 | ) | |
142 | (unterminated-sequence | |
143 | (let* ((type (cadr err)) | |
144 | (end | |
145 | (cond | |
146 | ((eq type 'string) ?\") | |
147 | ((eq type 'list) ?\)) | |
148 | ((eq type 'vector) ?\]) | |
149 | ((eq type 'map) ?})))) | |
150 | (princ (format "Expected '%c', got EOF\n" end)))) | |
151 | (error ; catch-all | |
152 | (println (error-message-string err)))) | |
153 | (setq eof t) | |
154 | ;; print final newline | |
155 | (terpri)))))) | |
156 | ||
157 | (main) |