[jackhill/mal.git] / plsql / stepA_mal.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;
                io.writeline('Error: ' || SQLERRM);
                io.writeline(dbms_utility.format_error_backtrace);
        END;
    END LOOP;
END;

END mal;
/
show errors;

quit;
Commit	Line	Data
10cc781f JM	1	@io.sql
	2	@types.sql
	3	@reader.sql
	4	@printer.sql
	5	@env.sql
	6	@core.sql
	7
	8	CREATE OR REPLACE PACKAGE mal IS
	9
	10	FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer;
	11
	12	END mal;
	13	/
	14
	15	CREATE OR REPLACE PACKAGE BODY mal IS
	16
	17	FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS
2866f9a8	18	M types.mal_table; -- general mal value memory pool
6a085103 JM	19	H types.map_entry_table; -- hashmap memory pool
6a085103 JM	20	E env_pkg.env_entry_table; -- mal env memory pool
10cc781f JM	21	repl_env integer;
10cc781f JM	22	x integer;
02936b42	23	line CLOB;
2866f9a8	24	core_ns core_ns_T;
10cc781f	25	cidx integer;
2866f9a8	26	argv mal_vals;
10cc781f JM	27	err_val integer;
	28
	29	-- read
	30	FUNCTION READ(line varchar) RETURN integer IS
	31	BEGIN
6a085103	32	RETURN reader.read_str(M, H, line);
10cc781f JM	33	END;
	34
	35	-- eval
	36
	37	-- forward declarations
	38	FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer;
2866f9a8	39	FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer;
10cc781f JM	40
	41	FUNCTION is_pair(ast integer) RETURN BOOLEAN IS
	42	BEGIN
	43	RETURN M(ast).type_id IN (8,9) AND types.count(M, ast) > 0;
	44	END;
	45
	46	FUNCTION quasiquote(ast integer) RETURN integer IS
	47	a0 integer;
	48	a00 integer;
	49	BEGIN
	50	IF NOT is_pair(ast) THEN
	51	RETURN types.list(M, types.symbol(M, 'quote'), ast);
	52	ELSE
	53	a0 := types.nth(M, ast, 0);
	54	IF M(a0).type_id = 7 AND
2866f9a8	55	TREAT(m(a0) AS mal_str_T).val_str = 'unquote' THEN
10cc781f JM	56	RETURN types.nth(M, ast, 1);
	57	ELSIF is_pair(a0) THEN
	58	a00 := types.nth(M, a0, 0);
	59	IF M(a00).type_id = 7 AND
2866f9a8	60	TREAT(M(a00) AS mal_str_T).val_str = 'splice-unquote' THEN
10cc781f JM	61	RETURN types.list(M, types.symbol(M, 'concat'),
	62	types.nth(M, a0, 1),
	63	quasiquote(types.slice(M, ast, 1)));
	64	END IF;
	65	END IF;
	66	RETURN types.list(M, types.symbol(M, 'cons'),
	67	quasiquote(a0),
	68	quasiquote(types.slice(M, ast, 1)));
	69	END IF;
	70	END;
	71
	72
	73	FUNCTION is_macro_call(ast integer, env integer) RETURN BOOLEAN IS
	74	a0 integer;
	75	mac integer;
	76	BEGIN
	77	IF M(ast).type_id = 8 THEN
	78	a0 := types.nth(M, ast, 0);
	79	IF M(a0).type_id = 7 AND
	80	env_pkg.env_find(M, E, env, a0) IS NOT NULL THEN
	81	mac := env_pkg.env_get(M, E, env, a0);
	82	IF M(mac).type_id = 12 THEN
2866f9a8	83	RETURN TREAT(M(mac) AS mal_func_T).is_macro > 0;
10cc781f JM	84	END IF;
	85	END IF;
	86	END IF;
	87	RETURN FALSE;
	88	END;
	89
	90	FUNCTION macroexpand(orig_ast integer, env integer) RETURN integer IS
	91	ast integer;
	92	mac integer;
2866f9a8 JM	93	malfn mal_func_T;
2866f9a8 JM	94	fargs mal_vals;
10cc781f JM	95	fn_env integer;
	96	BEGIN
	97	ast := orig_ast;
	98	WHILE is_macro_call(ast, env) LOOP
	99	mac := env_pkg.env_get(M, E, env, types.nth(M, ast, 0));
