kanaka/mal
1
1
Fork 0
mirror of https://github.com/kanaka/mal.git synced 2024-11-10 12:47:45 +03:00
Code Issues Projects Releases Wiki Activity

plsql: add step9 basics. Refactor arg list passing.

Browse Source
This commit is contained in:
Joel Martin 2016-04-28 22:36:24 -05:00
parent 0fc0391825
commit 150011e4b6
14 changed files with 550 additions and 99 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
plsql/core.sql
View File

@ -23,6 +23,14 @@ BEGIN
RETURN types.wraptf(types.equal_Q(M, args(1), args(2)));
END;
-- scalar functiosn
FUNCTION symbol(M IN OUT NOCOPY mem_type,
val integer) RETURN integer IS
BEGIN
RETURN types.symbol(M, TREAT(M(val) AS mal_str_type).val_str);
END;
-- string functions
FUNCTION pr_str(M IN OUT NOCOPY mem_type,
args mal_seq_items_type) RETURN integer IS
@ -179,6 +187,12 @@ BEGIN
CASE
WHEN fname = '=' THEN RETURN equal_Q(M, args);
WHEN fname = 'nil?' THEN RETURN types.wraptf(args(1) = 1);
WHEN fname = 'false?' THEN RETURN types.wraptf(args(1) = 2);
WHEN fname = 'true?' THEN RETURN types.wraptf(args(1) = 3);
WHEN fname = 'symbol' THEN RETURN symbol(M, args(1));
WHEN fname = 'symbol?' THEN RETURN types.wraptf(M(args(1)).type_id = 7);
WHEN fname = 'pr-str' THEN RETURN pr_str(M, args);
WHEN fname = 'str' THEN RETURN str(M, args);
WHEN fname = 'prn' THEN RETURN prn(M, args);
@ -243,6 +257,13 @@ FUNCTION get_core_ns RETURN core_ns_type IS
BEGIN
RETURN core_ns_type(
'=',
'throw',
'nil?',
'true?',
'false?',
'symbol',
'symbol?',
'pr-str',
'str',
@ -270,6 +291,8 @@ BEGIN
'rest',
'empty?',
'count',
'apply',
'map',
-- defined in step do_builtin function
'atom',

39
plsql/env.sql
View File

@ -25,9 +25,14 @@ CREATE OR REPLACE TYPE env_mem_type FORCE IS TABLE OF env_type;
CREATE OR REPLACE PACKAGE env_pkg IS
FUNCTION env_new(M IN OUT NOCOPY mem_type,
eM IN OUT NOCOPY env_mem_type,
outer_idx integer DEFAULT NULL,
binds integer DEFAULT NULL,
exprs mal_seq_type DEFAULT NULL) RETURN integer;
outer_idx integer DEFAULT NULL)
RETURN integer;
FUNCTION env_new(M IN OUT NOCOPY mem_type,
eM IN OUT NOCOPY env_mem_type,
outer_idx integer,
binds integer,
exprs mal_seq_items_type)
RETURN integer;
FUNCTION env_set(M IN OUT NOCOPY mem_type,
eM IN OUT NOCOPY env_mem_type,
eidx integer,
@ -43,36 +48,48 @@ CREATE OR REPLACE PACKAGE env_pkg IS
key integer) RETURN integer;
END env_pkg;
/
show errors;
CREATE OR REPLACE PACKAGE BODY env_pkg IS
FUNCTION env_new(M IN OUT NOCOPY mem_type,
eM IN OUT NOCOPY env_mem_type,
outer_idx integer DEFAULT NULL,
binds integer DEFAULT NULL,
exprs mal_seq_type DEFAULT NULL) RETURN integer IS
outer_idx integer DEFAULT NULL)
RETURN integer IS
eidx integer;
BEGIN
eM.EXTEND();
eidx := eM.COUNT();
eM(eidx) := env_type(eidx, outer_idx, env_data());
RETURN eidx;
END;
FUNCTION env_new(M IN OUT NOCOPY mem_type,
eM IN OUT NOCOPY env_mem_type,
outer_idx integer,
binds integer,
exprs mal_seq_items_type)
RETURN integer IS
eidx integer;
ed env_data;
i integer;
bs mal_seq_items_type;
es mal_seq_items_type;
BEGIN
eM.EXTEND();
eidx := eM.COUNT;
eidx := eM.COUNT();
ed := env_data();
IF binds IS NOT NULL THEN
bs := TREAT(M(binds) AS mal_seq_type).val_seq;
es := exprs.val_seq;
FOR i IN 1..bs.COUNT LOOP
ed.EXTEND();
IF TREAT(M(bs(i)) AS mal_str_type).val_str = '&' THEN
ed(ed.COUNT) := env_item(
TREAT(M(bs(i+1)) AS mal_str_type).val_str,
types.slice(M, es, i-1));
types.slice(M, exprs, i-1));
EXIT;
ELSE
ed(ed.COUNT) := env_item(
TREAT(M(bs(i)) AS mal_str_type).val_str,
es(i));
exprs(i));
END IF;
END LOOP;
END IF;

