2 (import (scheme write))
3 (import (scheme process-context))
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))))
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)))
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)))
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)))
36 (if (and (mal-object? a0)
37 (eq? (mal-type a0) 'symbol)
38 (eq? (mal-value a0) 'unquote))
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)
46 (QUASIQUOTE (mal-list (cdr items)))))
47 (mal-list (list (mal-symbol 'cons)
49 (QUASIQUOTE (mal-list (cdr items))))))))))
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)
55 (let ((x (env-find env (mal-value op))))
57 (if (and (func? x) (func-macro? x))
64 (define (macroexpand ast env)
66 (if (is-macro-call? ast env)
67 (let* ((items (mal-value ast))
70 (fn (func-fn (env-get env (mal-value op)))))
71 (loop (apply fn ops)))
74 (define (EVAL ast env)
75 (let ((type (and (mal-object? ast) (mal-type ast))))
76 (if (not (eq? type 'list))
78 (if (null? (mal-value ast))
80 (let* ((ast (macroexpand ast env))
81 (items (mal-value ast)))
82 (if (not (mal-instance-of? ast 'list))
84 (let ((a0 (car items)))
85 (case (and (mal-object? a0) (mal-value a0))
87 (let ((symbol (mal-value (cadr items)))
88 (value (EVAL (list-ref items 2) env)))
89 (env-set env symbol value)
92 (let ((symbol (mal-value (cadr items)))
93 (value (EVAL (list-ref items 2) env)))
95 (func-macro?-set! value #t))
96 (env-set env symbol value)
99 (macroexpand (cadr items) env))
101 (let ((env* (make-env env))
102 (binds (->list (mal-value (cadr items))))
103 (form (list-ref items 2)))
104 (let loop ((binds binds))
106 (let ((key (mal-value (car binds))))
107 (when (null? (cdr binds))
108 (error "unbalanced list"))
109 (let ((value (EVAL (cadr binds) env*)))
110 (env-set env* key value)
111 (loop (cddr binds))))))
112 (EVAL form env*))) ; TCO
114 (let ((forms (cdr items)))
117 ;; the evaluation order of map is unspecified
118 (let loop ((forms forms))
119 (let ((form (car forms))
122 (EVAL form env) ; TCO
127 (let* ((condition (EVAL (cadr items) env))
128 (type (and (mal-object? condition)
129 (mal-type condition))))
130 (if (memq type '(false nil))
131 (if (< (length items) 4)
133 (EVAL (list-ref items 3) env)) ; TCO
134 (EVAL (list-ref items 2) env)))) ; TCO
138 (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO
140 (let* ((binds (->list (mal-value (cadr items))))
141 (binds (map mal-value binds))
142 (body (list-ref items 2))
144 (let ((env* (make-env env binds args)))
146 (make-func body binds env fn)))
148 (let* ((items (mal-value (eval-ast ast env)))
152 (let* ((outer (func-env op))
153 (binds (func-params op))
154 (env* (make-env outer binds ops)))
155 (EVAL (func-ast op) env*)) ; TCO
156 (apply op ops))))))))))))
161 (define repl-env (make-env #f))
162 (for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns)
165 (PRINT (EVAL (READ input) repl-env)))
167 (define args (cdr (command-line)))
169 (env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env)))
170 (env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args))))
172 (rep "(def! not (fn* (a) (if a false true)))")
173 (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
175 (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)))))))")
176 (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))))))))")
181 (let ((input (readline "user> ")))
184 (ex ((error-object? ex)
185 (when (not (memv 'empty-input (error-object-irritants ex)))
187 (display (error-object-message ex))
189 ((and (pair? ex) (eq? (car ex) 'user-error))
191 (display (pr-str (cdr ex) #t))
193 (display (rep input))
200 (rep (string-append "(load-file \"" (car args) "\")")))