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

plsql: stepA basics. Fix step6 argument processing.

Browse Source
This commit is contained in:
Joel Martin 2016-04-29 00:11:59 -05:00
parent 150011e4b6
commit 10cc781f71
15 changed files with 669 additions and 192 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
plsql/core.sql
View File

@ -64,6 +64,20 @@ BEGIN
RETURN reader.read_str(M, TREAT(M(args(1)) AS mal_str_type).val_str);
END;
FUNCTION readline(M IN OUT NOCOPY mem_type,
prompt integer) RETURN integer IS
input varchar2(4000);
BEGIN
input := stream_readline(TREAT(M(prompt) AS mal_str_type).val_str, 0);
RETURN types.string(M, input);
EXCEPTION WHEN OTHERS THEN
IF SQLCODE = -20001 THEN -- io streams closed
RETURN 1; -- nil
ELSE
RAISE;
END IF;
END;
FUNCTION slurp(M IN OUT NOCOPY mem_type,
args mal_seq_items_type) RETURN integer IS
content varchar2(4000);
@ -132,6 +146,17 @@ BEGIN
TREAT(M(args(2)) AS mal_int_type).val_int);
END;
FUNCTION time_ms(M IN OUT NOCOPY mem_type) RETURN integer IS
now integer;
BEGIN
-- SELECT (SYSDATE - TO_DATE('01-01-1970 00:00:00', 'DD-MM-YYYY HH24:MI:SS')) * 24 * 60 * 60 * 1000
-- INTO now FROM DUAL;
SELECT extract(day from(sys_extract_utc(systimestamp) - to_timestamp('1970-01-01', 'YYYY-MM-DD'))) * 86400000 + to_number(to_char(sys_extract_utc(systimestamp), 'SSSSSFF3'))
INTO now
FROM dual;
RETURN types.int(M, now);
END;
-- sequence functions
FUNCTION cons(M IN OUT NOCOPY mem_type,
args mal_seq_items_type) RETURN integer IS
@ -198,6 +223,7 @@ BEGIN
WHEN fname = 'prn' THEN RETURN prn(M, args);
WHEN fname = 'println' THEN RETURN println(M, args);
WHEN fname = 'read-string' THEN RETURN read_string(M, args);
WHEN fname = 'readline' THEN RETURN readline(M, args(1));
WHEN fname = 'slurp' THEN RETURN slurp(M, args);
WHEN fname = '<' THEN RETURN lt(M, args);
@ -208,6 +234,7 @@ BEGIN
WHEN fname = '-' THEN RETURN subtract(M, args);
WHEN fname = '*' THEN RETURN multiply(M, args);
WHEN fname = '/' THEN RETURN divide(M, args);
WHEN fname = 'time-ms' THEN RETURN time_ms(M);
WHEN fname = 'list' THEN RETURN types.seq(M, 8, args);
WHEN fname = 'list?' THEN RETURN types.wraptf(M(args(1)).type_id = 8);
@ -270,6 +297,7 @@ BEGIN
'prn',
'println',
'read-string',
'readline',
'slurp',
'<',
@ -280,6 +308,7 @@ BEGIN
'-',
'*',
'/',
'time-ms',
'list',
'list?',

94
plsql/env.sql
View File

