--- /dev/null
+BEGIN
+ EXECUTE IMMEDIATE 'DROP TABLE stream';
+EXCEPTION
+ WHEN OTHERS THEN IF SQLCODE != -942 THEN RAISE; END IF;
+END;
+/
+
+CREATE TABLE stream (
+ stream_id integer,
+ open number(1,0), -- stream open (1) or closed (0)
+ data varchar2(4000), -- queued stream data
+ rl_prompt varchar2(4000) -- prompt for readline input
+);
+
+-- stdin
+INSERT INTO stream (stream_id, open, data, rl_prompt)
+ VALUES (0, 0, '', '');
+-- stdout
+INSERT INTO stream (stream_id, open, data, rl_prompt)
+ VALUES (1, 0, '', '');
+
+-- ---------------------------------------------------------
+
+CREATE OR REPLACE PROCEDURE stream_open(sid integer) AS
+BEGIN
+ -- DBMS_OUTPUT.PUT_LINE('stream_open(' || sid || ') start');
+ UPDATE stream SET data = '', rl_prompt = '', open = 1
+ WHERE stream_id = sid;
+ COMMIT;
+ -- DBMS_OUTPUT.PUT_LINE('stream_open(' || sid || ') done');
+END;
+/
+
+CREATE OR REPLACE PROCEDURE stream_close(sid integer) AS
+BEGIN
+ -- DBMS_OUTPUT.PUT_LINE('stream_close(' || sid || ') start');
+ UPDATE stream SET rl_prompt = '', open = 0
+ WHERE stream_id = sid;
+ COMMIT;
+ -- DBMS_OUTPUT.PUT_LINE('stream_close(' || sid || ') done');
+END;
+/
+
+-- stream_read:
+-- read from stream stream_id in stream table. Waits until there is
+-- either data to return or the stream closes (NULL data). Returns
+-- NULL when stream is closed.
+CREATE OR REPLACE FUNCTION stream_read(sid integer DEFAULT 0)
+RETURN varchar IS
+ PRAGMA AUTONOMOUS_TRANSACTION;
+ input varchar(4000);
+ isopen integer;
+ sleep real;
+BEGIN
+ sleep := 0.05;
+ -- poll / wait for input
+ WHILE true
+ LOOP
+ -- atomic get and set to empty
+ -- LOCK TABLE stream IN EXCLUSIVE MODE;
+ SELECT data, open INTO input, isopen FROM stream
+ WHERE stream_id = sid;
+ IF isopen = 1 AND input IS NOT NULL THEN
+ UPDATE stream SET data = '' WHERE stream_id = sid;
+ COMMIT;
+ RETURN trim(TRAILING chr(10) FROM input);
+ END IF;
+ -- '' -> no input, NULL -> stream closed
+ --RAISE NOTICE 'read input: [%] %', input, stream_id;
+ IF isopen = 0 THEN
+ raise_application_error(
+ -20000, 'stream_read: stream ''' || sid || ''' is closed', TRUE);
+ END IF;
+ SYS.DBMS_LOCK.SLEEP(sleep);
+ IF sleep < 0.5 THEN
+ sleep := sleep * 1.1; -- backoff
+ END IF;
+ END LOOP;
+END;
+/
+
+-- stream_readline:
+-- set prompt and wait for readline style input on the stream
+CREATE OR REPLACE FUNCTION stream_readline(prompt varchar, sid integer DEFAULT 0)
+RETURN varchar IS
+ PRAGMA AUTONOMOUS_TRANSACTION;
+BEGIN
+ -- set prompt / request readline style input
+ -- LOCK TABLE stream IN EXCLUSIVE MODE;
+ UPDATE stream SET rl_prompt = prompt WHERE stream_id = sid;
+ COMMIT;
+
+ RETURN stream_read(sid);
+END;
+/
+
+CREATE OR REPLACE PROCEDURE stream_write(input varchar, sid integer DEFAULT 1) AS
+ PRAGMA AUTONOMOUS_TRANSACTION;
+BEGIN
+ -- LOCK TABLE stream IN EXCLUSIVE MODE;
+ UPDATE stream SET data = data || input WHERE stream_id = sid;
+ COMMIT;
+END;
+/
+
+CREATE OR REPLACE PROCEDURE stream_writeline(data varchar, sid integer DEFAULT 1) AS
+ PRAGMA AUTONOMOUS_TRANSACTION;
+BEGIN
+ stream_write(data || chr(10), sid);
+END;
+/
+
+-- ---------------------------------------------------------
+
+-- wait_rl_prompt:
+-- wait for rl_prompt to be set on the given stream and return the
+-- rl_prompt value. Errors if stream is already closed.
+CREATE OR REPLACE FUNCTION stream_wait_rl_prompt(sid integer DEFAULT 0)
+RETURN varchar IS
+ PRAGMA AUTONOMOUS_TRANSACTION;
+ isopen integer;
+ prompt varchar(4000);
+ sleep real;
+ datas integer;
+BEGIN
+ sleep := 0.05;
+ WHILE true
+ LOOP
+ -- LOCK TABLE stream IN EXCLUSIVE MODE;
+ SELECT open, rl_prompt INTO isopen, prompt
+ FROM stream WHERE stream_id = sid;
+ SELECT count(data) INTO datas FROM stream WHERE data IS NOT NULL;
+ if datas > 0 THEN
+ CONTINUE;
+ END IF;
+ IF isopen = 1 AND prompt IS NOT NULL THEN
+ UPDATE stream SET rl_prompt = '' WHERE stream_id = sid;
+ COMMIT;
+ -- Prompt is returned single-quoted because sqlplus trims
+ -- trailing whitespace in select output.
+ RETURN '''' || prompt || '''';
+ END IF;
+ -- '' -> no input, NULL -> stream closed
+ IF isopen = 0 THEN
+ raise_application_error(
+ -20000, 'stream_wait_rl_prompt: stream ''' || sid || ''' is closed', TRUE);
+ END IF;
+
+ DBMS_LOCK.SLEEP(sleep);
+ IF sleep < 0.5 THEN
+ sleep := sleep * 1.1; -- backoff
+ END IF;
+ END LOOP;
+END;
+/
+
+CREATE OR REPLACE PROCEDURE stream_wait_flushed(sid integer DEFAULT 1) AS
+ PRAGMA AUTONOMOUS_TRANSACTION;
+ pending integer;
+ sleep real;
+BEGIN
+ sleep := 0.05;
+ WHILE true
+ LOOP
+ SELECT count(data) INTO pending FROM stream
+ WHERE stream_id = sid AND data IS NOT NULL AND data <> '';
+ IF pending = 0 THEN RETURN; END IF;
+ DBMS_LOCK.SLEEP(sleep);
+ IF sleep < 0.5 THEN
+ sleep := sleep * 1.1; -- backoff
+ END IF;
+ END LOOP;
+END;
+/
--- /dev/null
+-- ---------------------------------------------------------
+-- reader.sql
+
+PROMPT "reader.sql start";
+
+CREATE OR REPLACE TYPE tokens FORCE AS TABLE OF varchar2(4000);
+/
+
+CREATE OR REPLACE TYPE reader FORCE AS OBJECT (
+ position integer,
+ toks tokens,
+ MEMBER FUNCTION peek (SELF IN OUT reader) RETURN varchar,
+ MEMBER FUNCTION next (SELF IN OUT reader) RETURN varchar
+);
+/
+
+
+CREATE OR REPLACE TYPE BODY reader AS
+ MEMBER FUNCTION peek (SELF IN OUT reader) RETURN varchar IS
+ BEGIN
+ IF position > toks.COUNT THEN
+ RETURN NULL;
+ END IF;
+ RETURN toks(position);
+ END;
+ MEMBER FUNCTION next (SELF IN OUT reader) RETURN varchar IS
+ BEGIN
+ position := position + 1;
+ RETURN toks(position-1);
+ END;
+END;
+/
+
+
+CREATE OR REPLACE PACKAGE reader_pkg IS
+ FUNCTION read_str(str varchar) RETURN mal_type;
+END reader_pkg;
+/
+
+CREATE OR REPLACE PACKAGE BODY reader_pkg AS
+
+FUNCTION tokenize(str varchar) RETURN tokens IS
+ re varchar2(100) := '[[:space:] ,]*(~@|[][{}()''`~@]|"(([\].|[^\"])*)"|;[^' || chr(10) || ']*|[^][[:space:] {}()''"`~@,;]*)';
+ tok varchar2(4000);
+ toks tokens := tokens();
+ cnt integer;
+BEGIN
+ cnt := REGEXP_COUNT(str, re);
+ FOR I IN 1..cnt LOOP
+ tok := REGEXP_SUBSTR(str, re, 1, I, 'm', 1);
+ IF tok IS NOT NULL THEN
+ toks.extend();
+ toks(toks.COUNT) := tok;
+ -- stream_writeline('tok: [' || tok || ']');
+ END IF;
+ END LOOP;
+ RETURN toks;
+END;
+
+-- read_atom:
+-- takes a reader
+-- updates reader and returns value
+FUNCTION read_atom(rdr IN OUT reader) RETURN mal_type IS
+ str_id integer;
+ str varchar2(4000);
+ token varchar2(4000);
+ result mal_type;
+BEGIN
+ token := rdr.next();
+ -- stream_writeline('read_atom: ' || token);
+ IF token = 'nil' THEN -- nil
+ result := mal_type(0);
+ ELSIF token = 'false' THEN -- false
+ result := mal_type(1);
+ ELSIF token = 'true' THEN -- true
+ result := mal_type(2);
+ ELSIF REGEXP_LIKE(token, '^-?[0-9][0-9]*$') THEN -- integer
+ result := mal_int_type(3, CAST(token AS integer));
+ ELSIF REGEXP_LIKE(token, '^".*"') THEN -- string
+ -- string
+-- str := substring(token FROM 2 FOR (char_length(token)-2));
+-- str := replace(str, '\"', '"');
+-- str := replace(str, '\n', E'\n');
+-- str := replace(str, '\\', E'\\');
+-- result := _stringv(str);
+ result := mal_str_type(5, token);
+-- ELSIF token ~ '^:.*' THEN -- keyword
+-- -- keyword
+-- result := _keywordv(substring(token FROM 2 FOR (char_length(token)-1)));
+ ELSE
+ -- symbol
+ result := mal_str_type(7, token);
+ END IF;
+ return result;
+END;
+
+-- forward declaration of read_form
+FUNCTION read_form(rdr IN OUT reader) RETURN mal_type;
+
+-- read_seq:
+-- takes a reader
+-- updates reader and returns new mal_type list/vector/hash-map
+FUNCTION read_seq(rdr IN OUT reader, type_id integer,
+ first varchar, last varchar)
+ RETURN mal_type IS
+ token varchar2(4000);
+ items mal_seq_items_type;
+BEGIN
+ token := rdr.next();
+ IF token <> first THEN
+ raise_application_error(-20002,
+ 'expected ''' || first || '''', TRUE);
+ END IF;
+ items := mal_seq_items_type();
+ LOOP
+ token := rdr.peek();
+ IF token IS NULL THEN
+ raise_application_error(-20002,
+ 'expected ''' || last || '''', TRUE);
+ END IF;
+ IF token = last THEN EXIT; END IF;
+ items.EXTEND();
+ items(items.COUNT) := read_form(rdr);
+ END LOOP;
+ token := rdr.next();
+ RETURN mal_seq_type(type_id, items);
+END;
+
+-- read_form:
+-- takes a reader
+-- updates the reader and returns new mal_type value
+FUNCTION read_form(rdr IN OUT reader) RETURN mal_type IS
+ token varchar2(4000);
+ meta mal_type;
+BEGIN
+ token := rdr.peek(); -- peek
+ CASE
+ WHEN token = '''' THEN
+ token := rdr.next();
+ RETURN types_pkg.mal_list(
+ mal_str_type(7, 'quote'),
+ read_form(rdr));
+ WHEN token = '`' THEN
+ token := rdr.next();
+ RETURN types_pkg.mal_list(
+ mal_str_type(7, 'quasiquote'),
+ read_form(rdr));
+ WHEN token = '~' THEN
+ token := rdr.next();
+ RETURN types_pkg.mal_list(
+ mal_str_type(7, 'unquote'),
+ read_form(rdr));
+ WHEN token = '~@' THEN
+ token := rdr.next();
+ RETURN types_pkg.mal_list(
+ mal_str_type(7, 'splice-unquote'),
+ read_form(rdr));
+ WHEN token = '^' THEN
+ token := rdr.next();
+ meta := read_form(rdr);
+ RETURN types_pkg.mal_list(
+ mal_str_type(7, 'with-meta'),
+ read_form(rdr),
+ meta);
+ WHEN token = '@' THEN
+ token := rdr.next();
+ RETURN types_pkg.mal_list(
+ mal_str_type(7, 'deref'),
+ read_form(rdr));
+
+ -- list
+ WHEN token = ')' THEN
+ raise_application_error(-20001,
+ 'unexpected '')''', TRUE);
+ WHEN token = '(' THEN
+ RETURN read_seq(rdr, 8, '(', ')');
+--
+-- -- vector
+-- WHEN token = ']' THEN
+-- RAISE EXCEPTION 'unexpected '']''';
+-- WHEN token = '[' THEN
+-- BEGIN
+-- SELECT p, _vector(items)
+-- FROM read_seq(tokens, '[', ']', pos) INTO pos, result;
+-- END;
+--
+-- -- hash-map
+-- WHEN token = '}' THEN
+-- RAISE EXCEPTION 'unexpected ''}''';
+-- WHEN token = '{' THEN
+-- BEGIN
+-- SELECT p, _hash_map(items)
+-- FROM read_seq(tokens, '{', '}', pos) INTO pos, result;
+-- END;
+--
+ --
+ ELSE
+ RETURN read_atom(rdr);
+ END CASE;
+END;
+
+-- read_str:
+-- takes a string
+-- returns a new mal_type value
+FUNCTION read_str(str varchar) RETURN mal_type IS
+ toks tokens;
+ rdr reader;
+ ast mal_type;
+BEGIN
+ toks := tokenize(str);
+ rdr := reader(1, toks);
+ -- stream_writeline('token 1: ' || rdr.peek());
+ RETURN read_form(rdr);
+END;
+
+END reader_pkg;
+/
+show errors;
+
+PROMPT "reader.sql finished";
--- /dev/null
+-- ---------------------------------------------------------
+-- persistent values
+
+PROMPT "types.sql start";
+
+BEGIN
+ EXECUTE IMMEDIATE 'DROP TYPE mal_type FORCE';
+EXCEPTION
+ WHEN OTHERS THEN IF SQLCODE != -4043 THEN RAISE; END IF;
+END;
+/
+
+-- list of types for type_id
+-- 0: nil
+-- 1: false
+-- 2: true
+-- 3: integer
+-- 4: float
+-- 5: string
+-- 6: keyword (not used, uses prefixed string)
+-- 7: symbol
+-- 8: list
+-- 9: vector
+-- 10: hashmap
+-- 11: function
+-- 12: malfunc
+-- 13: atom
+
+CREATE OR REPLACE TYPE mal_type FORCE AS OBJECT (
+ type_id integer
+) NOT FINAL;
+/
+
+CREATE OR REPLACE TYPE mal_int_type FORCE UNDER mal_type (
+ val_int integer
+) FINAL;
+/
+
+CREATE OR REPLACE TYPE mal_str_type FORCE UNDER mal_type (
+ val_str varchar2(4000)
+) FINAL;
+/
+
+CREATE OR REPLACE TYPE mal_seq_items_type FORCE AS TABLE OF mal_type;
+/
+
+CREATE OR REPLACE TYPE mal_seq_type FORCE UNDER mal_type (
+ val_seq mal_seq_items_type
+) FINAL;
+/
+
+
+-- CREATE OR REPLACE TYPE mal_seq_items AS TABLE OF mal_type;
+-- /
+
+-- CREATE OR REPLACE TYPE mal_seq_type AS OBJECT (
+-- items mal_seq_items
+-- );
+-- /
+
+-- BEGIN
+-- EXECUTE IMMEDIATE 'DROP TABLE sequence';
+-- EXCEPTION
+-- WHEN OTHERS THEN IF SQLCODE != -942 THEN RAISE; END IF;
+-- END;
+-- /
+--
+-- CREATE TABLE sequence (
+-- seq mal_seq_items
+-- )
+-- NESTED TABLE seq STORE AS seq_table;
+--
+-- PROMPT "types.sql 3";
+
+-- -- skip nil, false, true
+-- CREATE SEQUENCE value_id_seq START WITH 3;
+-- CREATE TABLE value (
+-- value_id integer NOT NULL,
+-- value REF mal_type
+-- -- type_id integer NOT NULL,
+-- -- val_int bigint, -- set for integers
+-- -- val_string varchar, -- set for strings, keywords, symbols,
+-- -- -- and native functions (function name)
+-- -- val_seq integer[], -- set for lists and vectors
+-- -- val_hash hstore, -- set for hash-maps
+-- -- ast_id integer, -- set for malfunc
+-- -- params_id integer, -- set for malfunc
+-- -- env_id integer, -- set for malfunc
+-- -- macro boolean, -- set for malfunc
+-- -- meta_id integer -- can be set for any collection
+-- );
+
+--NESTED TABLE val STORE AS val_table
+--( NESTED TABLE val_seq STORE AS val_seq_table );
+
+-- CREATE OR REPLACE TRIGGER pk_value_trigger BEFORE INSERT ON value
+-- FOR EACH ROW
+-- DECLARE
+-- BEGIN
+-- select value_id_seq.nextval into :new.value_id from dual;
+-- END;
+-- /
+
+PROMPT "types.sql 5";
+
+-- ALTER TABLE value ADD CONSTRAINT pk_value_id
+-- PRIMARY KEY (value_id);
+-- PL/pgSQL:-- drop sequence when table dropped
+-- PL/pgSQL:ALTER SEQUENCE value_id_seq OWNED BY value.value_id;
+-- ALTER TABLE value ADD CONSTRAINT fk_meta_id
+-- FOREIGN KEY (meta_id) REFERENCES value(value_id);
+-- ALTER TABLE value ADD CONSTRAINT fk_params_id
+-- FOREIGN KEY (params_id) REFERENCES value(value_id);
+--
+-- CREATE INDEX ON value (value_id, type_id);
+--
+-- INSERT INTO value (value_id, type_id) VALUES (0, 0); -- nil
+-- INSERT INTO value (value_id, type_id) VALUES (1, 1); -- false
+-- INSERT INTO value (value_id, type_id) VALUES (2, 2); -- true
+
+
+-- ---------------------------------------------------------
+-- general functions
+
+-- CREATE OR REPLACE FUNCTION _wraptf(val boolean) RETURNS integer AS $$
+-- BEGIN
+-- IF val THEN
+-- RETURN 2;
+-- ELSE
+-- RETURN 1;
+-- END IF;
+-- END; $$ LANGUAGE plpgsql IMMUTABLE;
+--
+-- -- pun both NULL and false to false
+-- CREATE OR REPLACE FUNCTION _tf(val boolean) RETURNS boolean AS $$
+-- BEGIN
+-- IF val IS NULL OR val = false THEN
+-- RETURN false;
+-- END IF;
+-- RETURN true;
+-- END; $$ LANGUAGE plpgsql IMMUTABLE;
+--
+-- -- pun both NULL and 0 to false
+-- CREATE OR REPLACE FUNCTION _tf(val integer) RETURNS boolean AS $$
+-- BEGIN
+-- IF val IS NULL OR val = 0 THEN
+-- RETURN false;
+-- END IF;
+-- RETURN true;
+-- END; $$ LANGUAGE plpgsql IMMUTABLE;
+--
+-- -- return the type of the given value_id
+-- CREATE OR REPLACE FUNCTION _type(obj integer) RETURNS integer AS $$
+-- BEGIN
+-- RETURN (SELECT type_id FROM value WHERE value_id = obj);
+-- END; $$ LANGUAGE plpgsql;
+--
+--
+-- CREATE OR REPLACE FUNCTION _equal_Q(a integer, b integer) RETURNS boolean AS $$
+-- DECLARE
+-- atype integer;
+-- btype integer;
+-- anum bigint;
+-- bnum bigint;
+-- avid integer;
+-- bvid integer;
+-- aseq integer[];
+-- bseq integer[];
+-- ahash hstore;
+-- bhash hstore;
+-- kv RECORD;
+-- i integer;
+-- BEGIN
+-- atype := _type(a);
+-- btype := _type(b);
+-- IF NOT ((atype = btype) OR (_sequential_Q(a) AND _sequential_Q(b))) THEN
+-- RETURN false;
+-- END IF;
+-- CASE
+-- WHEN atype = 3 THEN -- integer
+-- SELECT val_int FROM value INTO anum WHERE value_id = a;
+-- SELECT val_int FROM value INTO bnum WHERE value_id = b;
+-- RETURN anum = bnum;
+-- WHEN atype = 5 OR atype = 7 THEN -- string/symbol
+-- RETURN _valueToString(a) = _valueToString(b);
+-- WHEN atype IN (8, 9) THEN -- list/vector
+-- IF _count(a) <> _count(b) THEN
+-- RETURN false;
+-- END IF;
+-- SELECT val_seq INTO aseq FROM value WHERE value_id = a;
+-- SELECT val_seq INTO bseq FROM value WHERE value_id = b;
+-- FOR i IN 1 .. _count(a)
+-- LOOP
+-- IF NOT _equal_Q(aseq[i], bseq[i]) THEN
+-- return false;
+-- END IF;
+-- END LOOP;
+-- RETURN true;
+-- WHEN atype = 10 THEN -- hash-map
+-- SELECT val_hash INTO ahash FROM value WHERE value_id = a;
+-- SELECT val_hash INTO bhash FROM value WHERE value_id = b;
+-- IF array_length(akeys(ahash), 1) <> array_length(akeys(bhash), 1) THEN
+-- RETURN false;
+-- END IF;
+-- FOR kv IN SELECT * FROM each(ahash) LOOP
+-- avid := CAST((ahash -> kv.key) AS integer);
+-- bvid := CAST((bhash -> kv.key) AS integer);
+-- IF bvid IS NULL OR NOT _equal_Q(avid, bvid) THEN
+-- return false;
+-- END IF;
+-- END LOOP;
+-- RETURN true;
+-- ELSE
+-- RETURN a = b;
+-- END CASE;
+-- END; $$ LANGUAGE plpgsql;
+--
+--
+-- -- _clone:
+-- -- take a value_id of a collection
+-- -- returns a new value_id of a cloned collection
+-- CREATE OR REPLACE FUNCTION _clone(id integer) RETURNS integer AS $$
+-- DECLARE
+-- result integer;
+-- BEGIN
+-- INSERT INTO value (type_id,val_int,val_string,val_seq,val_hash,
+-- ast_id,params_id,env_id,meta_id)
+-- (SELECT type_id,val_int,val_string,val_seq,val_hash,
+-- ast_id,params_id,env_id,meta_id
+-- FROM value
+-- WHERE value_id = id)
+-- RETURNING value_id INTO result;
+-- RETURN result;
+-- END; $$ LANGUAGE plpgsql;
+--
+--
+-- -- ---------------------------------------------------------
+-- -- scalar functions
+--
+--
+-- -- _nil_Q:
+-- -- takes a value_id
+-- -- returns the whether value_id is nil
+-- CREATE OR REPLACE FUNCTION _nil_Q(id integer) RETURNS boolean AS $$
+-- BEGIN
+-- RETURN id = 0;
+-- END; $$ LANGUAGE plpgsql IMMUTABLE;
+--
+-- -- _true_Q:
+-- -- takes a value_id
+-- -- returns the whether value_id is true
+-- CREATE OR REPLACE FUNCTION _true_Q(id integer) RETURNS boolean AS $$
+-- BEGIN
+-- RETURN id = 2;
+-- END; $$ LANGUAGE plpgsql IMMUTABLE;
+--
+-- -- _false_Q:
+-- -- takes a value_id
+-- -- returns the whether value_id is false
+-- CREATE OR REPLACE FUNCTION _false_Q(id integer) RETURNS boolean AS $$
+-- BEGIN
+-- RETURN id = 1;
+-- END; $$ LANGUAGE plpgsql IMMUTABLE;
+--
+-- -- _string_Q:
+-- -- takes a value_id
+-- -- returns the whether value_id is string type
+-- CREATE OR REPLACE FUNCTION _string_Q(id integer) RETURNS boolean AS $$
+-- BEGIN
+-- IF (SELECT 1 FROM value WHERE type_id = 5 AND value_id = id) THEN
+-- RETURN NOT _keyword_Q(id);
+-- END IF;
+-- RETURN false;
+-- END; $$ LANGUAGE plpgsql;
+--
+--
+-- -- _valueToString:
+-- -- takes a value_id for a string
+-- -- returns the varchar value of the string
+-- CREATE OR REPLACE FUNCTION _valueToString(sid integer) RETURNS varchar AS $$
+-- BEGIN
+-- RETURN (SELECT val_string FROM value WHERE value_id = sid);
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _stringish:
+-- -- takes a varchar string
+-- -- returns the value_id of a stringish type (string, symbol, keyword)
+-- CREATE OR REPLACE FUNCTION _stringish(str varchar, type integer) RETURNS integer AS $$
+-- DECLARE
+-- result integer;
+-- BEGIN
+-- -- TODO: share string data between string types
+-- -- lookup if it exists
+-- SELECT value_id FROM value INTO result
+-- WHERE val_string = str AND type_id = type;
+-- IF result IS NULL THEN
+-- -- Create string entry
+-- INSERT INTO value (type_id, val_string)
+-- VALUES (type, str)
+-- RETURNING value_id INTO result;
+-- END IF;
+-- RETURN result;
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _stringv:
+-- -- takes a varchar string
+-- -- returns the value_id of a string (new or existing)
+-- CREATE OR REPLACE FUNCTION _stringv(str varchar) RETURNS integer AS $$
+-- BEGIN
+-- RETURN _stringish(str, 5);
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _keywordv:
+-- -- takes a varchar string
+-- -- returns the value_id of a keyword (new or existing)
+-- CREATE OR REPLACE FUNCTION _keywordv(name varchar) RETURNS integer AS $$
+-- BEGIN
+-- RETURN _stringish(chr(CAST(x'7f' AS integer)) || name, 5);
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _keyword_Q:
+-- -- takes a value_id
+-- -- returns the whether value_id is keyword type
+-- CREATE OR REPLACE FUNCTION _keyword_Q(id integer) RETURNS boolean AS $$
+-- DECLARE
+-- str varchar;
+-- BEGIN
+-- IF (SELECT 1 FROM value WHERE type_id = 5 AND value_id = id) THEN
+-- str := _valueToString(id);
+-- IF char_length(str) > 0 AND
+-- chr(CAST(x'7f' AS integer)) = substring(str FROM 1 FOR 1) THEN
+-- RETURN true;
+-- END IF;
+-- END IF;
+-- RETURN false;
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _symbolv:
+-- -- takes a varchar string
+-- -- returns the value_id of a symbol (new or existing)
+-- CREATE OR REPLACE FUNCTION _symbolv(name varchar) RETURNS integer AS $$
+-- BEGIN
+-- RETURN _stringish(name, 7);
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _symbol_Q:
+-- -- takes a value_id
+-- -- returns the whether value_id is symbol type
+-- CREATE OR REPLACE FUNCTION _symbol_Q(id integer) RETURNS boolean AS $$
+-- BEGIN
+-- RETURN _tf((SELECT 1 FROM value WHERE type_id = 7 AND value_id = id));
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _numToValue:
+-- -- takes an bigint number
+-- -- returns the value_id for the number
+-- CREATE OR REPLACE FUNCTION _numToValue(num bigint) RETURNS integer AS $$
+-- DECLARE
+-- result integer;
+-- BEGIN
+-- SELECT value_id FROM value INTO result
+-- WHERE val_int = num AND type_id = 3;
+-- IF result IS NULL THEN
+-- -- Create an integer entry
+-- INSERT INTO value (type_id, val_int)
+-- VALUES (3, num)
+-- RETURNING value_id INTO result;
+-- END IF;
+-- RETURN result;
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- ---------------------------------------------------------
+-- -- sequence functions
+--
+-- -- _sequential_Q:
+-- -- return true if obj value_id is a list or vector
+-- CREATE OR REPLACE FUNCTION _sequential_Q(obj integer) RETURNS boolean AS $$
+-- BEGIN
+-- RETURN _tf((SELECT 1 FROM value
+-- WHERE value_id = obj AND (type_id = 8 OR type_id = 9)));
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _collection:
+-- -- takes a array of value_id integers
+-- -- returns the value_id of a new list (8), vector (9) or hash-map (10)
+-- CREATE OR REPLACE FUNCTION _collection(items integer[], type integer) RETURNS integer AS $$
+-- DECLARE
+-- vid integer;
+-- BEGIN
+-- IF type IN (8, 9) THEN
+-- INSERT INTO value (type_id, val_seq)
+-- VALUES (type, items)
+-- RETURNING value_id INTO vid;
+-- ELSIF type = 10 THEN
+-- IF (array_length(items, 1) % 2) = 1 THEN
+-- RAISE EXCEPTION 'hash-map: odd number of arguments';
+-- END IF;
+-- INSERT INTO value (type_id, val_hash)
+-- VALUES (type, hstore(CAST(items AS varchar[])))
+-- RETURNING value_id INTO vid;
+-- END IF;
+-- RETURN vid;
+-- END; $$ LANGUAGE plpgsql;
+--
+
+CREATE OR REPLACE PACKAGE types_pkg IS
+ FUNCTION mal_list RETURN mal_type;
+ FUNCTION mal_list(a mal_type) RETURN mal_type;
+ FUNCTION mal_list(a mal_type, b mal_type) RETURN mal_type;
+ FUNCTION mal_list(a mal_type, b mal_type, c mal_type) RETURN mal_type;
+END types_pkg;
+/
+
+CREATE OR REPLACE PACKAGE BODY types_pkg IS
+
+-- mal_list:
+-- return a mal list
+FUNCTION mal_list RETURN mal_type IS
+BEGIN
+ RETURN mal_seq_type(8, mal_seq_items_type());
+END;
+
+FUNCTION mal_list(a mal_type) RETURN mal_type IS
+BEGIN
+ RETURN mal_seq_type(8, mal_seq_items_type(a));
+END;
+
+FUNCTION mal_list(a mal_type, b mal_type) RETURN mal_type IS
+BEGIN
+ RETURN mal_seq_type(8, mal_seq_items_type(a, b));
+END;
+
+FUNCTION mal_list(a mal_type, b mal_type, c mal_type) RETURN mal_type IS
+BEGIN
+ RETURN mal_seq_type(8, mal_seq_items_type(a, b, c));
+END;
+
+END types_pkg;
+/
+show errors;
+
+-- -- _vector:
+-- -- takes a array of value_id integers
+-- -- returns the value_id of a new list
+-- CREATE OR REPLACE FUNCTION _vector(items integer[]) RETURNS integer AS $$
+-- BEGIN
+-- RETURN _collection(items, 9);
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _list_Q:
+-- -- return true if obj value_id is a list
+-- CREATE OR REPLACE FUNCTION _list_Q(obj integer) RETURNS boolean AS $$
+-- BEGIN
+-- RETURN _tf((SELECT 1 FROM value WHERE value_id = obj and type_id = 8));
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _vector_Q:
+-- -- return true if obj value_id is a list
+-- CREATE OR REPLACE FUNCTION _vector_Q(obj integer) RETURNS boolean AS $$
+-- BEGIN
+-- RETURN _tf((SELECT 1 FROM value WHERE value_id = obj and type_id = 9));
+-- END; $$ LANGUAGE plpgsql;
+--
+--
+-- -- _valueToArray:
+-- -- takes an value_id referring to a list or vector
+-- -- returns an array of the value_ids from the list/vector
+-- CREATE OR REPLACE FUNCTION _valueToArray(seq integer) RETURNS integer[] AS $$
+-- DECLARE
+-- result integer[];
+-- BEGIN
+-- result := (SELECT val_seq FROM value WHERE value_id = seq);
+-- IF result IS NULL THEN
+-- result := ARRAY[]::integer[];
+-- END IF;
+-- RETURN result;
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- From: https://wiki.postgresql.org/wiki/Array_reverse
+-- CREATE OR REPLACE FUNCTION array_reverse(a integer[]) RETURNS integer[] AS $$
+-- SELECT ARRAY(
+-- SELECT a[i]
+-- FROM generate_subscripts(a,1) AS s(i)
+-- ORDER BY i DESC
+-- );
+-- $$ LANGUAGE 'sql' STRICT IMMUTABLE;
+--
+--
+-- -- _nth:
+-- -- takes value_id and an index
+-- -- returns the value_id of nth element in list/vector
+-- CREATE OR REPLACE FUNCTION _nth(seq_id integer, indx integer) RETURNS integer AS $$
+-- DECLARE
+-- result integer;
+-- BEGIN
+-- RETURN (SELECT val_seq[indx+1] FROM value WHERE value_id = seq_id);
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _first:
+-- -- takes value_id
+-- -- returns the value_id of first element in list/vector
+-- CREATE OR REPLACE FUNCTION _first(seq_id integer) RETURNS integer AS $$
+-- BEGIN
+-- RETURN _nth(seq_id, 0);
+-- END; $$ LANGUAGE plpgsql;
+--
+--
+-- -- _restArray:
+-- -- takes value_id
+-- -- returns the array of value_ids
+-- CREATE OR REPLACE FUNCTION _restArray(seq_id integer) RETURNS integer[] AS $$
+-- DECLARE
+-- result integer[];
+-- BEGIN
+-- result := (SELECT val_seq FROM value WHERE value_id = seq_id);
+-- RETURN result[2:array_length(result, 1)];
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _slice:
+-- -- takes value_id, a first index and an last index
+-- -- returns the value_id of new list from first (inclusive) to last (exclusive)
+-- CREATE OR REPLACE FUNCTION _slice(seq_id integer, first integer, last integer)
+-- RETURNS integer AS $$
+-- DECLARE
+-- seq integer[];
+-- vid integer;
+-- i integer;
+-- result integer;
+-- BEGIN
+-- SELECT val_seq INTO seq FROM value WHERE value_id = seq_id;
+-- INSERT INTO value (type_id, val_seq)
+-- VALUES (8, seq[first+1:last])
+-- RETURNING value_id INTO result;
+-- RETURN result;
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _rest:
+-- -- takes value_id
+-- -- returns the value_id of new list
+-- CREATE OR REPLACE FUNCTION _rest(seq_id integer) RETURNS integer AS $$
+-- BEGIN
+-- RETURN _slice(seq_id, 1, _count(seq_id));
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _count:
+-- -- takes value_id
+-- -- returns a count (not value_id)
+-- CREATE OR REPLACE FUNCTION _count(seq_id integer) RETURNS integer AS $$
+-- DECLARE
+-- result integer[];
+-- BEGIN
+-- result := (SELECT val_seq FROM value
+-- WHERE value_id = seq_id);
+-- RETURN COALESCE(array_length(result, 1), 0);
+-- END; $$ LANGUAGE plpgsql;
+--
+--
+-- -- ---------------------------------------------------------
+-- -- hash-map functions
+--
+-- -- _hash_map:
+-- -- return value_id of a new hash-map
+-- CREATE OR REPLACE FUNCTION _hash_map(items integer[]) RETURNS integer AS $$
+-- BEGIN
+-- RETURN _collection(items, 10);
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _hash_map_Q:
+-- -- return true if obj value_id is a list
+-- CREATE OR REPLACE FUNCTION _hash_map_Q(obj integer) RETURNS boolean AS $$
+-- BEGIN
+-- RETURN _tf((SELECT 1 FROM value WHERE value_id = obj and type_id = 10));
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _assoc_BANG:
+-- -- return value_id of the hash-map with new elements appended
+-- CREATE OR REPLACE FUNCTION _assoc_BANG(hm integer, items integer[]) RETURNS integer AS $$
+-- DECLARE
+-- hash hstore;
+-- BEGIN
+-- IF (array_length(items, 1) % 2) = 1 THEN
+-- RAISE EXCEPTION 'hash-map: odd number of arguments';
+-- END IF;
+-- SELECT val_hash INTO hash FROM value WHERE value_id = hm;
+-- IF hash IS NULL THEN
+-- UPDATE value SET val_hash = hstore(CAST(items AS varchar[]))
+-- WHERE value_id = hm;
+-- ELSE
+-- UPDATE value SET val_hash = hash || hstore(CAST(items AS varchar[]))
+-- WHERE value_id = hm;
+-- END IF;
+-- RETURN hm;
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _dissoc_BANG:
+-- -- return value_id of the hash-map with elements removed
+-- CREATE OR REPLACE FUNCTION _dissoc_BANG(hm integer, items integer[]) RETURNS integer AS $$
+-- DECLARE
+-- hash hstore;
+-- BEGIN
+-- SELECT val_hash INTO hash FROM value WHERE value_id = hm;
+-- UPDATE value SET val_hash = hash - CAST(items AS varchar[])
+-- WHERE value_id = hm;
+-- RETURN hm;
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _get:
+-- -- return value_id of the hash-map entry matching key
+-- CREATE OR REPLACE FUNCTION _get(hm integer, key varchar) RETURNS integer AS $$
+-- DECLARE
+-- hash hstore;
+-- BEGIN
+-- SELECT val_hash INTO hash FROM value WHERE value_id = hm;
+-- RETURN hash -> CAST(_stringv(key) AS varchar);
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _contains_Q:
+-- -- return true if hash-map contains entry matching key
+-- CREATE OR REPLACE FUNCTION _contains_Q(hm integer, key varchar) RETURNS boolean AS $$
+-- DECLARE
+-- hash hstore;
+-- BEGIN
+-- SELECT val_hash INTO hash FROM value WHERE value_id = hm;
+-- RETURN _tf(hash ? CAST(_stringv(key) AS varchar));
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _keys:
+-- -- return array of key value_ids from hash-map
+-- CREATE OR REPLACE FUNCTION _keys(hm integer) RETURNS integer[] AS $$
+-- DECLARE
+-- hash hstore;
+-- BEGIN
+-- SELECT val_hash INTO hash FROM value WHERE value_id = hm;
+-- RETURN CAST(akeys(hash) AS integer[]);
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _vals:
+-- -- return array of value value_ids from hash-map
+-- CREATE OR REPLACE FUNCTION _vals(hm integer) RETURNS integer[] AS $$
+-- DECLARE
+-- hash hstore;
+-- BEGIN
+-- SELECT val_hash INTO hash FROM value WHERE value_id = hm;
+-- RETURN CAST(avals(hash) AS integer[]);
+-- END; $$ LANGUAGE plpgsql;
+--
+--
+-- -- ---------------------------------------------------------
+-- -- function functions
+--
+-- -- _function:
+-- -- takes a function name
+-- -- returns the value_id of a new
+-- CREATE OR REPLACE FUNCTION _function(fname varchar)
+-- RETURNS varchar AS $$
+-- DECLARE
+-- result integer;
+-- BEGIN
+-- INSERT INTO value (type_id, val_string)
+-- VALUES (11, fname)
+-- RETURNING value_id INTO result;
+-- RETURN CAST(result AS varchar);
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _malfunc:
+-- -- takes a ast value_id, params value_id and env_id
+-- -- returns the value_id of a new function
+-- CREATE OR REPLACE FUNCTION _malfunc(ast integer, params integer, env integer)
+-- RETURNS integer AS $$
+-- DECLARE
+-- cid integer = NULL;
+-- result integer;
+-- BEGIN
+-- -- Create function entry
+-- INSERT INTO value (type_id, ast_id, params_id, env_id)
+-- VALUES (12, ast, params, env)
+-- RETURNING value_id into result;
+-- RETURN result;
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _macro:
+-- CREATE OR REPLACE FUNCTION _macro(func integer) RETURNS integer AS $$
+-- DECLARE
+-- newfunc integer;
+-- cid integer;
+-- BEGIN
+-- newfunc := _clone(func);
+-- UPDATE value SET macro = true WHERE value_id = newfunc;
+-- RETURN newfunc;
+-- END; $$ LANGUAGE plpgsql;
+--
+-- CREATE OR REPLACE FUNCTION _apply(func integer, args integer[]) RETURNS integer AS $$
+-- DECLARE
+-- type integer;
+-- fcid integer;
+-- fname varchar;
+-- fast integer;
+-- fparams integer;
+-- fenv integer;
+-- result integer;
+-- BEGIN
+-- SELECT type_id, val_string, ast_id, params_id, env_id
+-- INTO type, fname, fast, fparams, fenv
+-- FROM value WHERE value_id = func;
+-- IF type = 11 THEN
+-- EXECUTE format('SELECT %s($1);', fname)
+-- INTO result USING args;
+-- RETURN result;
+-- ELSIF type = 12 THEN
+-- -- NOTE: forward reference to current step EVAL function
+-- RETURN EVAL(fast, env_new_bindings(fenv, fparams, args));
+-- ELSE
+-- RAISE EXCEPTION 'Invalid function call';
+-- END IF;
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- ---------------------------------------------------------
+-- -- atom functions
+--
+-- -- _atom:
+-- -- takes an ast value_id
+-- -- returns a new atom value_id
+-- CREATE OR REPLACE FUNCTION _atom(val integer) RETURNS integer AS $$
+-- DECLARE
+-- cid integer = NULL;
+-- result integer;
+-- BEGIN
+-- -- Create atom
+-- INSERT INTO value (type_id, val_seq)
+-- VALUES (13, ARRAY[val])
+-- RETURNING value_id INTO result;
+-- RETURN result;
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _atom_Q:
+-- -- takes a value_id
+-- -- returns the whether value_id is an atom
+-- CREATE OR REPLACE FUNCTION _atom_Q(id integer) RETURNS boolean AS $$
+-- BEGIN
+-- RETURN EXISTS(SELECT 1 FROM value WHERE type_id = 13 AND value_id = id);
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _deref:
+-- -- takes an atom value_id
+-- -- returns a atom value value_id
+-- CREATE OR REPLACE FUNCTION _deref(atm integer) RETURNS integer AS $$
+-- DECLARE
+-- result integer;
+-- BEGIN
+-- RETURN (SELECT val_seq[1] FROM value WHERE value_id = atm);
+-- END; $$ LANGUAGE plpgsql;
+--
+-- -- _reset_BANG:
+-- -- takes an atom value_id and new value value_id
+-- -- returns a new value value_id
+-- CREATE OR REPLACE FUNCTION _reset_BANG(atm integer, newval integer) RETURNS integer AS $$
+-- BEGIN
+-- UPDATE value SET val_seq = ARRAY[newval] WHERE value_id = atm;
+-- RETURN newval;
+-- END; $$ LANGUAGE plpgsql;
+
+PROMPT "types.sql finished";
HCoop / jackhill / mal.git / commitdiff