2866f9a8	100	fargs := TREAT(M(types.slice(M, ast, 1)) as mal_seq_T).val_seq;
10cc781f	101	if M(mac).type_id = 12 THEN
2866f9a8	102	malfn := TREAT(M(mac) AS mal_func_T);
10cc781f JM	103	fn_env := env_pkg.env_new(M, E, malfn.env,
	104	malfn.params,
	105	fargs);
	106	ast := EVAL(malfn.ast, fn_env);
	107	ELSE
	108	ast := do_builtin(mac, fargs);
	109	END IF;
	110	END LOOP;
	111	RETURN ast;
	112	END;
	113
	114	FUNCTION eval_ast(ast integer, env integer) RETURN integer IS
6a085103	115	i integer;
2866f9a8 JM	116	old_seq mal_vals;
2866f9a8 JM	117	new_seq mal_vals;
6a085103 JM	118	new_hm integer;
	119	old_midx integer;
	120	new_midx integer;
	121	k varchar2(256);
10cc781f JM	122	BEGIN
	123	IF M(ast).type_id = 7 THEN
	124	RETURN env_pkg.env_get(M, E, env, ast);
	125	ELSIF M(ast).type_id IN (8,9) THEN
2866f9a8 JM	126	old_seq := TREAT(M(ast) AS mal_seq_T).val_seq;
2866f9a8 JM	127	new_seq := mal_vals();
10cc781f JM	128	new_seq.EXTEND(old_seq.COUNT);
	129	FOR i IN 1..old_seq.COUNT LOOP
	130	new_seq(i) := EVAL(old_seq(i), env);
	131	END LOOP;
	132	RETURN types.seq(M, M(ast).type_id, new_seq);
6a085103	133	ELSIF M(ast).type_id IN (10) THEN
2866f9a8 JM	134	new_hm := types.hash_map(M, H, mal_vals());
	135	old_midx := TREAT(M(ast) AS mal_map_T).map_idx;
	136	new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx;
6a085103 JM	137
	138	k := H(old_midx).FIRST();
	139	WHILE k IS NOT NULL LOOP
	140	H(new_midx)(k) := EVAL(H(old_midx)(k), env);
	141	k := H(old_midx).NEXT(k);
	142	END LOOP;
	143	RETURN new_hm;
10cc781f JM	144	ELSE
	145	RETURN ast;
	146	END IF;
	147	END;
	148
	149	FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS
	150	ast integer := orig_ast;
	151	env integer := orig_env;
	152	el integer;
	153	a0 integer;
	154	a0sym varchar2(100);
2866f9a8	155	seq mal_vals;
10cc781f JM	156	let_env integer;
	157	try_env integer;
	158	i integer;
	159	f integer;
	160	cond integer;
2866f9a8 JM	161	malfn mal_func_T;
2866f9a8 JM	162	args mal_vals;
10cc781f JM	163	BEGIN
10cc781f JM	164	WHILE TRUE LOOP
02936b42	165	-- io.writeline('EVAL: ' \|\| printer.pr_str(M, H, ast));
10cc781f JM	166	IF M(ast).type_id <> 8 THEN
	167	RETURN eval_ast(ast, env);
	168	END IF;
	169
	170	-- apply
	171	ast := macroexpand(ast, env);
	172	IF M(ast).type_id <> 8 THEN
	173	RETURN eval_ast(ast, env);
	174	END IF;
	175	IF types.count(M, ast) = 0 THEN
6a085103	176	RETURN ast; -- empty list just returned
10cc781f JM	177	END IF;
10cc781f JM	178
6a085103	179	-- apply
10cc781f JM	180	a0 := types.first(M, ast);
10cc781f JM	181	if M(a0).type_id = 7 THEN -- symbol
2866f9a8	182	a0sym := TREAT(M(a0) AS mal_str_T).val_str;
10cc781f JM	183	ELSE
	184	a0sym := '__<fn>__';
	185	END IF;
	186
	187	CASE
	188	WHEN a0sym = 'def!' THEN
	189	RETURN env_pkg.env_set(M, E, env,
	190	types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env));
	191	WHEN a0sym = 'let*' THEN
	192	let_env := env_pkg.env_new(M, E, env);