@ -23,27 +23,30 @@ CREATE OR REPLACE TYPE env_mem_type FORCE IS TABLE OF env_type;
/
CREATE OR REPLACE PACKAGE env_pkg IS
TYPE env_entry IS TABLE OF integer INDEX BY varchar2(256);
TYPE env_entry_table IS TABLE OF env_entry;
FUNCTION env_new(M IN OUT NOCOPY mem_type,
eM IN OUT NOCOPY env_mem_type,
eeT IN OUT NOCOPY env_entry_table,
outer_idx integer DEFAULT NULL)
RETURN integer;
FUNCTION env_new(M IN OUT NOCOPY mem_type,
eM IN OUT NOCOPY env_mem_type,
eeT IN OUT NOCOPY env_entry_table,
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,
eeT IN OUT NOCOPY env_entry_table,
eidx integer,
key integer,
val integer) RETURN integer;
FUNCTION env_find(M IN OUT NOCOPY mem_type,
eM env_mem_type,
eeT env_entry_table,
eidx integer,
key integer) RETURN integer;
FUNCTION env_get(M IN OUT NOCOPY mem_type,
eM env_mem_type,
eeT env_entry_table,
eidx integer,
key integer) RETURN integer;
END env_pkg;
@ -52,117 +55,88 @@ 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,
eeT IN OUT NOCOPY env_entry_table,
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());
eeT.EXTEND();
eidx := eeT.COUNT();
eeT(eidx)('**OUTER**') := outer_idx;
RETURN eidx;
END;
FUNCTION env_new(M IN OUT NOCOPY mem_type,
eM IN OUT NOCOPY env_mem_type,
eeT IN OUT NOCOPY env_entry_table,
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;
BEGIN
eM.EXTEND();
eidx := eM.COUNT();
ed := env_data();
eeT.EXTEND();
eidx := eeT.COUNT();
eeT(eidx)('**OUTER**') := outer_idx;
IF binds IS NOT NULL THEN
bs := TREAT(M(binds) AS mal_seq_type).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, exprs, i-1));
eeT(eidx)(TREAT(M(bs(i+1)) AS mal_str_type).val_str) :=
types.slice(M, exprs, i-1);
EXIT;
ELSE
ed(ed.COUNT) := env_item(
TREAT(M(bs(i)) AS mal_str_type).val_str,
exprs(i));
eeT(eidx)(TREAT(M(bs(i)) AS mal_str_type).val_str) :=
exprs(i);
END IF;
END LOOP;
END IF;
eM(eidx) := env_type(eidx, outer_idx, ed);
RETURN eidx;
END;
FUNCTION env_set(M IN OUT NOCOPY mem_type,
eM IN OUT NOCOPY env_mem_type,
eeT IN OUT NOCOPY env_entry_table,
eidx integer,
key integer,
val integer) RETURN integer IS
k varchar2(100);
k varchar2(256);
i integer;
cnt integer;
ed env_data;
BEGIN
k := TREAT(M(key) AS mal_str_type).val_str;
SELECT count(*) INTO cnt FROM TABLE(eM(eidx).data) t
WHERE key = k;
IF cnt > 0 THEN
-- TODO: a more efficient way to do this
ed := eM(eidx).data;
FOR i IN ed.FIRST..ed.LAST LOOP
IF ed(i).key = k THEN
eM(eidx).data(i).val := val;
EXIT;
END IF;
END LOOP;
ELSE
eM(eidx).data.EXTEND();
eM(eidx).data(eM(eidx).data.COUNT) := env_item(k, val);
END IF;
eeT(eidx)(k) := val;
RETURN val;
END;
FUNCTION env_find(M IN OUT NOCOPY mem_type,
eM env_mem_type,
eeT env_entry_table,
eidx integer,
key integer) RETURN integer IS
e env_type;
k varchar2(100);
cnt integer;
BEGIN
e := eM(eidx);
k := TREAT(M(key) AS mal_str_type).val_str;
SELECT COUNT(*) INTO cnt FROM TABLE(e.data) t WHERE key = k;
IF cnt > 0 THEN
RETURN e.idx;
ELSIF e.outer_idx IS NOT NULL THEN
e := eM(e.outer_idx);
RETURN env_find(M, eM, e.idx, key);
IF eeT(eidx).EXISTS(k) THEN
RETURN eidx;
ELSIF eeT(eidx)('**OUTER**') IS NOT NULL THEN
RETURN env_find(M, eeT, eeT(eidx)('**OUTER**'), key);
ELSE
RETURN NULL;
END IF;
END;
FUNCTION env_get(M IN OUT NOCOPY mem_type,
eM env_mem_type,
eeT env_entry_table,
eidx integer,
key integer) RETURN integer IS
idx integer;
e env_type;
k varchar2(100);
v integer;
found integer;
k varchar2(100);
BEGIN
idx := env_find(M, eM, eidx, key);
found := env_find(M, eeT, eidx, key);
k := TREAT(M(key) AS mal_str_type).val_str;
IF idx IS NOT NULL THEN
e := eM(idx);
SELECT t.val INTO v FROM TABLE(e.data) t
WHERE key = k;
RETURN v;
IF found IS NOT NULL THEN
RETURN eeT(found)(k);
ELSE
raise_application_error(-20005,
'''' || k || ''' not found', TRUE);

4
plsql/step0_repl.sql
View File

@ -3,14 +3,14 @@
CREATE OR REPLACE PACKAGE mal IS
FUNCTION MAIN(pwd varchar) RETURN integer;
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer;
END mal;
/
CREATE OR REPLACE PACKAGE BODY mal IS
FUNCTION MAIN(pwd varchar) RETURN integer IS
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS
line varchar2(4000);
-- read

4
plsql/step1_read_print.sql
View File

@ -5,14 +5,14 @@
CREATE OR REPLACE PACKAGE mal IS
FUNCTION MAIN(pwd varchar) RETURN integer;
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer;
END mal;
/
CREATE OR REPLACE PACKAGE BODY mal IS
FUNCTION MAIN(pwd varchar) RETURN integer IS
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS
M mem_type;
line varchar2(4000);

4
plsql/step2_eval.sql
View File

@ -5,14 +5,14 @@
CREATE OR REPLACE PACKAGE mal IS
FUNCTION MAIN(pwd varchar) RETURN integer;
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer;
END mal;
/
CREATE OR REPLACE PACKAGE BODY mal IS
FUNCTION MAIN(pwd varchar) RETURN integer IS
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS
M mem_type;
TYPE env_type IS TABLE OF integer INDEX BY varchar2(100);
repl_env env_type;

34
plsql/step3_env.sql
View File

@ -6,16 +6,16 @@
CREATE OR REPLACE PACKAGE mal IS
FUNCTION MAIN(pwd varchar) RETURN integer;
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer;
END mal;
/
CREATE OR REPLACE PACKAGE BODY mal IS
FUNCTION MAIN(pwd varchar) RETURN integer IS
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS
M mem_type;
env_mem env_mem_type;
E env_pkg.env_entry_table;
repl_env integer;
x integer;
line varchar2(4000);
@ -39,7 +39,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
new_seq mal_seq_items_type;
BEGIN
IF M(ast).type_id = 7 THEN
RETURN env_pkg.env_get(M, env_mem, env, ast);
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_type).val_seq;
new_seq := mal_seq_items_type();
@ -77,14 +77,14 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
CASE
WHEN a0sym = 'def!' THEN
RETURN env_pkg.env_set(M, env_mem, env,
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, env_mem, env);
let_env := env_pkg.env_new(M, E, 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,
x := env_pkg.env_set(M, E, let_env,
seq(i), EVAL(seq(i+1), let_env));
i := i + 2;
END LOOP;
@ -156,17 +156,17 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
BEGIN
M := types.mem_new();
env_mem := env_mem_type();
E := env_pkg.env_entry_table();
repl_env := env_pkg.env_new(M, env_mem, NULL);
x := env_pkg.env_set(M, env_mem, repl_env, types.symbol(M, '+'),
types.func(M, '+'));
x := env_pkg.env_set(M, env_mem, repl_env, types.symbol(M, '-'),
types.func(M, '-'));
x := env_pkg.env_set(M, env_mem, repl_env, types.symbol(M, '*'),
types.func(M, '*'));
x := env_pkg.env_set(M, env_mem, repl_env, types.symbol(M, '/'),
types.func(M, '/'));
repl_env := env_pkg.env_new(M, E, NULL);
x := env_pkg.env_set(M, E, repl_env, types.symbol(M, '+'),
types.func(M, '+'));
x := env_pkg.env_set(M, E, repl_env, types.symbol(M, '-'),
types.func(M, '-'));
x := env_pkg.env_set(M, E, repl_env, types.symbol(M, '*'),
types.func(M, '*'));
x := env_pkg.env_set(M, E, repl_env, types.symbol(M, '/'),
types.func(M, '/'));
WHILE true LOOP
BEGIN

22
plsql/step4_if_fn_do.sql
View File

@ -7,16 +7,16 @@
CREATE OR REPLACE PACKAGE mal IS
FUNCTION MAIN(pwd varchar) RETURN integer;
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer;
END mal;
/
CREATE OR REPLACE PACKAGE BODY mal IS
FUNCTION MAIN(pwd varchar) RETURN integer IS
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS
M mem_type;
env_mem env_mem_type;
E env_pkg.env_entry_table;
repl_env integer;
x integer;
line varchar2(4000);
@ -40,7 +40,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
new_seq mal_seq_items_type;
BEGIN
IF M(ast).type_id = 7 THEN
RETURN env_pkg.env_get(M, env_mem, env, ast);
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_type).val_seq;
new_seq := mal_seq_items_type();
@ -81,14 +81,14 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
CASE
WHEN a0sym = 'def!' THEN
RETURN env_pkg.env_set(M, env_mem, env,
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, env_mem, env);
let_env := env_pkg.env_new(M, E, 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,
x := env_pkg.env_set(M, E, let_env,
seq(i), EVAL(seq(i+1), let_env));
i := i + 2;
END LOOP;
@ -117,7 +117,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
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,
fn_env := env_pkg.env_new(M, E, malfn.env,
malfn.params, args);
RETURN EVAL(malfn.ast, fn_env);
ELSE
@ -141,14 +141,14 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
BEGIN
M := types.mem_new();
env_mem := env_mem_type();
E := env_pkg.env_entry_table();
repl_env := env_pkg.env_new(M, env_mem, NULL);
repl_env := env_pkg.env_new(M, E, 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,
x := env_pkg.env_set(M, E, repl_env,
types.symbol(M, core_ns(cidx)),
types.func(M, core_ns(cidx)));
END LOOP;

22
plsql/step5_tco.sql
View File

@ -7,16 +7,16 @@
CREATE OR REPLACE PACKAGE mal IS
FUNCTION MAIN(pwd varchar) RETURN integer;
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer;
END mal;
/
CREATE OR REPLACE PACKAGE BODY mal IS
FUNCTION MAIN(pwd varchar) RETURN integer IS
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS
M mem_type;
env_mem env_mem_type;
E env_pkg.env_entry_table;
repl_env integer;
x integer;
line varchar2(4000);
@ -40,7 +40,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
new_seq mal_seq_items_type;
BEGIN
IF M(ast).type_id = 7 THEN
RETURN env_pkg.env_get(M, env_mem, env, ast);
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_type).val_seq;
new_seq := mal_seq_items_type();
@ -83,14 +83,14 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
CASE
WHEN a0sym = 'def!' THEN
RETURN env_pkg.env_set(M, env_mem, env,
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, env_mem, env);
let_env := env_pkg.env_new(M, E, 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,
x := env_pkg.env_set(M, E, let_env,
seq(i), EVAL(seq(i+1), let_env));
i := i + 2;
END LOOP;
@ -121,7 +121,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
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,
env := env_pkg.env_new(M, E, malfn.env,
malfn.params, args);
ast := malfn.ast; -- TCO
ELSE
@ -147,14 +147,14 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
BEGIN
M := types.mem_new();
env_mem := env_mem_type();
E := env_pkg.env_entry_table();
repl_env := env_pkg.env_new(M, env_mem, NULL);
repl_env := env_pkg.env_new(M, E, 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,
x := env_pkg.env_set(M, E, repl_env,
types.symbol(M, core_ns(cidx)),
types.func(M, core_ns(cidx)));
END LOOP;

40
plsql/step6_file.sql
View File

@ -7,21 +7,22 @@
CREATE OR REPLACE PACKAGE mal IS
FUNCTION MAIN(pwd varchar) RETURN integer;
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer;
END mal;
/
CREATE OR REPLACE PACKAGE BODY mal IS
FUNCTION MAIN(pwd varchar) RETURN integer IS
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS
M mem_type;
env_mem env_mem_type;
E env_pkg.env_entry_table;
repl_env integer;
x integer;
line varchar2(4000);
core_ns core_ns_type;
cidx integer;
argv mal_seq_items_type;
-- read
FUNCTION READ(line varchar) RETURN integer IS
@ -41,7 +42,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
new_seq mal_seq_items_type;
BEGIN
IF M(ast).type_id = 7 THEN
RETURN env_pkg.env_get(M, env_mem, env, ast);
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_type).val_seq;
new_seq := mal_seq_items_type();
@ -84,14 +85,14 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
CASE
WHEN a0sym = 'def!' THEN
RETURN env_pkg.env_set(M, env_mem, env,
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, env_mem, env);
let_env := env_pkg.env_new(M, E, 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,
x := env_pkg.env_set(M, E, let_env,
seq(i), EVAL(seq(i+1), let_env));
i := i + 2;
END LOOP;
@ -122,7 +123,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
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,
env := env_pkg.env_new(M, E, malfn.env,
malfn.params, args);
ast := malfn.ast; -- TCO
ELSE
@ -159,7 +160,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
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,
fn_env := env_pkg.env_new(M, E, malfn.env,
malfn.params, fargs);
val := EVAL(malfn.ast, fn_env);
ELSE
@ -187,28 +188,37 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
BEGIN
M := types.mem_new();
env_mem := env_mem_type();
E := env_pkg.env_entry_table();
repl_env := env_pkg.env_new(M, env_mem, NULL);
repl_env := env_pkg.env_new(M, E, NULL);
argv := TREAT(M(reader.read_str(M, args)) AS mal_seq_type).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, env_mem, repl_env,
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, env_mem, repl_env,
x := env_pkg.env_set(M, E, repl_env,
types.symbol(M, 'eval'),
types.func(M, 'do_eval'));
x := env_pkg.env_set(M, env_mem, repl_env,
x := env_pkg.env_set(M, E, repl_env,
types.symbol(M, '*ARGV*'),
types.list(M));
types.slice(M, argv, 1));
-- 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) ")")))))');
IF argv.COUNT() > 0 THEN
line := REP('(load-file "' ||
TREAT(M(argv(1)) AS mal_str_type).val_str ||
'")');
RETURN 0;
END IF;
WHILE true LOOP
BEGIN
line := stream_readline('user> ', 0);

