mirror of
https://github.com/kanaka/mal.git
synced 2024-11-11 00:52:44 +03:00
dd7a4f55f3
Fixes made to: ada, c, chuck, clojure, coffee, common-lisp, cpp, crystal, d, dart, elm, erlang, es6, factor, fsharp, gnu-smalltalk, groovy, guile, haxe, hy, js, livescript, matlab, miniMAL, nasm, nim, objc, objpascal, ocaml, perl, perl6, php, plsql, ps, python, r, rpython, ruby, scheme, swift3, tcl, ts, vb, vimscript, wasm, yorick. Catchless try* test is an optional test. Not all implementations support catchless try* but a number were fixed so they at least don't crash on catchless try*.
463 lines
16 KiB
SQL
463 lines
16 KiB
SQL
@io.sql
|
|
@types.sql
|
|
@reader.sql
|
|
@printer.sql
|
|
@env.sql
|
|
@core.sql
|
|
|
|
CREATE OR REPLACE PACKAGE mal IS
|
|
|
|
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer;
|
|
|
|
END mal;
|
|
/
|
|
|
|
CREATE OR REPLACE PACKAGE BODY mal IS
|
|
|
|
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS
|
|
M types.mal_table; -- general mal value memory pool
|
|
H types.map_entry_table; -- hashmap memory pool
|
|
E env_pkg.env_entry_table; -- mal env memory pool
|
|
repl_env integer;
|
|
x integer;
|
|
line CLOB;
|
|
core_ns core_ns_T;
|
|
cidx integer;
|
|
argv mal_vals;
|
|
err_val integer;
|
|
|
|
-- read
|
|
FUNCTION READ(line varchar) RETURN integer IS
|
|
BEGIN
|
|
RETURN reader.read_str(M, H, line);
|
|
END;
|
|
|
|
-- eval
|
|
|
|
-- forward declarations
|
|
FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer;
|
|
FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer;
|
|
|
|
FUNCTION is_pair(ast integer) RETURN BOOLEAN IS
|
|
BEGIN
|
|
RETURN M(ast).type_id IN (8,9) AND types.count(M, ast) > 0;
|
|
END;
|
|
|
|
FUNCTION quasiquote(ast integer) RETURN integer IS
|
|
a0 integer;
|
|
a00 integer;
|
|
BEGIN
|
|
IF NOT is_pair(ast) THEN
|
|
RETURN types.list(M, types.symbol(M, 'quote'), ast);
|
|
ELSE
|
|
a0 := types.nth(M, ast, 0);
|
|
IF M(a0).type_id = 7 AND
|
|
TREAT(m(a0) AS mal_str_T).val_str = 'unquote' THEN
|
|
RETURN types.nth(M, ast, 1);
|
|
ELSIF is_pair(a0) THEN
|
|
a00 := types.nth(M, a0, 0);
|
|
IF M(a00).type_id = 7 AND
|
|
TREAT(M(a00) AS mal_str_T).val_str = 'splice-unquote' THEN
|
|
RETURN types.list(M, types.symbol(M, 'concat'),
|
|
types.nth(M, a0, 1),
|
|
quasiquote(types.slice(M, ast, 1)));
|
|
END IF;
|
|
END IF;
|
|
RETURN types.list(M, types.symbol(M, 'cons'),
|
|
quasiquote(a0),
|
|
quasiquote(types.slice(M, ast, 1)));
|
|
END IF;
|
|
END;
|
|
|
|
|
|
FUNCTION is_macro_call(ast integer, env integer) RETURN BOOLEAN IS
|
|
a0 integer;
|
|
mac integer;
|
|
BEGIN
|
|
IF M(ast).type_id = 8 THEN
|
|
a0 := types.nth(M, ast, 0);
|
|
IF M(a0).type_id = 7 AND
|
|
env_pkg.env_find(M, E, env, a0) IS NOT NULL THEN
|
|
mac := env_pkg.env_get(M, E, env, a0);
|
|
IF M(mac).type_id = 12 THEN
|
|
RETURN TREAT(M(mac) AS mal_func_T).is_macro > 0;
|
|
END IF;
|
|
END IF;
|
|
END IF;
|
|
RETURN FALSE;
|
|
END;
|
|
|
|
FUNCTION macroexpand(orig_ast integer, env integer) RETURN integer IS
|
|
ast integer;
|
|
mac integer;
|
|
malfn mal_func_T;
|
|
fargs mal_vals;
|
|
fn_env integer;
|
|
BEGIN
|
|
ast := orig_ast;
|
|
WHILE is_macro_call(ast, env) LOOP
|
|
mac := env_pkg.env_get(M, E, env, types.nth(M, ast, 0));
|
|
fargs := TREAT(M(types.slice(M, ast, 1)) as mal_seq_T).val_seq;
|
|
if M(mac).type_id = 12 THEN
|
|
malfn := TREAT(M(mac) AS mal_func_T);
|
|
fn_env := env_pkg.env_new(M, E, malfn.env,
|
|
malfn.params,
|
|
fargs);
|
|
ast := EVAL(malfn.ast, fn_env);
|
|
ELSE
|
|
ast := do_builtin(mac, fargs);
|
|
END IF;
|
|
END LOOP;
|
|
RETURN ast;
|
|
END;
|
|
|
|
FUNCTION eval_ast(ast integer, env integer) RETURN integer IS
|
|
i integer;
|
|
old_seq mal_vals;
|
|
new_seq mal_vals;
|
|
new_hm integer;
|
|
old_midx integer;
|
|
new_midx integer;
|
|
k varchar2(256);
|
|
BEGIN
|
|
IF M(ast).type_id = 7 THEN
|
|
RETURN env_pkg.env_get(M, E, env, ast);
|
|
ELSIF M(ast).type_id IN (8,9) THEN
|
|
old_seq := TREAT(M(ast) AS mal_seq_T).val_seq;
|
|
new_seq := mal_vals();
|
|
new_seq.EXTEND(old_seq.COUNT);
|
|
FOR i IN 1..old_seq.COUNT LOOP
|
|
new_seq(i) := EVAL(old_seq(i), env);
|
|
END LOOP;
|
|
RETURN types.seq(M, M(ast).type_id, new_seq);
|
|
ELSIF M(ast).type_id IN (10) THEN
|
|
new_hm := types.hash_map(M, H, mal_vals());
|
|
old_midx := TREAT(M(ast) AS mal_map_T).map_idx;
|
|
new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx;
|
|
|
|
k := H(old_midx).FIRST();
|
|
WHILE k IS NOT NULL LOOP
|
|
H(new_midx)(k) := EVAL(H(old_midx)(k), env);
|
|
k := H(old_midx).NEXT(k);
|
|
END LOOP;
|
|
RETURN new_hm;
|
|
ELSE
|
|
RETURN ast;
|
|
END IF;
|
|
END;
|
|
|
|
FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS
|
|
ast integer := orig_ast;
|
|
env integer := orig_env;
|
|
el integer;
|
|
a0 integer;
|
|
a0sym varchar2(100);
|
|
seq mal_vals;
|
|
let_env integer;
|
|
try_env integer;
|
|
i integer;
|
|
f integer;
|
|
cond integer;
|
|
malfn mal_func_T;
|
|
args mal_vals;
|
|
BEGIN
|
|
WHILE TRUE LOOP
|
|
-- io.writeline('EVAL: ' || printer.pr_str(M, H, ast));
|
|
IF M(ast).type_id <> 8 THEN
|
|
RETURN eval_ast(ast, env);
|
|
END IF;
|
|
|
|
-- apply
|
|
ast := macroexpand(ast, env);
|
|
IF M(ast).type_id <> 8 THEN
|
|
RETURN eval_ast(ast, env);
|
|
END IF;
|
|
IF types.count(M, ast) = 0 THEN
|
|
RETURN ast; -- empty list just returned
|
|
END IF;
|
|
|
|
-- apply
|
|
a0 := types.first(M, ast);
|
|
if M(a0).type_id = 7 THEN -- symbol
|
|
a0sym := TREAT(M(a0) AS mal_str_T).val_str;
|
|
ELSE
|
|
a0sym := '__<*fn*>__';
|
|
END IF;
|
|
|
|
CASE
|
|
WHEN a0sym = 'def!' THEN
|
|
RETURN env_pkg.env_set(M, E, env,
|
|
types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env));
|
|
WHEN a0sym = 'let*' THEN
|
|
let_env := env_pkg.env_new(M, E, env);
|
|
seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq;
|
|
i := 1;
|
|
WHILE i <= seq.COUNT LOOP
|
|
x := env_pkg.env_set(M, E, let_env,
|
|
seq(i), EVAL(seq(i+1), let_env));
|
|
i := i + 2;
|
|
END LOOP;
|
|
env := let_env;
|
|
ast := types.nth(M, ast, 2); -- TCO
|
|
WHEN a0sym = 'quote' THEN
|
|
RETURN types.nth(M, ast, 1);
|
|
WHEN a0sym = 'quasiquote' THEN
|
|
RETURN EVAL(quasiquote(types.nth(M, ast, 1)), env);
|
|
WHEN a0sym = 'defmacro!' THEN
|
|
x := EVAL(types.nth(M, ast, 2), env);
|
|
malfn := TREAT(M(x) as mal_func_T);
|
|
malfn.is_macro := 1;
|
|
M(x) := malfn;
|
|
RETURN env_pkg.env_set(M, E, env,
|
|
types.nth(M, ast, 1), x);
|
|
WHEN a0sym = 'macroexpand' THEN
|
|
RETURN macroexpand(types.nth(M, ast, 1), env);
|
|
WHEN a0sym = 'try*' THEN
|
|
DECLARE
|
|
exc integer;
|
|
a2 integer := -1;
|
|
a20 integer := -1;
|
|
a20sym varchar2(100);
|
|
BEGIN
|
|
RETURN EVAL(types.nth(M, ast, 1), env);
|
|
|
|
EXCEPTION WHEN OTHERS THEN
|
|
IF types.count(M, ast) > 2 THEN
|
|
a2 := types.nth(M, ast, 2);
|
|
IF M(a2).type_id = 8 THEN
|
|
a20 := types.nth(M, a2, 0);
|
|
IF M(a20).type_id = 7 THEN
|
|
a20sym := TREAT(M(a20) AS mal_str_T).val_str;
|
|
END IF;
|
|
END IF;
|
|
END IF;
|
|
IF a20sym = 'catch*' THEN
|
|
IF SQLCODE <> -20000 THEN
|
|
IF SQLCODE < -20000 AND SQLCODE > -20100 THEN
|
|
exc := types.string(M,
|
|
REGEXP_REPLACE(SQLERRM,
|
|
'^ORA-200[0-9][0-9]: '));
|
|
ELSE
|
|
exc := types.string(M, SQLERRM);
|
|
END IF;
|
|
ELSE -- mal throw
|
|
exc := err_val;
|
|
err_val := NULL;
|
|
END IF;
|
|
try_env := env_pkg.env_new(M, E, env,
|
|
types.list(M, types.nth(M, a2, 1)),
|
|
mal_vals(exc));
|
|
RETURN EVAL(types.nth(M, a2, 2), try_env);
|
|
END IF;
|
|
RAISE; -- not handled, re-raise the exception
|
|
END;
|
|
WHEN a0sym = 'do' THEN
|
|
x := types.slice(M, ast, 1, types.count(M, ast)-2);
|
|
x := eval_ast(x, env);
|
|
ast := types.nth(M, ast, types.count(M, ast)-1); -- TCO
|
|
WHEN a0sym = 'if' THEN
|
|
cond := EVAL(types.nth(M, ast, 1), env);
|
|
IF cond = 1 OR cond = 2 THEN -- nil or false
|
|
IF types.count(M, ast) > 3 THEN
|
|
ast := types.nth(M, ast, 3); -- TCO
|
|
ELSE
|
|
RETURN 1; -- nil
|
|
END IF;
|
|
ELSE
|
|
ast := types.nth(M, ast, 2); -- TCO
|
|
END IF;
|
|
WHEN a0sym = 'fn*' THEN
|
|
RETURN types.malfunc(M, types.nth(M, ast, 2),
|
|
types.nth(M, ast, 1),
|
|
env);
|
|
ELSE
|
|
el := eval_ast(ast, env);
|
|
f := types.first(M, el);
|
|
args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq;
|
|
IF M(f).type_id = 12 THEN
|
|
malfn := TREAT(M(f) AS mal_func_T);
|
|
env := env_pkg.env_new(M, E, malfn.env,
|
|
malfn.params, args);
|
|
ast := malfn.ast; -- TCO
|
|
ELSE
|
|
RETURN do_builtin(f, args);
|
|
END IF;
|
|
END CASE;
|
|
|
|
END LOOP;
|
|
|
|
END;
|
|
|
|
-- hack to get around lack of function references
|
|
-- functions that require special access to repl_env or EVAL
|
|
-- are implemented directly here, otherwise, core.do_core_fn
|
|
-- is called.
|
|
FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer IS
|
|
fname varchar2(100);
|
|
val integer;
|
|
f integer;
|
|
malfn mal_func_T;
|
|
fargs mal_vals;
|
|
fn_env integer;
|
|
i integer;
|
|
tseq mal_vals;
|
|
BEGIN
|
|
fname := TREAT(M(fn) AS mal_str_T).val_str;
|
|
CASE
|
|
WHEN fname = 'do_eval' THEN
|
|
RETURN EVAL(args(1), repl_env);
|
|
WHEN fname = 'swap!' THEN
|
|
val := TREAT(M(args(1)) AS mal_atom_T).val;
|
|
f := args(2);
|
|
-- slice one extra at the beginning that will be changed
|
|
-- to the value of the atom
|
|
fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_T).val_seq;
|
|
fargs(1) := val;
|
|
IF M(f).type_id = 12 THEN
|
|
malfn := TREAT(M(f) AS mal_func_T);
|
|
fn_env := env_pkg.env_new(M, E, malfn.env,
|
|
malfn.params, fargs);
|
|
val := EVAL(malfn.ast, fn_env);
|
|
ELSE
|
|
val := do_builtin(f, fargs);
|
|
END IF;
|
|
RETURN types.atom_reset(M, args(1), val);
|
|
WHEN fname = 'apply' THEN
|
|
f := args(1);
|
|
fargs := mal_vals();
|
|
tseq := TREAT(M(args(args.COUNT())) AS mal_seq_T).val_seq;
|
|
fargs.EXTEND(args.COUNT()-2 + tseq.COUNT());
|
|
FOR i IN 1..args.COUNT()-2 LOOP
|
|
fargs(i) := args(i+1);
|
|
END LOOP;
|
|
FOR i IN 1..tseq.COUNT() LOOP
|
|
fargs(args.COUNT()-2 + i) := tseq(i);
|
|
END LOOP;
|
|
IF M(f).type_id = 12 THEN
|
|
malfn := TREAT(M(f) AS mal_func_T);
|
|
fn_env := env_pkg.env_new(M, E, malfn.env,
|
|
malfn.params, fargs);
|
|
val := EVAL(malfn.ast, fn_env);
|
|
ELSE
|
|
val := do_builtin(f, fargs);
|
|
END IF;
|
|
RETURN val;
|
|
WHEN fname = 'map' THEN
|
|
f := args(1);
|
|
fargs := TREAT(M(args(2)) AS mal_seq_T).val_seq;
|
|
tseq := mal_vals();
|
|
tseq.EXTEND(fargs.COUNT());
|
|
IF M(f).type_id = 12 THEN
|
|
malfn := TREAT(M(f) AS mal_func_T);
|
|
FOR i IN 1..fargs.COUNT() LOOP
|
|
fn_env := env_pkg.env_new(M, E, malfn.env,
|
|
malfn.params,
|
|
mal_vals(fargs(i)));
|
|
tseq(i) := EVAL(malfn.ast, fn_env);
|
|
END LOOP;
|
|
ELSE
|
|
FOR i IN 1..fargs.COUNT() LOOP
|
|
tseq(i) := do_builtin(f,
|
|
mal_vals(fargs(i)));
|
|
END LOOP;
|
|
END IF;
|
|
RETURN types.seq(M, 8, tseq);
|
|
WHEN fname = 'throw' THEN
|
|
err_val := args(1);
|
|
raise_application_error(-20000, 'MalException', TRUE);
|
|
ELSE
|
|
RETURN core.do_core_func(M, H, fn, args);
|
|
END CASE;
|
|
END;
|
|
|
|
|
|
-- print
|
|
FUNCTION PRINT(exp integer) RETURN varchar IS
|
|
BEGIN
|
|
RETURN printer.pr_str(M, H, exp);
|
|
END;
|
|
|
|
-- repl
|
|
FUNCTION REP(line varchar) RETURN varchar IS
|
|
BEGIN
|
|
RETURN PRINT(EVAL(READ(line), repl_env));
|
|
END;
|
|
|
|
BEGIN
|
|
-- initialize memory pools
|
|
M := types.mem_new();
|
|
H := types.map_entry_table();
|
|
E := env_pkg.env_entry_table();
|
|
|
|
repl_env := env_pkg.env_new(M, E, NULL);
|
|
|
|
argv := TREAT(M(reader.read_str(M, H, args)) AS mal_seq_T).val_seq;
|
|
|
|
-- core.EXT: defined using PL/SQL
|
|
core_ns := core.get_core_ns();
|
|
FOR cidx IN 1..core_ns.COUNT LOOP
|
|
x := env_pkg.env_set(M, E, repl_env,
|
|
types.symbol(M, core_ns(cidx)),
|
|
types.func(M, core_ns(cidx)));
|
|
END LOOP;
|
|
x := env_pkg.env_set(M, E, repl_env,
|
|
types.symbol(M, 'eval'),
|
|
types.func(M, 'do_eval'));
|
|
x := env_pkg.env_set(M, E, repl_env,
|
|
types.symbol(M, '*ARGV*'),
|
|
types.slice(M, argv, 1));
|
|
|
|
-- core.mal: defined using the language itself
|
|
line := REP('(def! *host-language* "PL/SQL")');
|
|
line := REP('(def! not (fn* (a) (if a false true)))');
|
|
line := REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))');
|
|
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)))))))');
|
|
line := REP('(def! *gensym-counter* (atom 0))');
|
|
line := REP('(def! gensym (fn* [] (symbol (str "G__" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))');
|
|
line := REP('(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))');
|
|
|
|
IF argv.COUNT() > 0 THEN
|
|
BEGIN
|
|
line := REP('(load-file "' ||
|
|
TREAT(M(argv(1)) AS mal_str_T).val_str ||
|
|
'")');
|
|
io.close(1); -- close output stream
|
|
RETURN 0;
|
|
EXCEPTION WHEN OTHERS THEN
|
|
io.writeline('Error: ' || SQLERRM);
|
|
io.writeline(dbms_utility.format_error_backtrace);
|
|
io.close(1); -- close output stream
|
|
RAISE;
|
|
END;
|
|
END IF;
|
|
|
|
line := REP('(println (str "Mal [" *host-language* "]"))');
|
|
WHILE true LOOP
|
|
BEGIN
|
|
line := io.readline('user> ', 0);
|
|
IF line = EMPTY_CLOB() THEN CONTINUE; END IF;
|
|
IF line IS NOT NULL THEN
|
|
io.writeline(REP(line));
|
|
END IF;
|
|
|
|
EXCEPTION WHEN OTHERS THEN
|
|
IF SQLCODE = -20001 THEN -- io read stream closed
|
|
io.close(1); -- close output stream
|
|
RETURN 0;
|
|
END IF;
|
|
IF SQLCODE <> -20000 THEN
|
|
io.writeline('Error: ' || SQLERRM);
|
|
ELSE
|
|
io.writeline('Error: ' || printer.pr_str(M, H, err_val));
|
|
END IF;
|
|
io.writeline(dbms_utility.format_error_backtrace);
|
|
END;
|
|
END LOOP;
|
|
END;
|
|
|
|
END mal;
|
|
/
|
|
show errors;
|
|
|
|
quit;
|