2866f9a8	193	seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq;
10cc781f JM	194	i := 1;
	195	WHILE i <= seq.COUNT LOOP
	196	x := env_pkg.env_set(M, E, let_env,
	197	seq(i), EVAL(seq(i+1), let_env));
	198	i := i + 2;
	199	END LOOP;
	200	env := let_env;
	201	ast := types.nth(M, ast, 2); -- TCO
	202	WHEN a0sym = 'quote' THEN
	203	RETURN types.nth(M, ast, 1);
	204	WHEN a0sym = 'quasiquote' THEN
	205	RETURN EVAL(quasiquote(types.nth(M, ast, 1)), env);
	206	WHEN a0sym = 'defmacro!' THEN
	207	x := EVAL(types.nth(M, ast, 2), env);
2866f9a8	208	malfn := TREAT(M(x) as mal_func_T);
10cc781f JM	209	malfn.is_macro := 1;
	210	M(x) := malfn;
	211	RETURN env_pkg.env_set(M, E, env,
	212	types.nth(M, ast, 1), x);
	213	WHEN a0sym = 'macroexpand' THEN
	214	RETURN macroexpand(types.nth(M, ast, 1), env);
	215	WHEN a0sym = 'try*' THEN
	216	DECLARE
	217	exc integer;
	218	a2 integer := -1;
	219	a20 integer := -1;
	220	a20sym varchar2(100);
	221	BEGIN
	222	RETURN EVAL(types.nth(M, ast, 1), env);
	223
	224	EXCEPTION WHEN OTHERS THEN
	225	IF types.count(M, ast) > 2 THEN
	226	a2 := types.nth(M, ast, 2);
	227	IF M(a2).type_id = 8 THEN
	228	a20 := types.nth(M, a2, 0);
	229	IF M(a20).type_id = 7 THEN
2866f9a8	230	a20sym := TREAT(M(a20) AS mal_str_T).val_str;
10cc781f JM	231	END IF;
	232	END IF;
	233	END IF;
	234	IF a20sym = 'catch*' THEN
	235	IF SQLCODE <> -20000 THEN
	236	IF SQLCODE < -20000 AND SQLCODE > -20100 THEN
	237	exc := types.string(M,
	238	REGEXP_REPLACE(SQLERRM,
	239	'^ORA-200[0-9][0-9]: '));
	240	ELSE
	241	exc := types.string(M, SQLERRM);
	242	END IF;
	243	ELSE -- mal throw
	244	exc := err_val;
	245	err_val := NULL;
	246	END IF;
	247	try_env := env_pkg.env_new(M, E, env,
	248	types.list(M, types.nth(M, a2, 1)),
2866f9a8	249	mal_vals(exc));
10cc781f JM	250	RETURN EVAL(types.nth(M, a2, 2), try_env);
	251	END IF;
	252	RAISE; -- not handled, re-raise the exception
	253	END;
	254	WHEN a0sym = 'do' THEN
	255	x := types.slice(M, ast, 1, types.count(M, ast)-2);
	256	x := eval_ast(x, env);
	257	ast := types.nth(M, ast, types.count(M, ast)-1); -- TCO
	258	WHEN a0sym = 'if' THEN
	259	cond := EVAL(types.nth(M, ast, 1), env);
	260	IF cond = 1 OR cond = 2 THEN -- nil or false
	261	IF types.count(M, ast) > 3 THEN
6a085103	262	ast := types.nth(M, ast, 3); -- TCO
10cc781f JM	263	ELSE
	264	RETURN 1; -- nil
	265	END IF;
	266	ELSE
6a085103	267	ast := types.nth(M, ast, 2); -- TCO
10cc781f JM	268	END IF;
	269	WHEN a0sym = 'fn*' THEN
	270	RETURN types.malfunc(M, types.nth(M, ast, 2),
	271	types.nth(M, ast, 1),
	272	env);
	273	ELSE
	274	el := eval_ast(ast, env);
	275	f := types.first(M, el);