40
plsql/step7_quote.sql
View File

@ -7,21 +7,22 @@
CREATE OR REPLACE PACKAGE mal IS
FUNCTION MAIN(pwd varchar) RETURN integer;
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer;
END mal;
/
CREATE OR REPLACE PACKAGE BODY mal IS
FUNCTION MAIN(pwd varchar) RETURN integer IS
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS
M mem_type;
env_mem env_mem_type;
E env_pkg.env_entry_table;
repl_env integer;
x integer;
line varchar2(4000);
core_ns core_ns_type;
cidx integer;
argv mal_seq_items_type;
-- read
FUNCTION READ(line varchar) RETURN integer IS
@ -72,7 +73,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
new_seq mal_seq_items_type;
BEGIN
IF M(ast).type_id = 7 THEN
RETURN env_pkg.env_get(M, env_mem, env, ast);
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_type).val_seq;
new_seq := mal_seq_items_type();
@ -115,14 +116,14 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
CASE
WHEN a0sym = 'def!' THEN
RETURN env_pkg.env_set(M, env_mem, env,
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, env_mem, env);
let_env := env_pkg.env_new(M, E, 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,
x := env_pkg.env_set(M, E, let_env,
seq(i), EVAL(seq(i+1), let_env));
i := i + 2;
END LOOP;
@ -157,7 +158,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
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,
env := env_pkg.env_new(M, E, malfn.env,
malfn.params, args);
ast := malfn.ast; -- TCO
ELSE
@ -194,7 +195,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
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,
fn_env := env_pkg.env_new(M, E, malfn.env,
malfn.params, fargs);
val := EVAL(malfn.ast, fn_env);
ELSE
@ -222,28 +223,37 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
BEGIN
M := types.mem_new();
env_mem := env_mem_type();
E := env_pkg.env_entry_table();
repl_env := env_pkg.env_new(M, env_mem, NULL);
repl_env := env_pkg.env_new(M, E, NULL);
argv := TREAT(M(reader.read_str(M, args)) AS mal_seq_type).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, env_mem, repl_env,
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, env_mem, repl_env,
x := env_pkg.env_set(M, E, repl_env,
types.symbol(M, 'eval'),
types.func(M, 'do_eval'));
x := env_pkg.env_set(M, env_mem, repl_env,
x := env_pkg.env_set(M, E, repl_env,
types.symbol(M, '*ARGV*'),
types.list(M));
types.slice(M, argv, 1));
-- 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) ")")))))');
IF argv.COUNT() > 0 THEN
line := REP('(load-file "' ||
TREAT(M(argv(1)) AS mal_str_type).val_str ||
'")');
RETURN 0;
END IF;
WHILE true LOOP
BEGIN
line := stream_readline('user> ', 0);

