8 CREATE OR REPLACE PACKAGE mal
IS
10 FUNCTION MAIN(args
varchar DEFAULT '()') RETURN integer;
15 CREATE OR REPLACE PACKAGE BODY mal
IS
17 FUNCTION MAIN(args
varchar DEFAULT '()') RETURN integer IS
18 M types.mal_table
; -- general mal value memory pool
19 H types.map_entry_table
; -- hashmap memory pool
20 E env_pkg.env_entry_table
; -- mal env memory pool
29 FUNCTION READ(line
varchar) RETURN integer IS
31 RETURN reader.
read_str(M
, H
, line
);
36 -- forward declarations
37 FUNCTION EVAL(orig_ast
integer, orig_env
integer) RETURN integer;
38 FUNCTION do_builtin(fn
integer, args mal_vals
) RETURN integer;
40 FUNCTION is_pair(ast
integer) RETURN BOOLEAN IS
42 RETURN M(ast
).type_id
IN (8,9) AND types.
count(M
, ast
) > 0;
45 FUNCTION quasiquote(ast
integer) RETURN integer IS
49 IF NOT is_pair(ast
) THEN
50 RETURN types.
list(M
, types.
symbol(M
, 'quote'), ast
);
52 a0
:= types.
nth(M
, ast
, 0);
53 IF M(a0
).type_id
= 7 AND
54 TREAT(m(a0
) AS mal_str_T
).val_str
= 'unquote' THEN
55 RETURN types.
nth(M
, ast
, 1);
56 ELSIF
is_pair(a0
) THEN
57 a00
:= types.
nth(M
, a0
, 0);
58 IF M(a00
).type_id
= 7 AND
59 TREAT(M(a00
) AS mal_str_T
).val_str
= 'splice-unquote' THEN
60 RETURN types.
list(M
, types.
symbol(M
, 'concat'),
62 quasiquote(types.
slice(M
, ast
, 1)));
65 RETURN types.
list(M
, types.
symbol(M
, 'cons'),
67 quasiquote(types.
slice(M
, ast
, 1)));
72 FUNCTION is_macro_call(ast
integer, env
integer) RETURN BOOLEAN IS
76 IF M(ast
).type_id
= 8 THEN
77 a0
:= types.
nth(M
, ast
, 0);
78 IF M(a0
).type_id
= 7 AND
79 env_pkg.
env_find(M
, E
, env
, a0
) IS NOT NULL THEN
80 mac
:= env_pkg.
env_get(M
, E
, env
, a0
);
81 IF M(mac
).type_id
= 12 THEN
82 RETURN TREAT(M(mac
) AS mal_func_T
).is_macro
> 0;
89 FUNCTION macroexpand(orig_ast
integer, env
integer) RETURN integer IS
97 WHILE
is_macro_call(ast
, env
) LOOP
98 mac
:= env_pkg.
env_get(M
, E
, env
, types.
nth(M
, ast
, 0));
99 fargs
:= TREAT(M(types.
slice(M
, ast
, 1)) as mal_seq_T
).val_seq
;
100 if M(mac
).type_id
= 12 THEN
101 malfn
:= TREAT(M(mac
) AS mal_func_T
);
102 fn_env
:= env_pkg.
env_new(M
, E
, malfn.env
,
105 ast
:= EVAL(malfn.ast
, fn_env
);
107 ast
:= do_builtin(mac
, fargs
);
113 FUNCTION eval_ast(ast
integer, env
integer) RETURN integer IS
122 IF M(ast
).type_id
= 7 THEN
123 RETURN env_pkg.
env_get(M
, E
, env
, ast
);
124 ELSIF
M(ast
).type_id
IN (8,9) THEN
125 old_seq
:= TREAT(M(ast
) AS mal_seq_T
).val_seq
;
126 new_seq
:= mal_vals();
127 new_seq.
EXTEND(old_seq.
COUNT);
128 FOR i
IN 1..old_seq.
COUNT LOOP
129 new_seq(i
) := EVAL(old_seq(i
), env
);
131 RETURN types.
seq(M
, M(ast
).type_id
, new_seq
);
132 ELSIF
M(ast
).type_id
IN (10) THEN
133 new_hm
:= types.
hash_map(M
, H
, mal_vals());
134 old_midx
:= TREAT(M(ast
) AS mal_map_T
).map_idx
;
135 new_midx
:= TREAT(M(new_hm
) AS mal_map_T
).map_idx
;
137 k
:= H(old_midx
).
FIRST();
138 WHILE k
IS NOT NULL LOOP
139 H(new_midx
)(k
) := EVAL(H(old_midx
)(k
), env
);
140 k
:= H(old_midx
).
NEXT(k
);
148 FUNCTION EVAL(orig_ast
integer, orig_env
integer) RETURN integer IS
149 ast
integer := orig_ast
;
150 env
integer := orig_env
;
163 -- io.writeline('EVAL: ' || printer.pr_str(M, H, ast));
164 IF M(ast
).type_id
<> 8 THEN
165 RETURN eval_ast(ast
, env
);
169 ast
:= macroexpand(ast
, env
);
170 IF M(ast
).type_id
<> 8 THEN
171 RETURN eval_ast(ast
, env
);
173 IF types.
count(M
, ast
) = 0 THEN
174 RETURN ast
; -- empty list just returned
178 a0
:= types.
first(M
, ast
);
179 if M(a0
).type_id
= 7 THEN -- symbol
180 a0sym
:= TREAT(M(a0
) AS mal_str_T
).val_str
;
182 a0sym
:= '__<*fn*>__';
186 WHEN a0sym
= 'def!' THEN
187 RETURN env_pkg.
env_set(M
, E
, env
,
188 types.
nth(M
, ast
, 1), EVAL(types.
nth(M
, ast
, 2), env
));
189 WHEN a0sym
= 'let*' THEN
190 let_env
:= env_pkg.
env_new(M
, E
, env
);
191 seq
:= TREAT(M(types.
nth(M
, ast
, 1)) AS mal_seq_T
).val_seq
;
193 WHILE i
<= seq.
COUNT LOOP
194 x
:= env_pkg.
env_set(M
, E
, let_env
,
195 seq(i
), EVAL(seq(i
+1), let_env
));
199 ast
:= types.
nth(M
, ast
, 2); -- TCO
200 WHEN a0sym
= 'quote' THEN
201 RETURN types.
nth(M
, ast
, 1);
202 WHEN a0sym
= 'quasiquote' THEN
203 RETURN EVAL(quasiquote(types.
nth(M
, ast
, 1)), env
);
204 WHEN a0sym
= 'defmacro!' THEN
205 x
:= EVAL(types.
nth(M
, ast
, 2), env
);
206 malfn
:= TREAT(M(x
) as mal_func_T
);
209 RETURN env_pkg.
env_set(M
, E
, env
,
210 types.
nth(M
, ast
, 1), x
);
211 WHEN a0sym
= 'macroexpand' THEN
212 RETURN macroexpand(types.
nth(M
, ast
, 1), env
);
213 WHEN a0sym
= 'do' THEN
214 x
:= types.
slice(M
, ast
, 1, types.
count(M
, ast
)-2);
215 x
:= eval_ast(x
, env
);
216 ast
:= types.
nth(M
, ast
, types.
count(M
, ast
)-1); -- TCO
217 WHEN a0sym
= 'if' THEN
218 cond
:= EVAL(types.
nth(M
, ast
, 1), env
);
219 IF cond
= 1 OR cond
= 2 THEN -- nil or false
220 IF types.
count(M
, ast
) > 3 THEN
221 ast
:= types.
nth(M
, ast
, 3); -- TCO
226 ast
:= types.
nth(M
, ast
, 2); -- TCO
228 WHEN a0sym
= 'fn*' THEN
229 RETURN types.
malfunc(M
, types.
nth(M
, ast
, 2),
230 types.
nth(M
, ast
, 1),
233 el
:= eval_ast(ast
, env
);
234 f
:= types.
first(M
, el
);
235 args
:= TREAT(M(types.
slice(M
, el
, 1)) AS mal_seq_T
).val_seq
;
236 IF M(f
).type_id
= 12 THEN
237 malfn
:= TREAT(M(f
) AS mal_func_T
);
238 env
:= env_pkg.
env_new(M
, E
, malfn.env
,
240 ast
:= malfn.ast
; -- TCO
242 RETURN do_builtin(f
, args
);
250 -- hack to get around lack of function references
251 -- functions that require special access to repl_env or EVAL
252 -- are implemented directly here, otherwise, core.do_core_fn
254 FUNCTION do_builtin(fn
integer, args mal_vals
) RETURN integer IS
262 fname
:= TREAT(M(fn
) AS mal_str_T
).val_str
;
264 WHEN fname
= 'do_eval' THEN
265 RETURN EVAL(args(1), repl_env
);
266 WHEN fname
= 'swap!' THEN
267 val
:= TREAT(M(args(1)) AS mal_atom_T
).val
;
269 -- slice one extra at the beginning that will be changed
270 -- to the value of the atom
271 fargs
:= TREAT(M(types.
slice(M
, args
, 1)) AS mal_seq_T
).val_seq
;
273 IF M(f
).type_id
= 12 THEN
274 malfn
:= TREAT(M(f
) AS mal_func_T
);
275 fn_env
:= env_pkg.
env_new(M
, E
, malfn.env
,
276 malfn.params
, fargs
);
277 val
:= EVAL(malfn.ast
, fn_env
);
279 val
:= do_builtin(f
, fargs
);
281 RETURN types.
atom_reset(M
, args(1), val
);
283 RETURN core.
do_core_func(M
, H
, fn
, args
);
289 FUNCTION PRINT(exp integer) RETURN varchar IS
291 RETURN printer.
pr_str(M
, H
, exp);
295 FUNCTION REP(line
varchar) RETURN varchar IS
297 RETURN PRINT(EVAL(READ(line
), repl_env
));
301 -- initialize memory pools
302 M
:= types.
mem_new();
303 H
:= types.
map_entry_table();
304 E
:= env_pkg.
env_entry_table();
306 repl_env
:= env_pkg.
env_new(M
, E
, NULL);
308 argv
:= TREAT(M(reader.
read_str(M
, H
, args
)) AS mal_seq_T
).val_seq
;
310 -- core.EXT: defined using PL/SQL
311 core_ns
:= core.
get_core_ns();
312 FOR cidx
IN 1..core_ns.
COUNT LOOP
313 x
:= env_pkg.
env_set(M
, E
, repl_env
,
314 types.
symbol(M
, core_ns(cidx
)),
315 types.
func(M
, core_ns(cidx
)));
317 x
:= env_pkg.
env_set(M
, E
, repl_env
,
318 types.
symbol(M
, 'eval'),
319 types.
func(M
, 'do_eval'));
320 x
:= env_pkg.
env_set(M
, E
, repl_env
,
321 types.
symbol(M
, '*ARGV*'),
322 types.
slice(M
, argv
, 1));
324 -- core.mal: defined using the language itself
325 line
:= REP('(def! not (fn* (a) (if a false true)))');
326 line
:= REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))');
327 line
:= 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)))))))');
329 IF argv.
COUNT() > 0 THEN
331 line
:= REP('(load-file "' ||
332 TREAT(M(argv(1)) AS mal_str_T
).val_str ||
334 io.
close(1); -- close output stream
336 EXCEPTION WHEN OTHERS THEN
337 io.
writeline('Error: ' || SQLERRM
);
338 io.
writeline(dbms_utility.format_error_backtrace
);
339 io.
close(1); -- close output stream
346 line
:= io.
readline('user> ', 0);
347 IF line
= EMPTY_CLOB() THEN CONTINUE; END IF;
348 IF line
IS NOT NULL THEN
349 io.
writeline(REP(line
));
352 EXCEPTION WHEN OTHERS THEN
353 IF SQLCODE = -20001 THEN -- io read stream closed
354 io.
close(1); -- close output stream
357 io.
writeline('Error: ' || SQLERRM
);
358 io.
writeline(dbms_utility.format_error_backtrace
);