Commit | Line | Data |
---|---|---|
f5223195 JM |
1 | #!/usr/bin/env racket |
2 | #lang racket | |
3 | ||
4 | (require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt" | |
5 | "env.rkt" "core.rkt") | |
6 | ||
7 | ;; read | |
8 | (define (READ str) | |
9 | (read_str str)) | |
10 | ||
11 | ;; eval | |
fbfe6784 NB |
12 | |
13 | (define (qq-loop elt acc) | |
14 | (if (and (list? elt) (= (length elt) 2) (equal? (car elt) 'splice-unquote)) | |
15 | (list 'concat (cadr elt) acc) | |
16 | (list 'cons (quasiquote elt) acc))) | |
f5223195 JM |
17 | |
18 | (define (quasiquote ast) | |
19 | (cond | |
fbfe6784 | 20 | [(or (symbol? ast) (hash? ast)) |
f5223195 JM |
21 | (list 'quote ast)] |
22 | ||
fbfe6784 NB |
23 | [(vector? ast) |
24 | (list 'vec (foldr qq-loop null (_to_list ast)))] | |
25 | ||
26 | [(not (list? ast)) | |
27 | ast] | |
f5223195 | 28 | |
fbfe6784 NB |
29 | [(and (= (length ast) 2) (equal? (car ast) 'unquote)) |
30 | (cadr ast)] | |
f5223195 JM |
31 | |
32 | [else | |
fbfe6784 | 33 | (foldr qq-loop null ast)])) |
f5223195 JM |
34 | |
35 | (define (macro? ast env) | |
36 | (and (list? ast) | |
864fa9f8 | 37 | (not (empty? ast)) |
f5223195 JM |
38 | (symbol? (first ast)) |
39 | (not (equal? null (send env find (first ast)))) | |
40 | (let ([fn (send env get (first ast))]) | |
41 | (and (malfunc? fn) (malfunc-macro? fn))))) | |
42 | ||
43 | (define (macroexpand ast env) | |
44 | (if (macro? ast env) | |
45 | (let ([mac (malfunc-fn (send env get (first ast)))]) | |
46 | (macroexpand (apply mac (rest ast)) env)) | |
47 | ast)) | |
48 | ||
49 | (define (eval-ast ast env) | |
50 | (cond | |
51 | [(symbol? ast) (send env get ast)] | |
52 | [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)] | |
53 | [(hash? ast) (make-hash | |
54 | (dict-map ast (lambda (k v) (cons k (EVAL v env)))))] | |
55 | [else ast])) | |
56 | ||
57 | (define (EVAL ast env) | |
58 | ;(printf "~a~n" (pr_str ast true)) | |
59 | (if (not (list? ast)) | |
60 | (eval-ast ast env) | |
61 | ||
62 | (let ([ast (macroexpand ast env)]) | |
864fa9f8 | 63 | (if (or (not (list? ast)) (empty? ast)) |
0d629719 | 64 | (eval-ast ast env) |
f5223195 JM |
65 | (let ([a0 (_nth ast 0)]) |
66 | (cond | |
67 | [(eq? 'def! a0) | |
68 | (send env set (_nth ast 1) (EVAL (_nth ast 2) env))] | |
69 | [(eq? 'let* a0) | |
70 | (let ([let-env (new Env% [outer env] [binds null] [exprs null])]) | |
71 | (_map (lambda (b_e) | |
72 | (send let-env set (_first b_e) | |
73 | (EVAL (_nth b_e 1) let-env))) | |
74 | (_partition 2 (_to_list (_nth ast 1)))) | |
75 | (EVAL (_nth ast 2) let-env))] | |
76 | [(eq? 'quote a0) | |
77 | (_nth ast 1)] | |
fbfe6784 NB |
78 | [(eq? 'quasiquoteexpand a0) |
79 | (quasiquote (cadr ast))] | |
f5223195 JM |
80 | [(eq? 'quasiquote a0) |
81 | (EVAL (quasiquote (_nth ast 1)) env)] | |
82 | [(eq? 'defmacro! a0) | |
83 | (let* ([func (EVAL (_nth ast 2) env)] | |
84 | [mac (struct-copy malfunc func [macro? #t])]) | |
85 | (send env set (_nth ast 1) mac))] | |
86 | [(eq? 'macroexpand a0) | |
87 | (macroexpand (_nth ast 1) env)] | |
88 | [(eq? 'try* a0) | |
5d991812 JM |
89 | (if (or (< (length ast) 3) |
90 | (not (eq? 'catch* (_nth (_nth ast 2) 0)))) | |
91 | (EVAL (_nth ast 1) env) | |
f5223195 JM |
92 | (let ([efn (lambda (exc) |
93 | (EVAL (_nth (_nth ast 2) 2) | |
94 | (new Env% | |
95 | [outer env] | |
96 | [binds (list (_nth (_nth ast 2) 1))] | |
97 | [exprs (list exc)])))]) | |
98 | (with-handlers | |
99 | ([mal-exn? (lambda (exc) (efn (mal-exn-val exc)))] | |
100 | [string? (lambda (exc) (efn exc))] | |
101 | [exn:fail? (lambda (exc) (efn (format "~a" exc)))]) | |
5d991812 | 102 | (EVAL (_nth ast 1) env))))] |
f5223195 JM |
103 | [(eq? 'do a0) |
104 | (eval-ast (drop (drop-right ast 1) 1) env) | |
105 | (EVAL (last ast) env)] | |
106 | [(eq? 'if a0) | |
107 | (let ([cnd (EVAL (_nth ast 1) env)]) | |
108 | (if (or (eq? cnd nil) (eq? cnd #f)) | |
109 | (if (> (length ast) 3) | |
110 | (EVAL (_nth ast 3) env) | |
111 | nil) | |
112 | (EVAL (_nth ast 2) env)))] | |
113 | [(eq? 'fn* a0) | |
114 | (malfunc | |
115 | (lambda args (EVAL (_nth ast 2) | |
116 | (new Env% [outer env] | |
117 | [binds (_nth ast 1)] | |
118 | [exprs args]))) | |
119 | (_nth ast 2) env (_nth ast 1) #f nil)] | |
120 | [else (let* ([el (eval-ast ast env)] | |
121 | [f (first el)] | |
122 | [args (rest el)]) | |
123 | (if (malfunc? f) | |
124 | (EVAL (malfunc-ast f) | |
125 | (new Env% | |
126 | [outer (malfunc-env f)] | |
127 | [binds (malfunc-params f)] | |
128 | [exprs args])) | |
129 | (apply f args)))])))))) | |
130 | ||
131 | ||
132 | (define (PRINT exp) | |
133 | (pr_str exp true)) | |
134 | ||
135 | ;; repl | |
136 | (define repl-env | |
137 | (new Env% [outer null] [binds null] [exprs null])) | |
138 | (define (rep str) | |
139 | (PRINT (EVAL (READ str) repl-env))) | |
140 | ||
141 | (for () ;; ignore return values | |
142 | ||
143 | ;; core.rkt: defined using Racket | |
144 | (hash-for-each core_ns (lambda (k v) (send repl-env set k v))) | |
145 | (send repl-env set 'eval (lambda [ast] (EVAL ast repl-env))) | |
61c7bc86 | 146 | (send repl-env set '*ARGV* (_rest (current-command-line-arguments))) |
f5223195 JM |
147 | |
148 | ;; core.mal: defined using the language itself | |
149 | (rep "(def! not (fn* (a) (if a false true)))") | |
e6d41de4 | 150 | (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))") |
f5223195 | 151 | (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)))))))") |
f5223195 JM |
152 | |
153 | ) | |
154 | ||
155 | (define (repl-loop) | |
156 | (let ([line (readline "user> ")]) | |
157 | (when (not (eq? nil line)) | |
158 | (with-handlers | |
159 | ([string? (lambda (exc) (printf "Error: ~a~n" exc))] | |
160 | [mal-exn? (lambda (exc) (printf "Error: ~a~n" | |
161 | (pr_str (mal-exn-val exc) true)))] | |
162 | [blank-exn? (lambda (exc) null)]) | |
163 | (printf "~a~n" (rep line))) | |
164 | (repl-loop)))) | |
165 | (let ([args (current-command-line-arguments)]) | |
166 | (if (> (vector-length args) 0) | |
167 | (for () (rep (string-append "(load-file \"" (vector-ref args 0) "\")"))) | |
168 | (repl-loop))) |