4
plsql/io.sql
View File

@ -84,7 +84,7 @@ BEGIN
-- '' -> no input, NULL -> stream closed
--RAISE NOTICE 'read input: [%] %', input, stream_id;
IF isopen = 0 THEN
raise_application_error(-20000,
raise_application_error(-20001,
'stream_read: stream ''' || sid || ''' is closed', TRUE);
END IF;
SYS.DBMS_LOCK.SLEEP(sleep);
@ -148,7 +148,7 @@ BEGIN
SELECT count(data) INTO datas FROM stream WHERE data IS NOT NULL;
IF isopen = 0 THEN
raise_application_error(-20000,
raise_application_error(-20001,
'stream_wait_rl_prompt: stream ''' || sid || ''' is closed', TRUE);
END IF;

6
plsql/reader.sql
View File

@ -112,14 +112,14 @@ FUNCTION read_seq(M IN OUT NOCOPY mem_type,
BEGIN
token := rdr.next();
IF token <> first THEN
raise_application_error(-20002,
raise_application_error(-20003,
'expected ''' || first || '''', TRUE);
END IF;
items := mal_seq_items_type();
LOOP
token := rdr.peek();
IF token IS NULL THEN
raise_application_error(-20002,
raise_application_error(-20003,
'expected ''' || last || '''', TRUE);
END IF;
IF token = last THEN EXIT; END IF;
@ -176,7 +176,7 @@ BEGIN
-- list
WHEN token = ')' THEN
raise_application_error(-20001,
raise_application_error(-20002,
'unexpected '')''', TRUE);
WHEN token = '(' THEN
RETURN read_seq(M, rdr, 8, '(', ')');

2
plsql/step0_repl.sql
View File

@ -47,7 +47,7 @@ BEGIN
END IF;
EXCEPTION WHEN OTHERS THEN
IF SQLCODE = -20000 THEN
IF SQLCODE = -20001 THEN -- io streams closed
RETURN 0;
END IF;
stream_writeline('Error: ' || SQLERRM);

2
plsql/step1_read_print.sql
View File

@ -52,7 +52,7 @@ BEGIN
END IF;
EXCEPTION WHEN OTHERS THEN
IF SQLCODE = -20000 THEN
IF SQLCODE = -20001 THEN -- io streams closed
RETURN 0;
END IF;
stream_writeline('Error: ' || SQLERRM);

8
plsql/step2_eval.sql
View File

@ -54,7 +54,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
FUNCTION EVAL(ast integer, env env_type) RETURN integer IS
el integer;
f integer;
args mal_seq_type;
args mal_seq_items_type;
BEGIN
IF M(ast).type_id <> 8 THEN
RETURN eval_ast(ast, env);
@ -63,8 +63,8 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
-- apply
el := eval_ast(ast, env);
f := types.first(M, el);
args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_type);
RETURN do_core_func(f, args.val_seq);
args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_type).val_seq;
RETURN do_core_func(f, args);
END;
-- print
@ -140,7 +140,7 @@ BEGIN
END IF;
EXCEPTION WHEN OTHERS THEN
IF SQLCODE = -20000 THEN
IF SQLCODE = -20001 THEN -- io streams closed
RETURN 0;
END IF;
stream_writeline('Error: ' || SQLERRM);

