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