plsql/step7_quote.sql

   1 @io.sql
   2 @types.sql
   3 @reader.sql
   4 @printer.sql
   5 @env.sql
   6 @core.sql
   7
   8 CREATE OR REPLACE PACKAGE mal IS
   9
  10 FUNCTION MAIN(pwd varchar) RETURN integer;
  11
  12 END mal;
  13 /
  14
  15 CREATE OR REPLACE PACKAGE BODY mal IS
  16
  17 FUNCTION MAIN(pwd varchar) RETURN integer IS
  18     M         mem_type;
  19     env_mem   env_mem_type;
  20     repl_env  integer;
  21     x         integer;
  22     line      varchar2(4000);
  23     core_ns   core_ns_type;
  24     cidx      integer;
  25
  26     -- read
  27     FUNCTION READ(line varchar) RETURN integer IS
  28     BEGIN
  29         RETURN reader.read_str(M, line);
  30     END;
  31
  32     -- eval
  33
  34     -- forward declarations
  35     FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer;
  36     FUNCTION do_builtin(fn integer, args mal_seq_type) RETURN integer;
  37
  38     FUNCTION is_pair(ast integer) RETURN BOOLEAN IS
  39     BEGIN
  40         RETURN M(ast).type_id IN (8,9) AND types.count(M, ast) > 0;
  41     END;
  42
  43     FUNCTION quasiquote(ast integer) RETURN integer IS
  44         a0   integer;
  45         a00  integer;
  46     BEGIN
  47         IF NOT is_pair(ast) THEN
  48             RETURN types.list(M, types.symbol(M, 'quote'), ast);
  49         ELSE
  50             a0 := types.nth(M, ast, 0);
  51             IF M(a0).type_id = 7 AND
  52                TREAT(m(a0) AS mal_str_type).val_str = 'unquote' THEN
  53                 RETURN types.nth(M, ast, 1);
  54             ELSIF is_pair(a0) THEN
  55                 a00 := types.nth(M, a0, 0);
  56                 IF M(a00).type_id = 7 AND
  57                    TREAT(M(a00) AS mal_str_type).val_str = 'splice-unquote' THEN
  58                     RETURN types.list(M, types.symbol(M, 'concat'),
  59                                          types.nth(M, a0, 1),
  60                                          quasiquote(types.slice(M, ast, 1)));
  61                 END IF;
  62             END IF;
  63             RETURN types.list(M, types.symbol(M, 'cons'),
  64                                  quasiquote(a0),
  65                                  quasiquote(types.slice(M, ast, 1)));
  66         END IF;
  67     END;
  68
  69     FUNCTION eval_ast(ast integer, env integer) RETURN integer IS
  70         i        integer;
  71         old_seq  mal_seq_items_type;
  72         new_seq  mal_seq_items_type;
  73     BEGIN
  74         IF M(ast).type_id = 7 THEN
  75             RETURN env_pkg.env_get(M, env_mem, env, ast);
  76         ELSIF M(ast).type_id IN (8,9) THEN
  77             old_seq := TREAT(M(ast) AS mal_seq_type).val_seq;
  78             new_seq := mal_seq_items_type();
  79             new_seq.EXTEND(old_seq.COUNT);
  80             FOR i IN 1..old_seq.COUNT LOOP
  81                 new_seq(i) := EVAL(old_seq(i), env);
  82             END LOOP;
  83             RETURN types.seq(M, M(ast).type_id, new_seq);
  84         ELSE
  85             RETURN ast;
  86         END IF;
  87     END;
  88
  89     FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS
  90         ast      integer := orig_ast;
  91         env      integer := orig_env;
  92         el       integer;
  93         a0       integer;
  94         a0sym    varchar2(4000);
  95         seq      mal_seq_items_type;
  96         let_env  integer;
  97         i        integer;
  98         f        integer;
  99         cond     integer;
 100         malfn    malfunc_type;
 101         args     mal_seq_type;
 102     BEGIN
 103       WHILE TRUE LOOP
 104         IF M(ast).type_id <> 8 THEN
 105             RETURN eval_ast(ast, env);
 106         END IF;
 107
 108         -- apply
 109         a0 := types.first(M, ast);
 110         if M(a0).type_id = 7 THEN -- symbol
 111             a0sym := TREAT(M(a0) AS mal_str_type).val_str;
 112         ELSE
 113             a0sym := '__<*fn*>__';
 114         END IF;
 115
 116         CASE
 117         WHEN a0sym = 'def!' THEN
 118             RETURN env_pkg.env_set(M, env_mem, env,
 119                 types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env));
 120         WHEN a0sym = 'let*' THEN
 121             let_env := env_pkg.env_new(M, env_mem, env);
 122             seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_type).val_seq;
 123             i := 1;
 124             WHILE i <= seq.COUNT LOOP
 125                 x := env_pkg.env_set(M, env_mem, let_env,
 126                     seq(i), EVAL(seq(i+1), let_env));
 127                 i := i + 2;
 128             END LOOP;
 129             env := let_env;
 130             ast := types.nth(M, ast, 2); -- TCO
 131         WHEN a0sym = 'quote' THEN
 132             RETURN types.nth(M, ast, 1);
 133         WHEN a0sym = 'quasiquote' THEN
 134             RETURN EVAL(quasiquote(types.nth(M, ast, 1)), env);
 135         WHEN a0sym = 'do' THEN
 136             x := types.slice(M, ast, 1, types.count(M, ast)-2);
 137             x := eval_ast(x, env);
 138             ast := types.nth(M, ast, types.count(M, ast)-1);  -- TCO
 139         WHEN a0sym = 'if' THEN
 140             cond := EVAL(types.nth(M, ast, 1), env);
 141             IF cond = 1 OR cond = 2 THEN  -- nil or false
 142                 IF types.count(M, ast) > 3 THEN
 143                     ast := EVAL(types.nth(M, ast, 3), env);  -- TCO
 144                 ELSE
 145                     RETURN 1;  -- nil
 146                 END IF;
 147             ELSE
 148                 ast := EVAL(types.nth(M, ast, 2), env);  -- TCO
 149             END IF;
 150         WHEN a0sym = 'fn*' THEN
 151             RETURN types.malfunc(M, types.nth(M, ast, 2),
 152                                     types.nth(M, ast, 1),
 153                                     env);
 154         ELSE
 155             el := eval_ast(ast, env);
 156             f := types.first(M, el);
 157             args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_type);
 158             IF M(f).type_id = 12 THEN
 159                 malfn := TREAT(M(f) AS malfunc_type);
 160                 env := env_pkg.env_new(M, env_mem, malfn.env,
 161                                           malfn.params, args);
 162                 ast := malfn.ast;  -- TCO
 163             ELSE
 164                 RETURN do_builtin(f, args);
 165             END IF;
 166         END CASE;
 167
 168       END LOOP;
 169
 170     END;
 171
 172     -- hack to get around lack of function references
 173     -- functions that require special access to repl_env or EVAL
 174     -- are implemented directly here, otherwise, core.do_core_fn
 175     -- is called.
 176     FUNCTION do_builtin(fn integer, args mal_seq_type) RETURN integer IS
 177         fname   varchar2(100);
 178         sargs   mal_seq_items_type := args.val_seq;
 179         aval    integer;
 180         f       integer;
 181         malfn   malfunc_type;
 182         fargs   mal_seq_items_type;
 183         fn_env  integer;
 184     BEGIN
 185         fname := TREAT(M(fn) AS mal_str_type).val_str;
 186         CASE
 187         WHEN fname = 'do_eval' THEN
 188             RETURN EVAL(sargs(1), repl_env);
 189         WHEN fname = 'swap!' THEN
 190             aval := TREAT(M(sargs(1)) AS mal_atom_type).val;
 191             f := sargs(2);
 192             -- slice one extra at the beginning that will be changed
 193             -- to the value of the atom
 194             fargs := TREAT(M(types.slice(M, sargs, 1)) AS mal_seq_type).val_seq;
 195             fargs(1) := aval;
 196             IF M(f).type_id = 12 THEN
 197                 malfn := TREAT(M(f) AS malfunc_type);
 198                 fn_env := env_pkg.env_new(M, env_mem, malfn.env,
 199                                           malfn.params,
 200                                           mal_seq_type(8, fargs));
 201                 aval := EVAL(malfn.ast, fn_env);
 202             ELSE
 203                 aval := do_builtin(f, mal_seq_type(8, fargs));
 204             END IF;
 205             M(sargs(1)) := mal_atom_type(13, aval);
 206             RETURN aval;
 207         ELSE
 208             RETURN core.do_core_func(M, fn, sargs);
 209         END CASE;
 210     END;
 211
 212
 213     -- print
 214     FUNCTION PRINT(exp integer) RETURN varchar IS
 215     BEGIN
 216         RETURN printer.pr_str(M, exp);
 217     END;
 218
 219     -- repl
 220     FUNCTION REP(line varchar) RETURN varchar IS
 221     BEGIN
 222         RETURN PRINT(EVAL(READ(line), repl_env));
 223     END;
 224
 225 BEGIN
 226     M := types.mem_new();
 227     env_mem := env_mem_type();
 228
 229     repl_env := env_pkg.env_new(M, env_mem, NULL);
 230
 231     -- core.EXT: defined using PL/SQL
 232     core_ns := core.get_core_ns();
 233     FOR cidx IN 1..core_ns.COUNT LOOP
 234         x := env_pkg.env_set(M, env_mem, repl_env,
 235             types.symbol(M, core_ns(cidx)),
 236             types.func(M, core_ns(cidx)));
 237     END LOOP;
 238     x := env_pkg.env_set(M, env_mem, repl_env,
 239         types.symbol(M, 'eval'),
 240         types.func(M, 'do_eval'));
 241     x := env_pkg.env_set(M, env_mem, repl_env,
 242         types.symbol(M, '*ARGV*'),
 243         types.list(M));
 244
 245     -- core.mal: defined using the language itself
 246     line := REP('(def! not (fn* (a) (if a false true)))');
 247     line := REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))');
 248
 249     WHILE true LOOP
 250         BEGIN
 251             line := stream_readline('user> ', 0);
 252             IF line IS NULL THEN CONTINUE; END IF;
 253             IF line IS NOT NULL THEN
 254                 stream_writeline(REP(line));
 255             END IF;
 256
 257             EXCEPTION WHEN OTHERS THEN
 258                 IF SQLCODE = -20000 THEN
 259                     RETURN 0;
 260                 END IF;
 261                 stream_writeline('Error: ' || SQLERRM);
 262                 stream_writeline(dbms_utility.format_error_backtrace);
 263         END;
 264     END LOOP;
 265 END;
 266
 267 END mal;
 268 /
 269 show errors;
 270
 271 quit;