10
plsql/step3_env.sql
View File

@ -56,12 +56,12 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
FUNCTION EVAL(ast integer, env integer) RETURN integer IS
el integer;
a0 integer;
a0sym varchar2(4000);
a0sym varchar2(100);
seq mal_seq_items_type;
let_env integer;
i integer;
f integer;
args mal_seq_type;
args mal_seq_items_type;
BEGIN
IF M(ast).type_id <> 8 THEN
RETURN eval_ast(ast, env);
@ -92,8 +92,8 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
ELSE
el := eval_ast(ast, env);
f := types.first(M, el);
args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_type);
RETURN do_core_func(f, args.val_seq);
args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_type).val_seq;
RETURN do_core_func(f, args);
END CASE;
END;
@ -177,7 +177,7 @@ BEGIN
END IF;
EXCEPTION WHEN OTHERS THEN
IF SQLCODE = -20000 THEN
IF SQLCODE = -20001 THEN -- io streams closed
RETURN 0;
END IF;
stream_writeline('Error: ' || SQLERRM);

11
plsql/step4_if_fn_do.sql
View File

@ -57,7 +57,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
FUNCTION EVAL(ast integer, env integer) RETURN integer IS
el integer;
a0 integer;
a0sym varchar2(4000);
a0sym varchar2(100);
seq mal_seq_items_type;
let_env integer;
i integer;
@ -65,7 +65,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
fn_env integer;
cond integer;
malfn malfunc_type;
args mal_seq_type;
args mal_seq_items_type;
BEGIN
IF M(ast).type_id <> 8 THEN
RETURN eval_ast(ast, env);
@ -114,14 +114,14 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
ELSE
el := eval_ast(ast, env);
f := types.first(M, el);
args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_type);
args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_type).val_seq;
IF M(f).type_id = 12 THEN
malfn := TREAT(M(f) AS malfunc_type);
fn_env := env_pkg.env_new(M, env_mem, malfn.env,
malfn.params, args);
RETURN EVAL(malfn.ast, fn_env);
ELSE
RETURN core.do_core_func(M, f, args.val_seq);
RETURN core.do_core_func(M, f, args);
END IF;
END CASE;
@ -133,6 +133,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
RETURN printer.pr_str(M, exp);
END;
-- repl
FUNCTION REP(line varchar) RETURN varchar IS
BEGIN
RETURN PRINT(EVAL(READ(line), repl_env));
@ -164,7 +165,7 @@ BEGIN
END IF;
EXCEPTION WHEN OTHERS THEN
IF SQLCODE = -20000 THEN
IF SQLCODE = -20001 THEN -- io streams closed
RETURN 0;
END IF;
stream_writeline('Error: ' || SQLERRM);

10
plsql/step5_tco.sql
View File

@ -59,14 +59,14 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
env integer := orig_env;
el integer;
a0 integer;
a0sym varchar2(4000);
a0sym varchar2(100);
seq mal_seq_items_type;
let_env integer;
i integer;
f integer;
cond integer;
malfn malfunc_type;
args mal_seq_type;
args mal_seq_items_type;
BEGIN
WHILE TRUE LOOP
IF M(ast).type_id <> 8 THEN
@ -118,14 +118,14 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
ELSE
el := eval_ast(ast, env);
f := types.first(M, el);
args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_type);
args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_type).val_seq;
IF M(f).type_id = 12 THEN
malfn := TREAT(M(f) AS malfunc_type);
env := env_pkg.env_new(M, env_mem, malfn.env,
malfn.params, args);
ast := malfn.ast; -- TCO
ELSE
RETURN core.do_core_func(M, f, args.val_seq);
RETURN core.do_core_func(M, f, args);
END IF;
END CASE;
@ -171,7 +171,7 @@ BEGIN
END IF;
EXCEPTION WHEN OTHERS THEN
IF SQLCODE = -20000 THEN
IF SQLCODE = -20001 THEN -- io streams closed
RETURN 0;
END IF;
stream_writeline('Error: ' || SQLERRM);

38
plsql/step6_file.sql
View File

