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 (starts-with? ast sym)
26 (let ((items (mal-value ast)))
27 (and (not (null? items))
28 (let ((a0 (car items)))
29 (and (mal-instance-of? a0 'symbol)
30 (eq? (mal-value a0) sym))))))
36 (acc (qq-lst (cdr xs))))
37 (if (and (mal-instance-of? elt 'list) (starts-with? elt 'splice-unquote))
38 (mal-list (list (mal-symbol 'concat) (cadr (mal-value elt)) acc))
39 (mal-list (list (mal-symbol 'cons) (QUASIQUOTE elt) acc))))))
41 (define (QUASIQUOTE ast)
42 (case (and (mal-object? ast) (mal-type ast))
43 ((list) (if (starts-with? ast 'unquote)
44 (cadr (mal-value ast))
45 (qq-lst (->list (mal-value ast)))))
46 ((vector) (mal-list (list (mal-symbol 'vec) (qq-lst (->list (mal-value ast))))))
47 ((map symbol) (mal-list (list (mal-symbol 'quote) ast)))
50 (define (EVAL ast env)
51 (let ((type (and (mal-object? ast) (mal-type ast))))
52 (if (not (eq? type 'list))
54 (let ((items (mal-value ast)))
57 (let ((a0 (car items)))
58 (case (and (mal-object? a0) (mal-value a0))
60 (let ((symbol (mal-value (cadr items)))
61 (value (EVAL (list-ref items 2) env)))
62 (env-set env symbol value)
65 (let ((env* (make-env env))
66 (binds (->list (mal-value (cadr items))))
67 (form (list-ref items 2)))
68 (let loop ((binds binds))
70 (let ((key (mal-value (car binds))))
71 (when (null? (cdr binds))
72 (error "unbalanced list"))
73 (let ((value (EVAL (cadr binds) env*)))
74 (env-set env* key value)
75 (loop (cddr binds))))))
76 (EVAL form env*))) ; TCO
78 (let ((forms (cdr items)))
81 ;; the evaluation order of map is unspecified
82 (let loop ((forms forms))
83 (let ((form (car forms))
91 (let* ((condition (EVAL (cadr items) env))
92 (type (and (mal-object? condition)
93 (mal-type condition))))
94 (if (memq type '(false nil))
95 (if (< (length items) 4)
97 (EVAL (list-ref items 3) env)) ; TCO
98 (EVAL (list-ref items 2) env)))) ; TCO
99 ((quote) (cadr items))
100 ((quasiquoteexpand) (QUASIQUOTE (cadr items)))
101 ((quasiquote) (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO
103 (let* ((binds (->list (mal-value (cadr items))))
104 (binds (map mal-value binds))
105 (body (list-ref items 2))
107 (let ((env* (make-env env binds args)))
109 (make-func body binds env fn)))
111 (let* ((items (mal-value (eval-ast ast env)))
115 (let* ((outer (func-env op))
116 (binds (func-params op))
117 (env* (make-env outer binds ops)))
118 (EVAL (func-ast op) env*)) ; TCO
119 (apply op ops)))))))))))
124 (define repl-env (make-env #f))
125 (for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns)
128 (PRINT (EVAL (READ input) repl-env)))
130 (define args (cdr (command-line)))
132 (env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env)))
133 (env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args))))
135 (rep "(def! not (fn* (a) (if a false true)))")
136 (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))")
140 (let ((input (readline "user> ")))
143 (ex ((error-object? ex)
144 (when (not (memv 'empty-input (error-object-irritants ex)))
146 (display (error-object-message ex))
148 ((and (pair? ex) (eq? (car ex) 'user-error))
150 (display (pr-str (cdr ex) #t))
152 (display (rep input))
159 (rep (string-append "(load-file \"" (car args) "\")")))