50
plsql/step8_macros.sql
View File

@ -7,21 +7,22 @@
CREATE OR REPLACE PACKAGE mal IS
FUNCTION MAIN(pwd varchar) RETURN integer;
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer;
END mal;
/
CREATE OR REPLACE PACKAGE BODY mal IS
FUNCTION MAIN(pwd varchar) RETURN integer IS
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS
M mem_type;
env_mem env_mem_type;
E env_pkg.env_entry_table;
repl_env integer;
x integer;
line varchar2(4000);
core_ns core_ns_type;
cidx integer;
argv mal_seq_items_type;
-- read
FUNCTION READ(line varchar) RETURN integer IS
@ -74,8 +75,8 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
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);
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 malfunc_type).is_macro > 0;
END IF;
@ -93,11 +94,11 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
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));
mac := env_pkg.env_get(M, E, 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,
fn_env := env_pkg.env_new(M, E, malfn.env,
malfn.params,
fargs);
ast := EVAL(malfn.ast, fn_env);
@ -114,7 +115,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
new_seq mal_seq_items_type;
BEGIN
IF M(ast).type_id = 7 THEN
RETURN env_pkg.env_get(M, env_mem, env, ast);
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_type).val_seq;
new_seq := mal_seq_items_type();
@ -165,14 +166,14 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
CASE
WHEN a0sym = 'def!' THEN
RETURN env_pkg.env_set(M, env_mem, env,
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, env_mem, env);
let_env := env_pkg.env_new(M, E, 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,
x := env_pkg.env_set(M, E, let_env,
seq(i), EVAL(seq(i+1), let_env));
i := i + 2;
END LOOP;
@ -187,7 +188,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
malfn := TREAT(M(x) as malfunc_type);
malfn.is_macro := 1;
M(x) := malfn;
RETURN env_pkg.env_set(M, env_mem, env,
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);
@ -216,7 +217,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
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,
env := env_pkg.env_new(M, E, malfn.env,
malfn.params, args);
ast := malfn.ast; -- TCO
ELSE
@ -253,7 +254,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
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,
fn_env := env_pkg.env_new(M, E, malfn.env,
malfn.params, fargs);
val := EVAL(malfn.ast, fn_env);
ELSE
@ -281,23 +282,25 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
BEGIN
M := types.mem_new();
env_mem := env_mem_type();
E := env_pkg.env_entry_table();
repl_env := env_pkg.env_new(M, env_mem, NULL);
repl_env := env_pkg.env_new(M, E, NULL);
argv := TREAT(M(reader.read_str(M, args)) AS mal_seq_type).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, env_mem, repl_env,
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, env_mem, repl_env,
x := env_pkg.env_set(M, E, repl_env,
types.symbol(M, 'eval'),
types.func(M, 'do_eval'));
x := env_pkg.env_set(M, env_mem, repl_env,
x := env_pkg.env_set(M, E, repl_env,
types.symbol(M, '*ARGV*'),
types.list(M));
types.slice(M, argv, 1));
-- core.mal: defined using the language itself
line := REP('(def! not (fn* (a) (if a false true)))');
@ -305,6 +308,13 @@ BEGIN
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))))))))');
IF argv.COUNT() > 0 THEN
line := REP('(load-file "' ||
TREAT(M(argv(1)) AS mal_str_type).val_str ||
'")');
RETURN 0;
END IF;
WHILE true LOOP
BEGIN
line := stream_readline('user> ', 0);