@ -33,7 +33,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
-- forward declarations
FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer;
FUNCTION do_builtin(fn integer, args mal_seq_type) RETURN integer;
FUNCTION do_builtin(fn integer, args mal_seq_items_type) RETURN integer;
FUNCTION eval_ast(ast integer, env integer) RETURN integer IS
i integer;
@ -60,14 +60,14 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
env integer := orig_env;
el integer;
a0 integer;
a0sym varchar2(4000);
a0sym varchar2(100);
seq mal_seq_items_type;
let_env integer;
i integer;
f integer;
cond integer;
malfn malfunc_type;
args mal_seq_type;
args mal_seq_items_type;
BEGIN
WHILE TRUE LOOP
IF M(ast).type_id <> 8 THEN
@ -119,7 +119,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
ELSE
el := eval_ast(ast, env);
f := types.first(M, el);
args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_type);
args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_type).val_seq;
IF M(f).type_id = 12 THEN
malfn := TREAT(M(f) AS malfunc_type);
env := env_pkg.env_new(M, env_mem, malfn.env,
@ -138,10 +138,9 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
-- 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_seq_type) RETURN integer IS
FUNCTION do_builtin(fn integer, args mal_seq_items_type) RETURN integer IS
fname varchar2(100);
sargs mal_seq_items_type := args.val_seq;
aval integer;
val integer;
f integer;
malfn malfunc_type;
fargs mal_seq_items_type;
@ -150,27 +149,26 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
fname := TREAT(M(fn) AS mal_str_type).val_str;
CASE
WHEN fname = 'do_eval' THEN
RETURN EVAL(sargs(1), repl_env);
RETURN EVAL(args(1), repl_env);
WHEN fname = 'swap!' THEN
aval := TREAT(M(sargs(1)) AS mal_atom_type).val;
f := sargs(2);
val := TREAT(M(args(1)) AS mal_atom_type).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, sargs, 1)) AS mal_seq_type).val_seq;
fargs(1) := aval;
fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_type).val_seq;
fargs(1) := val;
IF M(f).type_id = 12 THEN
malfn := TREAT(M(f) AS malfunc_type);
fn_env := env_pkg.env_new(M, env_mem, malfn.env,
malfn.params,
mal_seq_type(8, fargs));
aval := EVAL(malfn.ast, fn_env);
malfn.params, fargs);
val := EVAL(malfn.ast, fn_env);
ELSE
aval := do_builtin(f, mal_seq_type(8, fargs));
val := do_builtin(f, fargs);
END IF;
M(sargs(1)) := mal_atom_type(13, aval);
RETURN aval;
M(args(1)) := mal_atom_type(13, val);
RETURN val;
ELSE
RETURN core.do_core_func(M, fn, sargs);
RETURN core.do_core_func(M, fn, args);
END CASE;
END;
@ -220,7 +218,7 @@ BEGIN
END IF;
EXCEPTION WHEN OTHERS THEN
IF SQLCODE = -20000 THEN
IF SQLCODE = -20001 THEN -- io streams closed
RETURN 0;
END IF;
stream_writeline('Error: ' || SQLERRM);

38
plsql/step7_quote.sql
View File