2866f9a8	276	args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq;
10cc781f	277	IF M(f).type_id = 12 THEN
2866f9a8	278	malfn := TREAT(M(f) AS mal_func_T);
10cc781f JM	279	env := env_pkg.env_new(M, E, malfn.env,
	280	malfn.params, args);
	281	ast := malfn.ast; -- TCO
	282	ELSE
	283	RETURN do_builtin(f, args);
	284	END IF;
	285	END CASE;
	286
	287	END LOOP;
	288
	289	END;
	290
	291	-- hack to get around lack of function references
	292	-- functions that require special access to repl_env or EVAL
	293	-- are implemented directly here, otherwise, core.do_core_fn
	294	-- is called.
2866f9a8	295	FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer IS
10cc781f JM	296	fname varchar2(100);
	297	val integer;
	298	f integer;
2866f9a8 JM	299	malfn mal_func_T;
2866f9a8 JM	300	fargs mal_vals;
10cc781f JM	301	fn_env integer;
10cc781f JM	302	i integer;
2866f9a8	303	tseq mal_vals;
10cc781f	304	BEGIN
2866f9a8	305	fname := TREAT(M(fn) AS mal_str_T).val_str;
10cc781f JM	306	CASE
	307	WHEN fname = 'do_eval' THEN
	308	RETURN EVAL(args(1), repl_env);
	309	WHEN fname = 'swap!' THEN
2866f9a8	310	val := TREAT(M(args(1)) AS mal_atom_T).val;
10cc781f JM	311	f := args(2);
	312	-- slice one extra at the beginning that will be changed
	313	-- to the value of the atom
2866f9a8	314	fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_T).val_seq;
10cc781f JM	315	fargs(1) := val;
10cc781f JM	316	IF M(f).type_id = 12 THEN
2866f9a8	317	malfn := TREAT(M(f) AS mal_func_T);
10cc781f JM	318	fn_env := env_pkg.env_new(M, E, malfn.env,
	319	malfn.params, fargs);
	320	val := EVAL(malfn.ast, fn_env);
	321	ELSE
	322	val := do_builtin(f, fargs);
	323	END IF;
2866f9a8	324	RETURN types.atom_reset(M, args(1), val);
10cc781f JM	325	WHEN fname = 'apply' THEN
10cc781f JM	326	f := args(1);
2866f9a8 JM	327	fargs := mal_vals();
2866f9a8 JM	328	tseq := TREAT(M(args(args.COUNT())) AS mal_seq_T).val_seq;
10cc781f JM	329	fargs.EXTEND(args.COUNT()-2 + tseq.COUNT());
	330	FOR i IN 1..args.COUNT()-2 LOOP
	331	fargs(i) := args(i+1);
	332	END LOOP;
	333	FOR i IN 1..tseq.COUNT() LOOP
	334	fargs(args.COUNT()-2 + i) := tseq(i);
	335	END LOOP;
	336	IF M(f).type_id = 12 THEN
2866f9a8	337	malfn := TREAT(M(f) AS mal_func_T);
10cc781f JM	338	fn_env := env_pkg.env_new(M, E, malfn.env,
	339	malfn.params, fargs);
	340	val := EVAL(malfn.ast, fn_env);
	341	ELSE
	342	val := do_builtin(f, fargs);
	343	END IF;
	344	RETURN val;
	345	WHEN fname = 'map' THEN
	346	f := args(1);
2866f9a8 JM	347	fargs := TREAT(M(args(2)) AS mal_seq_T).val_seq;
2866f9a8 JM	348	tseq := mal_vals();
10cc781f JM	349	tseq.EXTEND(fargs.COUNT());
10cc781f JM	350	IF M(f).type_id = 12 THEN
2866f9a8	351	malfn := TREAT(M(f) AS mal_func_T);
10cc781f JM	352	FOR i IN 1..fargs.COUNT() LOOP
	353	fn_env := env_pkg.env_new(M, E, malfn.env,
	354	malfn.params,
2866f9a8	355	mal_vals(fargs(i)));
10cc781f JM	356	tseq(i) := EVAL(malfn.ast, fn_env);
	357	END LOOP;
	358	ELSE
	359	FOR i IN 1..fargs.COUNT() LOOP
	360	tseq(i) := do_builtin(f,
2866f9a8	361	mal_vals(fargs(i)));
10cc781f JM	362	END LOOP;
	363	END IF;
	364	RETURN types.seq(M, 8, tseq);
	365	WHEN fname = 'throw' THEN
	366	err_val := args(1);
	367	raise_application_error(-20000, 'MalException', TRUE);
	368	ELSE