56
plsql/step9_try.sql
View File

@ -7,21 +7,22 @@
CREATE OR REPLACE PACKAGE mal IS
FUNCTION MAIN(pwd varchar) RETURN integer;
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer;
END mal;
/
CREATE OR REPLACE PACKAGE BODY mal IS
FUNCTION MAIN(pwd varchar) RETURN integer IS
FUNCTION MAIN(args varchar DEFAULT '()') RETURN integer IS
M mem_type;
env_mem env_mem_type;
E env_pkg.env_entry_table;
repl_env integer;
x integer;
line varchar2(4000);
core_ns core_ns_type;
cidx integer;
argv mal_seq_items_type;
err_val integer;
-- read
@ -75,8 +76,8 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
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);
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 malfunc_type).is_macro > 0;
END IF;
@ -94,11 +95,11 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
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));
mac := env_pkg.env_get(M, E, 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,
fn_env := env_pkg.env_new(M, E, malfn.env,
malfn.params,
fargs);
ast := EVAL(malfn.ast, fn_env);
@ -115,7 +116,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
new_seq mal_seq_items_type;
BEGIN
IF M(ast).type_id = 7 THEN
RETURN env_pkg.env_get(M, env_mem, env, ast);
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_type).val_seq;
new_seq := mal_seq_items_type();
@ -167,14 +168,14 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
CASE
WHEN a0sym = 'def!' THEN
RETURN env_pkg.env_set(M, env_mem, env,
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, env_mem, env);
let_env := env_pkg.env_new(M, E, 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,
x := env_pkg.env_set(M, E, let_env,
seq(i), EVAL(seq(i+1), let_env));
i := i + 2;
END LOOP;
@ -189,7 +190,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
malfn := TREAT(M(x) as malfunc_type);
malfn.is_macro := 1;
M(x) := malfn;
RETURN env_pkg.env_set(M, env_mem, env,
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);
@ -225,7 +226,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
exc := err_val;
err_val := NULL;
END IF;
try_env := env_pkg.env_new(M, env_mem, env,
try_env := env_pkg.env_new(M, E, env,
types.list(M, types.nth(M, a2, 1)),
mal_seq_items_type(exc));
RETURN EVAL(types.nth(M, a2, 2), try_env);
@ -257,7 +258,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
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,
env := env_pkg.env_new(M, E, malfn.env,
malfn.params, args);
ast := malfn.ast; -- TCO
ELSE
@ -296,7 +297,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
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,
fn_env := env_pkg.env_new(M, E, malfn.env,
malfn.params, fargs);
val := EVAL(malfn.ast, fn_env);
ELSE
@ -317,7 +318,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
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,
fn_env := env_pkg.env_new(M, E, malfn.env,
malfn.params, fargs);
val := EVAL(malfn.ast, fn_env);
ELSE
@ -332,7 +333,7 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
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,
fn_env := env_pkg.env_new(M, E, malfn.env,
malfn.params,
mal_seq_items_type(fargs(i)));
tseq(i) := EVAL(malfn.ast, fn_env);
@ -367,23 +368,25 @@ FUNCTION MAIN(pwd varchar) RETURN integer IS
BEGIN
M := types.mem_new();
env_mem := env_mem_type();
E := env_pkg.env_entry_table();
repl_env := env_pkg.env_new(M, env_mem, NULL);
repl_env := env_pkg.env_new(M, E, NULL);
argv := TREAT(M(reader.read_str(M, args)) AS mal_seq_type).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, env_mem, repl_env,
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, env_mem, repl_env,
x := env_pkg.env_set(M, E, repl_env,
types.symbol(M, 'eval'),
types.func(M, 'do_eval'));
x := env_pkg.env_set(M, env_mem, repl_env,
x := env_pkg.env_set(M, E, repl_env,
types.symbol(M, '*ARGV*'),
types.list(M));
types.slice(M, argv, 1));
-- core.mal: defined using the language itself
line := REP('(def! not (fn* (a) (if a false true)))');
@ -391,6 +394,13 @@ BEGIN
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))))))))');
IF argv.COUNT() > 0 THEN
line := REP('(load-file "' ||
TREAT(M(argv(1)) AS mal_str_type).val_str ||
'")');
RETURN 0;
END IF;
WHILE true LOOP
BEGIN
line := stream_readline('user> ', 0);