@ -33,7 +33,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
-- forward declarations
FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer;
FUNCTION do_builtin(fn integer, args mal_seq_type) RETURN integer;
FUNCTION do_builtin(fn integer, args mal_seq_items_type) RETURN integer;
FUNCTION is_pair(ast integer) RETURN BOOLEAN IS
BEGIN
@ -91,14 +91,14 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
env integer := orig_env;
el integer;
a0 integer;
a0sym varchar2(4000);
a0sym varchar2(100);
seq mal_seq_items_type;
let_env integer;
i integer;
f integer;
cond integer;
malfn malfunc_type;
args mal_seq_type;
args mal_seq_items_type;
BEGIN
WHILE TRUE LOOP
IF M(ast).type_id <> 8 THEN
@ -154,7 +154,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
ELSE
el := eval_ast(ast, env);
f := types.first(M, el);
args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_type);
args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_type).val_seq;
IF M(f).type_id = 12 THEN
malfn := TREAT(M(f) AS malfunc_type);
env := env_pkg.env_new(M, env_mem, malfn.env,
@ -173,10 +173,9 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
-- 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_seq_type) RETURN integer IS
FUNCTION do_builtin(fn integer, args mal_seq_items_type) RETURN integer IS
fname varchar2(100);
sargs mal_seq_items_type := args.val_seq;
aval integer;
val integer;
f integer;
malfn malfunc_type;
fargs mal_seq_items_type;
@ -185,27 +184,26 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
fname := TREAT(M(fn) AS mal_str_type).val_str;
CASE
WHEN fname = 'do_eval' THEN
RETURN EVAL(sargs(1), repl_env);
RETURN EVAL(args(1), repl_env);
WHEN fname = 'swap!' THEN
aval := TREAT(M(sargs(1)) AS mal_atom_type).val;
f := sargs(2);
val := TREAT(M(args(1)) AS mal_atom_type).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, sargs, 1)) AS mal_seq_type).val_seq;
fargs(1) := aval;
fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_type).val_seq;
fargs(1) := val;
IF M(f).type_id = 12 THEN
malfn := TREAT(M(f) AS malfunc_type);
fn_env := env_pkg.env_new(M, env_mem, malfn.env,
malfn.params,
mal_seq_type(8, fargs));
aval := EVAL(malfn.ast, fn_env);
malfn.params, fargs);
val := EVAL(malfn.ast, fn_env);
ELSE
aval := do_builtin(f, mal_seq_type(8, fargs));
val := do_builtin(f, fargs);
END IF;
M(sargs(1)) := mal_atom_type(13, aval);
RETURN aval;
M(args(1)) := mal_atom_type(13, val);
RETURN val;
ELSE
RETURN core.do_core_func(M, fn, sargs);
RETURN core.do_core_func(M, fn, args);
END CASE;
END;
@ -255,7 +253,7 @@ BEGIN
END IF;
EXCEPTION WHEN OTHERS THEN
IF SQLCODE = -20000 THEN
IF SQLCODE = -20001 THEN -- io streams closed
RETURN 0;
END IF;
stream_writeline('Error: ' || SQLERRM);

42
plsql/step8_macros.sql
View File

@ -33,7 +33,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
-- forward declarations
FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer;
FUNCTION do_builtin(fn integer, args mal_seq_type) RETURN integer;
FUNCTION do_builtin(fn integer, args mal_seq_items_type) RETURN integer;
FUNCTION is_pair(ast integer) RETURN BOOLEAN IS
BEGIN
@ -88,13 +88,13 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
ast integer;
mac integer;
malfn malfunc_type;
fargs mal_seq_type;
fargs mal_seq_items_type;
fn_env integer;
BEGIN
ast := orig_ast;
WHILE is_macro_call(ast, env) LOOP
mac := env_pkg.env_get(M, env_mem, env, types.nth(M, ast, 0));
fargs := TREAT(M(types.slice(M, ast, 1)) as mal_seq_type);
fargs := TREAT(M(types.slice(M, ast, 1)) as mal_seq_type).val_seq;
if M(mac).type_id = 12 THEN
malfn := TREAT(M(mac) AS malfunc_type);
fn_env := env_pkg.env_new(M, env_mem, malfn.env,
@ -133,14 +133,14 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
env integer := orig_env;
el integer;
a0 integer;
a0sym varchar2(4000);
a0sym varchar2(100);
seq mal_seq_items_type;
let_env integer;
i integer;
f integer;
cond integer;
malfn malfunc_type;
args mal_seq_type;
args mal_seq_items_type;
BEGIN
WHILE TRUE LOOP
IF M(ast).type_id <> 8 THEN
@ -213,7 +213,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
ELSE
el := eval_ast(ast, env);
f := types.first(M, el);
args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_type);
args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_type).val_seq;
IF M(f).type_id = 12 THEN
malfn := TREAT(M(f) AS malfunc_type);
env := env_pkg.env_new(M, env_mem, malfn.env,
@ -232,10 +232,9 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
-- 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_seq_type) RETURN integer IS
FUNCTION do_builtin(fn integer, args mal_seq_items_type) RETURN integer IS
fname varchar2(100);
sargs mal_seq_items_type := args.val_seq;
aval integer;
val integer;
f integer;
malfn malfunc_type;
fargs mal_seq_items_type;
@ -244,27 +243,26 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
fname := TREAT(M(fn) AS mal_str_type).val_str;
CASE
WHEN fname = 'do_eval' THEN
RETURN EVAL(sargs(1), repl_env);
RETURN EVAL(args(1), repl_env);
WHEN fname = 'swap!' THEN
aval := TREAT(M(sargs(1)) AS mal_atom_type).val;
f := sargs(2);
val := TREAT(M(args(1)) AS mal_atom_type).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, sargs, 1)) AS mal_seq_type).val_seq;
fargs(1) := aval;
fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_type).val_seq;
fargs(1) := val;
IF M(f).type_id = 12 THEN
malfn := TREAT(M(f) AS malfunc_type);
fn_env := env_pkg.env_new(M, env_mem, malfn.env,
malfn.params,
mal_seq_type(8, fargs));
aval := EVAL(malfn.ast, fn_env);
malfn.params, fargs);
val := EVAL(malfn.ast, fn_env);
ELSE
aval := do_builtin(f, mal_seq_type(8, fargs));
val := do_builtin(f, fargs);
END IF;
M(sargs(1)) := mal_atom_type(13, aval);
RETURN aval;
M(args(1)) := mal_atom_type(13, val);
RETURN val;
ELSE
RETURN core.do_core_func(M, fn, sargs);
RETURN core.do_core_func(M, fn, args);
END CASE;
END;
@ -316,7 +314,7 @@ BEGIN
END IF;
EXCEPTION WHEN OTHERS THEN
IF SQLCODE = -20000 THEN
IF SQLCODE = -20001 THEN -- io streams closed
RETURN 0;
END IF;
stream_writeline('Error: ' || SQLERRM);

