Commit | Line | Data |
---|---|---|
704194e1 JM |
1 | (types.ps) run |
2 | (reader.ps) run | |
3 | ||
4 | % read | |
950e3c76 JM |
5 | /_readline { print flush (%stdin) (r) file 99 string readline } def |
6 | ||
704194e1 JM |
7 | /READ { |
8 | /str exch def | |
9 | str read_str | |
10 | } def | |
11 | ||
12 | ||
13 | % eval | |
14 | % is_pair?: ast -> is_pair? -> bool | |
15 | % return true if non-empty list, otherwise false | |
16 | /is_pair? { | |
17 | dup _list? { length 0 gt }{ pop false } ifelse | |
18 | } def | |
19 | ||
20 | % ast -> quasiquote -> new_ast | |
21 | /quasiquote { 3 dict begin | |
22 | /ast exch def | |
23 | ast is_pair? not { %if not is_pair? | |
24 | /quote ast 2 _list | |
25 | }{ | |
26 | /a0 ast 0 get def | |
27 | a0 /unquote eq { %if a0 unquote symbol | |
28 | ast 1 get | |
29 | }{ a0 is_pair? { %elseif a0 is_pair? | |
30 | /a00 a0 0 get def | |
31 | a00 /splice-unquote eq { %if splice-unquote | |
32 | /concat a0 1 get ast _rest quasiquote 3 _list | |
33 | }{ %else not splice-unquote | |
34 | /cons a0 quasiquote ast _rest quasiquote 3 _list | |
35 | } ifelse | |
36 | }{ % else not a0 is_pair? | |
37 | /cons a0 quasiquote ast _rest quasiquote 3 _list | |
38 | } ifelse } ifelse | |
39 | } ifelse | |
40 | end } def | |
41 | ||
42 | /is_macro_call? { 3 dict begin | |
43 | /env exch def | |
44 | /ast exch def | |
45 | ast _list? { | |
46 | /a0 ast 0 get def | |
47 | a0 _symbol? { %if a0 is symbol | |
48 | env a0 env_find null ne { %if a0 is in env | |
49 | env a0 env_get _mal_function? { %if user defined function | |
50 | env a0 env_get /macro? get true eq %if marked as macro | |
51 | }{ false } ifelse | |
52 | }{ false } ifelse | |
53 | }{ false } ifelse | |
54 | }{ false } ifelse | |
55 | end } def | |
56 | ||
57 | /macroexpand { 3 dict begin | |
58 | /env exch def | |
59 | /ast exch def | |
60 | { | |
61 | ast env is_macro_call? { | |
62 | /mac env ast 0 get env_get def | |
63 | /ast ast _rest mac fload EVAL def | |
64 | }{ | |
65 | exit | |
66 | } ifelse | |
67 | } loop | |
68 | ast | |
69 | end } def | |
70 | ||
71 | /eval_ast { 2 dict begin | |
72 | /env exch def | |
73 | /ast exch def | |
74 | %(eval_ast: ) print ast == | |
75 | ast _symbol? { %if symbol | |
76 | env ast env_get | |
77 | }{ ast _list? { %elseif list | |
78 | [ | |
79 | ast { | |
80 | env EVAL | |
81 | } forall | |
82 | ] | |
83 | }{ % else | |
84 | ast | |
85 | } ifelse } ifelse | |
86 | end } def | |
87 | ||
88 | /EVAL { 13 dict begin | |
89 | { %loop (TCO) | |
90 | ||
91 | /env exch def | |
92 | /ast exch def | |
93 | /loop? false def | |
94 | ||
95 | %(EVAL: ) print ast true _pr_str print (\n) print | |
96 | ast _list? not { %if not a list | |
97 | ast env eval_ast | |
98 | }{ %else apply the list | |
99 | /ast ast env macroexpand def | |
100 | ast _list? not { %if no longer a list | |
101 | ast | |
102 | }{ %else still a list | |
103 | /a0 ast 0 get def | |
104 | /def! a0 eq { %if def! | |
105 | /a1 ast 1 get def | |
106 | /a2 ast 2 get def | |
107 | env a1 a2 env EVAL env_set | |
108 | }{ /let* a0 eq { %if let* | |
109 | /a1 ast 1 get def | |
110 | /a2 ast 2 get def | |
111 | /let_env env [ ] [ ] env_new def | |
112 | 0 2 a1 length 1 sub { %for each pair | |
113 | /idx exch def | |
114 | let_env | |
115 | a1 idx get | |
116 | a1 idx 1 add get let_env EVAL | |
117 | env_set | |
118 | pop % discard the return value | |
119 | } for | |
120 | a2 let_env EVAL | |
121 | }{ /quote a0 eq { %if quote | |
122 | ast 1 get | |
123 | }{ /quasiquote a0 eq { %if quasiquote | |
124 | ast 1 get quasiquote env EVAL | |
125 | }{ /defmacro! a0 eq { %if defmacro! | |
126 | /a1 ast 1 get def | |
127 | /a2 ast 2 get def | |
128 | a2 env EVAL | |
129 | dup /macro? true put % set macro flag | |
130 | env exch a1 exch env_set % def! it | |
131 | }{ /macroexpand a0 eq { %if defmacro! | |
132 | ast 1 get env macroexpand | |
133 | }{ /ps* a0 eq { %if ps* | |
134 | count /stackcnt exch def | |
135 | ast 1 get | |
136 | { | |
137 | token not { exit } if | |
138 | exch | |
139 | } loop | |
140 | exec | |
141 | count stackcnt gt { % if new operands on stack | |
142 | % return an list of new operands | |
143 | count stackcnt sub array astore | |
144 | }{ | |
145 | null % return nil | |
146 | } ifelse | |
147 | }{ /do a0 eq { %if do | |
148 | ast length 2 gt { %if ast has more than 2 elements | |
149 | ast 1 ast length 2 sub getinterval env eval_ast pop | |
150 | } if | |
151 | ast ast length 1 sub get % last ast becomes new ast | |
152 | env | |
153 | /loop? true def % loop | |
154 | }{ /if a0 eq { %if if | |
155 | /a1 ast 1 get def | |
156 | /cond a1 env EVAL def | |
157 | cond null eq cond false eq or { % if cond is nil or false | |
158 | ast length 3 gt { %if false branch with a3 | |
159 | ast 3 get env | |
160 | /loop? true def | |
161 | }{ % else false branch with no a3 | |
162 | null | |
163 | } ifelse | |
164 | }{ % true branch | |
165 | ast 2 get env | |
166 | /loop? true def | |
167 | } ifelse | |
168 | }{ /fn* a0 eq { %if fn* | |
169 | /a1 ast 1 get def | |
170 | /a2 ast 2 get def | |
171 | << | |
172 | /type /_maltype_function % user defined function | |
173 | /macro? false % macro flag, false by default | |
174 | /params null % close over parameters | |
175 | /ast null % close over ast | |
176 | /env null % close over environment | |
950e3c76 | 177 | /data { __self__ fload EVAL } |
704194e1 JM |
178 | >> |
179 | dup length dict copy % make an actual copy/new instance | |
180 | dup /params a1 put % insert closed over a1 into position 2 | |
181 | dup /ast a2 put % insert closed over a2 into position 3 | |
182 | dup /env env put % insert closed over env into position 4 | |
950e3c76 | 183 | dup dup /data get exch 0 exch put % insert self reference |
704194e1 JM |
184 | }{ |
185 | /el ast env eval_ast def | |
950e3c76 JM |
186 | el _rest el _first % stack: ast function |
187 | dup _mal_function? { % if user defined function | |
188 | fload % stack: ast new_env | |
704194e1 JM |
189 | /loop? true def |
190 | }{ %else (regular procedure/function) | |
950e3c76 | 191 | exec % apply function to args |
704194e1 JM |
192 | } ifelse |
193 | } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse } ifelse | |
194 | } ifelse | |
195 | } ifelse | |
196 | ||
197 | loop? not { exit } if | |
198 | } loop % TCO | |
199 | end } def | |
200 | ||
201 | ||
202 | ||
203 | /PRINT { | |
204 | true _pr_str | |
205 | } def | |
206 | ||
207 | ||
208 | % repl | |
209 | /repl_env null [ ] [ ] env_new def | |
210 | ||
211 | /RE { READ repl_env EVAL } def | |
212 | /REP { READ repl_env EVAL PRINT } def | |
213 | /_ref { repl_env 3 1 roll env_set pop } def | |
214 | ||
215 | types_ns { _ref } forall | |
216 | ||
217 | (read-string) { 0 get read_str } _ref | |
218 | (eval) { 0 get repl_env EVAL } _ref | |
219 | /slurp { (r) file dup bytesavailable string readstring pop } def | |
220 | (slurp) { 0 get slurp } _ref | |
704194e1 JM |
221 | |
222 | (\(def! not \(fn* \(a\) \(if a false true\)\)\)) RE pop | |
223 | (\(def! load-file \(fn* \(f\) \(eval \(read-string \(str "\(do " \(slurp f\) "\)"\)\)\)\)\)) RE pop | |
224 | ||
704194e1 JM |
225 | userdict /ARGUMENTS known { %if command line arguments |
226 | ARGUMENTS length 0 gt { %if more than 0 arguments | |
227 | ARGUMENTS { | |
228 | (\(load-file ") exch ("\)) concatenate concatenate RE pop | |
229 | } forall | |
230 | quit | |
231 | } if | |
232 | } if | |
233 | { % loop | |
950e3c76 | 234 | (user> ) _readline |
704194e1 JM |
235 | not { exit } if % exit if EOF |
236 | ||
704194e1 JM |
237 | { %try |
238 | REP print (\n) print | |
239 | } stopped { | |
240 | (Error: ) print | |
241 | get_error_data false _pr_str print (\n) print | |
242 | $error /newerror false put | |
243 | $error /errorinfo null put | |
244 | clear | |
950e3c76 | 245 | cleardictstack |
704194e1 JM |
246 | } if |
247 | } bind loop | |
248 | ||
249 | (\n) print % final newline before exit for cleanliness | |
250 | quit |