430
plsql/stepA_mal.sql Normal file
View File

@ -0,0 +1,430 @@
@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 mem_type;
E env_pkg.env_entry_table;
repl_env integer;
x integer;
line varchar2(4000);
core_ns core_ns_type;
cidx integer;
argv mal_seq_items_type;
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, 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 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, E, 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, 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_seq_items_type;
new_seq mal_seq_items_type;
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_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, 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_type).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 malfunc_type);
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_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, E, 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, 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_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, E, 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, 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_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, E, 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();
E := env_pkg.env_entry_table();
repl_env := env_pkg.env_new(M, E, NULL);
argv := TREAT(M(reader.read_str(M, args)) AS mal_seq_type).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
line := REP('(load-file "' ||
TREAT(M(argv(1)) AS mal_str_type).val_str ||
'")');
RETURN 0;
END IF;
line := REP('(println (str "Mal [" *host-language* "]"))');
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;

20
plsql/types.sql
View File

@ -559,10 +559,12 @@ BEGIN
ELSE
final_idx := last + 1;
END IF;
new_items.EXTEND(final_idx - idx);
FOR i IN idx+1..final_idx LOOP
new_items(i-idx) := old_items(i);
END LOOP;
IF final_idx > idx THEN
new_items.EXTEND(final_idx - idx);
FOR i IN idx+1..final_idx LOOP
new_items(i-idx) := old_items(i);
END LOOP;
END IF;
M.EXTEND();
M(M.COUNT()) := mal_seq_type(8, new_items);
RETURN M.COUNT();
@ -574,10 +576,12 @@ FUNCTION slice(M IN OUT NOCOPY mem_type,
i integer;
BEGIN
new_items := mal_seq_items_type();
new_items.EXTEND(items.COUNT - idx);
FOR i IN idx+1..items.COUNT LOOP
new_items(i-idx) := items(i);
END LOOP;
IF items.COUNT > idx THEN
new_items.EXTEND(items.COUNT - idx);
FOR i IN idx+1..items.COUNT LOOP
new_items(i-idx) := items(i);
END LOOP;
END IF;
M.EXTEND();
M(M.COUNT()) := mal_seq_type(8, new_items);
RETURN M.COUNT();

12
plsql/wrap.sh
View File

@ -10,7 +10,7 @@ SQLPLUS="sqlplus -S system/oracle"
FILE_PID=
cleanup() {
trap - TERM QUIT INT EXIT
echo cleanup: ${FILE_PID}
#echo cleanup: ${FILE_PID}
[ "${FILE_PID}" ] && kill ${FILE_PID}
}
trap "cleanup" TERM QUIT INT EXIT
@ -87,7 +87,7 @@ while true; do
echo "UPDATE file_io SET data = '${content}' WHERE path = '${f}' AND in_or_out = 'in';" \
| ${SQLPLUS} >/dev/null
else
echo "UPDATE file_io SET error = 'Can not read ''${f}''' WHERE path = '${f}' AND in_or_out = 'in';" \
echo "UPDATE file_io SET error = 'Cannot read ''${f}''' WHERE path = '${f}' AND in_or_out = 'in';" \
| ${SQLPLUS} >/dev/null
fi
done
@ -103,13 +103,13 @@ shift
if [ $# -gt 0 ]; then
# If there are command line arguments then run a command and exit
args=$(for a in "$@"; do echo -n "\"$a\" "; done)
echo -e "BEGIN MAIN('$(pwd)', :'args'); END;\n/" \
| ${SQLPLUS} "(${args})"
echo -e "SELECT mal.MAIN('(${args})') FROM dual;" \
| ${SQLPLUS} > /dev/null
res=$?
else
# Start main loop in the background
echo "SELECT mal.MAIN('$(pwd)') FROM dual;" \
| ${SQLPLUS}
echo "SELECT mal.MAIN() FROM dual;" \
| ${SQLPLUS} > /dev/null
res=$?
fi
echo -e "BEGIN stream_close(0); stream_close(1); END;\n/" \