416
plsql/step9_try.sql Normal file
View File

@ -0,0 +1,416 @@
@io.sql
@types.sql
@reader.sql
@printer.sql
@env.sql
@core.sql
CREATE OR REPLACE PACKAGE mal IS
FUNCTION MAIN(pwd varchar) RETURN integer;
END mal;
/
CREATE OR REPLACE PACKAGE BODY mal IS
FUNCTION MAIN(pwd varchar) RETURN integer IS
M mem_type;
env_mem env_mem_type;
repl_env integer;
x integer;
line varchar2(4000);
core_ns core_ns_type;
cidx integer;
err_val integer;
-- read
FUNCTION READ(line varchar) RETURN integer IS
BEGIN
RETURN reader.read_str(M, line);
END;
-- eval
-- forward declarations
FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer;
FUNCTION do_builtin(fn integer, args mal_seq_items_type) 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_type).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_type).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, env_mem, env, a0) IS NOT NULL THEN
mac := env_pkg.env_get(M, env_mem, env, a0);
IF M(mac).type_id = 12 THEN
RETURN TREAT(M(mac) AS malfunc_type).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 malfunc_type;
fargs mal_seq_items_type;
fn_env integer;
BEGIN
ast := orig_ast;
WHILE is_macro_call(ast, env) LOOP
mac := env_pkg.env_get(M, env_mem, env, types.nth(M, ast, 0));
fargs := TREAT(M(types.slice(M, ast, 1)) as mal_seq_type).val_seq;
if M(mac).type_id = 12 THEN
malfn := TREAT(M(mac) AS malfunc_type);
fn_env := env_pkg.env_new(M, env_mem, 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_seq_items_type;
new_seq mal_seq_items_type;
BEGIN
IF M(ast).type_id = 7 THEN
RETURN env_pkg.env_get(M, env_mem, env, ast);
ELSIF M(ast).type_id IN (8,9) THEN
old_seq := TREAT(M(ast) AS mal_seq_type).val_seq;
new_seq := mal_seq_items_type();
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);
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_seq_items_type;
let_env integer;
try_env integer;
i integer;
f integer;
cond integer;
malfn malfunc_type;
args mal_seq_items_type;
BEGIN
WHILE TRUE LOOP
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;
END IF;
a0 := types.first(M, ast);
if M(a0).type_id = 7 THEN -- symbol
a0sym := TREAT(M(a0) AS mal_str_type).val_str;
ELSE
a0sym := '__<*fn*>__';
END IF;
CASE
WHEN a0sym = 'def!' THEN
RETURN env_pkg.env_set(M, env_mem, env,
types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env));
WHEN a0sym = 'let*' THEN
let_env := env_pkg.env_new(M, env_mem, env);
seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_type).val_seq;
i := 1;
WHILE i <= seq.COUNT LOOP
x := env_pkg.env_set(M, env_mem, 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 malfunc_type);
malfn.is_macro := 1;
M(x) := malfn;
RETURN env_pkg.env_set(M, env_mem, 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_type).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, env_mem, env,
types.list(M, types.nth(M, a2, 1)),
mal_seq_items_type(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 := EVAL(types.nth(M, ast, 3), env); -- TCO
ELSE
RETURN 1; -- nil
END IF;
ELSE
ast := EVAL(types.nth(M, ast, 2), env); -- 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_type).val_seq;
IF M(f).type_id = 12 THEN
malfn := TREAT(M(f) AS malfunc_type);
env := env_pkg.env_new(M, env_mem, 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_seq_items_type) RETURN integer IS
fname varchar2(100);
val integer;
f integer;
malfn malfunc_type;
fargs mal_seq_items_type;
fn_env integer;
i integer;
tseq mal_seq_items_type;
BEGIN
fname := TREAT(M(fn) AS mal_str_type).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_type).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_type).val_seq;
fargs(1) := val;
IF M(f).type_id = 12 THEN
malfn := TREAT(M(f) AS malfunc_type);
fn_env := env_pkg.env_new(M, env_mem, malfn.env,
malfn.params, fargs);
val := EVAL(malfn.ast, fn_env);
ELSE
val := do_builtin(f, fargs);
END IF;
M(args(1)) := mal_atom_type(13, val);
RETURN val;
WHEN fname = 'apply' THEN
f := args(1);
fargs := mal_seq_items_type();
tseq := TREAT(M(args(args.COUNT())) AS mal_seq_type).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 malfunc_type);
fn_env := env_pkg.env_new(M, env_mem, 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_type).val_seq;
tseq := mal_seq_items_type();
tseq.EXTEND(fargs.COUNT());
IF M(f).type_id = 12 THEN
malfn := TREAT(M(f) AS malfunc_type);
FOR i IN 1..fargs.COUNT() LOOP
fn_env := env_pkg.env_new(M, env_mem, malfn.env,
malfn.params,
mal_seq_items_type(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_seq_items_type(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, fn, args);
END CASE;
END;
-- print
FUNCTION PRINT(exp integer) RETURN varchar IS
BEGIN
RETURN printer.pr_str(M, exp);
END;
-- repl
FUNCTION REP(line varchar) RETURN varchar IS
BEGIN
RETURN PRINT(EVAL(READ(line), repl_env));
END;
BEGIN
M := types.mem_new();
env_mem := env_mem_type();
repl_env := env_pkg.env_new(M, env_mem, NULL);
-- 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, env_mem, repl_env,
types.symbol(M, core_ns(cidx)),
types.func(M, core_ns(cidx)));
END LOOP;
x := env_pkg.env_set(M, env_mem, repl_env,
types.symbol(M, 'eval'),
types.func(M, 'do_eval'));
x := env_pkg.env_set(M, env_mem, repl_env,
types.symbol(M, '*ARGV*'),
types.list(M));
-- core.mal: defined using the language itself
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('(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))');
WHILE true LOOP
BEGIN
line := stream_readline('user> ', 0);
IF line IS NULL THEN CONTINUE; END IF;
IF line IS NOT NULL THEN
stream_writeline(REP(line));
END IF;
EXCEPTION WHEN OTHERS THEN
IF SQLCODE = -20001 THEN -- io streams closed
RETURN 0;
END IF;
stream_writeline('Error: ' || SQLERRM);
stream_writeline(dbms_utility.format_error_backtrace);
END;
END LOOP;
END;
END mal;
/
show errors;
quit;