6a085103	369	RETURN core.do_core_func(M, H, fn, args);
10cc781f JM	370	END CASE;
	371	END;
	372
	373
	374	-- print
	375	FUNCTION PRINT(exp integer) RETURN varchar IS
	376	BEGIN
6a085103	377	RETURN printer.pr_str(M, H, exp);
10cc781f JM	378	END;
	379
	380	-- repl
	381	FUNCTION REP(line varchar) RETURN varchar IS
	382	BEGIN
	383	RETURN PRINT(EVAL(READ(line), repl_env));
	384	END;
	385
	386	BEGIN
6a085103	387	-- initialize memory pools
10cc781f	388	M := types.mem_new();
6a085103	389	H := types.map_entry_table();
10cc781f JM	390	E := env_pkg.env_entry_table();
	391
	392	repl_env := env_pkg.env_new(M, E, NULL);
	393
2866f9a8	394	argv := TREAT(M(reader.read_str(M, H, args)) AS mal_seq_T).val_seq;
10cc781f JM	395
	396	-- core.EXT: defined using PL/SQL
	397	core_ns := core.get_core_ns();
	398	FOR cidx IN 1..core_ns.COUNT LOOP
	399	x := env_pkg.env_set(M, E, repl_env,
	400	types.symbol(M, core_ns(cidx)),
	401	types.func(M, core_ns(cidx)));
	402	END LOOP;
	403	x := env_pkg.env_set(M, E, repl_env,
	404	types.symbol(M, 'eval'),
	405	types.func(M, 'do_eval'));
	406	x := env_pkg.env_set(M, E, repl_env,
	407	types.symbol(M, 'ARGV'),
	408	types.slice(M, argv, 1));
	409
	410	-- core.mal: defined using the language itself
	411	line := REP('(def! host-language "PL/SQL")');
	412	line := REP('(def! not (fn* (a) (if a false true)))');
	413	line := REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))');
	414	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)))))))');
	415	line := REP('(def! gensym-counter (atom 0))');
6a085103	416	line := REP('(def! gensym (fn* [] (symbol (str "G__" (swap! gensym-counter (fn* [x] (+ 1 x)))))))');
10cc781f JM	417	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)))))))))');
	418
	419	IF argv.COUNT() > 0 THEN
8119e744 JM	420	BEGIN
8119e744 JM	421	line := REP('(load-file "' \|\|
2866f9a8	422	TREAT(M(argv(1)) AS mal_str_T).val_str \|\|
8119e744 JM	423	'")');
	424	io.close(1); -- close output stream
	425	RETURN 0;
	426	EXCEPTION WHEN OTHERS THEN
	427	io.writeline('Error: ' \|\| SQLERRM);
	428	io.writeline(dbms_utility.format_error_backtrace);
	429	io.close(1); -- close output stream
	430	RAISE;
	431	END;
10cc781f JM	432	END IF;
	433
	434	line := REP('(println (str "Mal [" host-language "]"))');
	435	WHILE true LOOP
	436	BEGIN
02936b42	437	line := io.readline('user> ', 0);
8119e744	438	IF line = EMPTY_CLOB() THEN CONTINUE; END IF;
10cc781f	439	IF line IS NOT NULL THEN
02936b42	440	io.writeline(REP(line));
10cc781f JM	441	END IF;
	442
	443	EXCEPTION WHEN OTHERS THEN
8119e744 JM	444	IF SQLCODE = -20001 THEN -- io read stream closed
8119e744 JM	445	io.close(1); -- close output stream
10cc781f JM	446	RETURN 0;
10cc781f JM	447	END IF;
02936b42 JM	448	io.writeline('Error: ' \|\| SQLERRM);
02936b42 JM	449	io.writeline(dbms_utility.format_error_backtrace);
10cc781f JM	450	END;
	451	END LOOP;
	452	END;
	453
	454	END mal;
	455	/
	456	show errors;
	457
	458	quit;