Commit | Line | Data |
---|---|---|
1d117aaf VS |
1 | (import (scheme base)) |
2 | (import (scheme write)) | |
3 | (import (scheme process-context)) | |
4 | ||
5 | (import (lib util)) | |
6 | (import (lib reader)) | |
7 | (import (lib printer)) | |
8 | (import (lib types)) | |
9 | (import (lib env)) | |
10 | (import (lib core)) | |
11 | ||
12 | (define (READ input) | |
13 | (read-str input)) | |
14 | ||
15 | (define (eval-ast ast env) | |
16 | (let ((type (and (mal-object? ast) (mal-type ast))) | |
17 | (value (and (mal-object? ast) (mal-value ast)))) | |
18 | (case type | |
19 | ((symbol) (env-get env value)) | |
20 | ((list) (mal-list (map (lambda (item) (EVAL item env)) value))) | |
21 | ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value))) | |
22 | ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value))) | |
23 | (else ast)))) | |
24 | ||
25 | (define (is-pair? ast) | |
26 | (let ((type (and (mal-object? ast) (mal-type ast)))) | |
27 | (if (memq type '(list vector)) | |
28 | (pair? (->list (mal-value ast))) | |
29 | #f))) | |
30 | ||
31 | (define (QUASIQUOTE ast) | |
32 | (if (not (is-pair? ast)) | |
33 | (mal-list (list (mal-symbol 'quote) ast)) | |
34 | (let* ((items (->list (mal-value ast))) | |
35 | (a0 (car items))) | |
36 | (if (and (mal-object? a0) | |
37 | (eq? (mal-type a0) 'symbol) | |
38 | (eq? (mal-value a0) 'unquote)) | |
39 | (cadr items) | |
40 | (if (and (is-pair? a0) | |
41 | (mal-object? (car (mal-value a0))) | |
42 | (eq? (mal-type (car (mal-value a0))) 'symbol) | |
43 | (eq? (mal-value (car (mal-value a0))) 'splice-unquote)) | |
44 | (mal-list (list (mal-symbol 'concat) | |
45 | (cadr (mal-value a0)) | |
46 | (QUASIQUOTE (mal-list (cdr items))))) | |
47 | (mal-list (list (mal-symbol 'cons) | |
48 | (QUASIQUOTE a0) | |
49 | (QUASIQUOTE (mal-list (cdr items)))))))))) | |
50 | ||
51 | (define (is-macro-call? ast env) | |
52 | (if (mal-instance-of? ast 'list) | |
53 | (let ((op (car-safe (mal-value ast)))) | |
54 | (if (mal-instance-of? op 'symbol) | |
84dee477 VS |
55 | (let ((x (env-find env (mal-value op)))) |
56 | (if x | |
57 | (if (and (func? x) (func-macro? x)) | |
58 | #t | |
59 | #f) | |
1d117aaf VS |
60 | #f)) |
61 | #f)) | |
62 | #f)) | |
63 | ||
64 | (define (macroexpand ast env) | |
65 | (let loop ((ast ast)) | |
66 | (if (is-macro-call? ast env) | |
67 | (let* ((items (mal-value ast)) | |
68 | (op (car items)) | |
69 | (ops (cdr items)) | |
70 | (fn (func-fn (env-get env (mal-value op))))) | |
71 | (loop (apply fn ops))) | |
72 | ast))) | |
73 | ||
74 | (define (EVAL ast env) | |
75 | (define (handle-catch value handler) | |
76 | (let* ((symbol (mal-value (cadr handler))) | |
77 | (form (list-ref handler 2)) | |
78 | (env* (make-env env (list symbol) (list value)))) | |
79 | (EVAL form env*))) | |
80 | (let ((type (and (mal-object? ast) (mal-type ast)))) | |
81 | (if (not (eq? type 'list)) | |
82 | (eval-ast ast env) | |
83 | (if (null? (mal-value ast)) | |
84 | ast | |
85 | (let* ((ast (macroexpand ast env)) | |
86 | (items (mal-value ast))) | |
87 | (if (not (mal-instance-of? ast 'list)) | |
88 | (eval-ast ast env) | |
89 | (let ((a0 (car items))) | |
90 | (case (and (mal-object? a0) (mal-value a0)) | |
91 | ((def!) | |
92 | (let ((symbol (mal-value (cadr items))) | |
93 | (value (EVAL (list-ref items 2) env))) | |
94 | (env-set env symbol value) | |
95 | value)) | |
96 | ((defmacro!) | |
97 | (let ((symbol (mal-value (cadr items))) | |
98 | (value (EVAL (list-ref items 2) env))) | |
99 | (when (func? value) | |
100 | (func-macro?-set! value #t)) | |
101 | (env-set env symbol value) | |
102 | value)) | |
103 | ((macroexpand) | |
104 | (macroexpand (cadr items) env)) | |
105 | ((try*) | |
dd7a4f55 JM |
106 | (if (< (length items) 3) |
107 | (EVAL (cadr items) env) | |
108 | (let* ((form (cadr items)) | |
109 | (handler (mal-value (list-ref items 2)))) | |
110 | (guard | |
111 | (ex ((error-object? ex) | |
112 | (handle-catch | |
113 | (mal-string (error-object-message ex)) | |
114 | handler)) | |
115 | ((and (pair? ex) (eq? (car ex) 'user-error)) | |
116 | (handle-catch (cdr ex) handler))) | |
117 | (EVAL form env))))) | |
1d117aaf VS |
118 | ((let*) |
119 | (let ((env* (make-env env)) | |
120 | (binds (->list (mal-value (cadr items)))) | |
121 | (form (list-ref items 2))) | |
122 | (let loop ((binds binds)) | |
123 | (when (pair? binds) | |
124 | (let ((key (mal-value (car binds)))) | |
125 | (when (null? (cdr binds)) | |
126 | (error "unbalanced list")) | |
127 | (let ((value (EVAL (cadr binds) env*))) | |
128 | (env-set env* key value) | |
129 | (loop (cddr binds)))))) | |
130 | (EVAL form env*))) ; TCO | |
131 | ((do) | |
132 | (let ((forms (cdr items))) | |
133 | (if (null? forms) | |
134 | mal-nil | |
135 | ;; the evaluation order of map is unspecified | |
136 | (let loop ((forms forms)) | |
137 | (let ((form (car forms)) | |
138 | (tail (cdr forms))) | |
139 | (if (null? tail) | |
140 | (EVAL form env) ; TCO | |
141 | (begin | |
142 | (EVAL form env) | |
143 | (loop tail)))))))) | |
144 | ((if) | |
145 | (let* ((condition (EVAL (cadr items) env)) | |
146 | (type (and (mal-object? condition) | |
147 | (mal-type condition)))) | |
148 | (if (memq type '(false nil)) | |
149 | (if (< (length items) 4) | |
150 | mal-nil | |
151 | (EVAL (list-ref items 3) env)) ; TCO | |
152 | (EVAL (list-ref items 2) env)))) ; TCO | |
153 | ((quote) | |
154 | (cadr items)) | |
155 | ((quasiquote) | |
156 | (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO | |
157 | ((fn*) | |
158 | (let* ((binds (->list (mal-value (cadr items)))) | |
159 | (binds (map mal-value binds)) | |
160 | (body (list-ref items 2)) | |
161 | (fn (lambda args | |
162 | (let ((env* (make-env env binds args))) | |
163 | (EVAL body env*))))) | |
164 | (make-func body binds env fn))) | |
165 | (else | |
166 | (let* ((items (mal-value (eval-ast ast env))) | |
167 | (op (car items)) | |
168 | (ops (cdr items))) | |
169 | (if (func? op) | |
170 | (let* ((outer (func-env op)) | |
171 | (binds (func-params op)) | |
172 | (env* (make-env outer binds ops))) | |
173 | (EVAL (func-ast op) env*)) ; TCO | |
174 | (apply op ops)))))))))))) | |
175 | ||
176 | (define (PRINT ast) | |
177 | (pr-str ast #t)) | |
178 | ||
179 | (define repl-env (make-env #f)) | |
180 | (for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns) | |
181 | ||
182 | (define (rep input) | |
183 | (PRINT (EVAL (READ input) repl-env))) | |
184 | ||
e0704a2b | 185 | (define args (cdr (command-line))) |
1d117aaf VS |
186 | |
187 | (env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env))) | |
e0704a2b | 188 | (env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args)))) |
1d117aaf VS |
189 | |
190 | (rep "(def! not (fn* (a) (if a false true)))") | |
191 | (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))") | |
192 | ||
193 | (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)))))))") | |
194 | (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))))))))") | |
195 | ||
196 | ||
1d117aaf VS |
197 | (define (main) |
198 | (let loop () | |
199 | (let ((input (readline "user> "))) | |
200 | (when input | |
201 | (guard | |
202 | (ex ((error-object? ex) | |
203 | (when (not (memv 'empty-input (error-object-irritants ex))) | |
204 | (display "[error] ") | |
205 | (display (error-object-message ex)) | |
dd7a4f55 JM |
206 | (newline))) |
207 | ((and (pair? ex) (eq? (car ex) 'user-error)) | |
208 | (display "[error] ") | |
209 | (display (pr-str (cdr ex) #t)) | |
210 | (newline))) | |
1d117aaf VS |
211 | (display (rep input)) |
212 | (newline)) | |
213 | (loop)))) | |
214 | (newline)) | |
215 | ||
e0704a2b | 216 | (if (null? args) |
1d117aaf | 217 | (main) |
e0704a2b | 218 | (rep (string-append "(load-file \"" (car args) "\")"))) |