plsql/stepA_mal.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     err_val   integer;
  28
  29     -- read
  30     FUNCTION READ(line varchar) RETURN integer IS
  31     BEGIN
  32         RETURN reader.read_str(M, H, line);
  33     END;
  34
  35     -- eval
  36
  37     -- forward declarations
  38     FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer;
  39     FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer;
  40
  41     FUNCTION is_pair(ast integer) RETURN BOOLEAN IS
  42     BEGIN
  43         RETURN M(ast).type_id IN (8,9) AND types.count(M, ast) > 0;
  44     END;
  45
  46     FUNCTION quasiquote(ast integer) RETURN integer IS
  47         a0   integer;
  48         a00  integer;
  49     BEGIN
  50         IF NOT is_pair(ast) THEN
  51             RETURN types.list(M, types.symbol(M, 'quote'), ast);
  52         ELSE
  53             a0 := types.nth(M, ast, 0);
  54             IF M(a0).type_id = 7 AND
  55                TREAT(m(a0) AS mal_str_T).val_str = 'unquote' THEN
  56                 RETURN types.nth(M, ast, 1);
  57             ELSIF is_pair(a0) THEN
  58                 a00 := types.nth(M, a0, 0);
  59                 IF M(a00).type_id = 7 AND
  60                    TREAT(M(a00) AS mal_str_T).val_str = 'splice-unquote' THEN
  61                     RETURN types.list(M, types.symbol(M, 'concat'),
  62                                          types.nth(M, a0, 1),
  63                                          quasiquote(types.slice(M, ast, 1)));
  64                 END IF;
  65             END IF;
  66             RETURN types.list(M, types.symbol(M, 'cons'),
  67                                  quasiquote(a0),
  68                                  quasiquote(types.slice(M, ast, 1)));
  69         END IF;
  70     END;
  71
  72
  73     FUNCTION is_macro_call(ast integer, env integer) RETURN BOOLEAN IS
  74         a0   integer;
  75         mac  integer;
  76     BEGIN
  77         IF M(ast).type_id = 8 THEN
  78             a0 := types.nth(M, ast, 0);
  79             IF M(a0).type_id = 7 AND
  80                env_pkg.env_find(M, E, env, a0) IS NOT NULL THEN
  81                 mac := env_pkg.env_get(M, E, env, a0);
  82                 IF M(mac).type_id = 12 THEN
  83                     RETURN TREAT(M(mac) AS mal_func_T).is_macro > 0;
  84                 END IF;
  85             END IF;
  86         END IF;
  87         RETURN FALSE;
  88     END;
  89
  90     FUNCTION macroexpand(orig_ast integer, env integer) RETURN integer IS
  91         ast     integer;
  92         mac     integer;
  93         malfn   mal_func_T;
  94         fargs   mal_vals;
  95         fn_env  integer;
  96     BEGIN
  97         ast := orig_ast;
  98         WHILE is_macro_call(ast, env) LOOP
  99             mac := env_pkg.env_get(M, E, env, types.nth(M, ast, 0));
 100             fargs := TREAT(M(types.slice(M, ast, 1)) as mal_seq_T).val_seq;
 101             if M(mac).type_id = 12 THEN
 102                 malfn := TREAT(M(mac) AS mal_func_T);
 103                 fn_env := env_pkg.env_new(M, E, malfn.env,
 104                                           malfn.params,
 105                                           fargs);
 106                 ast := EVAL(malfn.ast, fn_env);
 107             ELSE
 108                 ast := do_builtin(mac, fargs);
 109             END IF;
 110         END LOOP;
 111         RETURN ast;
 112     END;
 113
 114     FUNCTION eval_ast(ast integer, env integer) RETURN integer IS
 115         i         integer;
 116         old_seq   mal_vals;
 117         new_seq   mal_vals;
 118         new_hm    integer;
 119         old_midx  integer;
 120         new_midx  integer;
 121         k         varchar2(256);
 122     BEGIN
 123         IF M(ast).type_id = 7 THEN
 124             RETURN env_pkg.env_get(M, E, env, ast);
 125         ELSIF M(ast).type_id IN (8,9) THEN
 126             old_seq := TREAT(M(ast) AS mal_seq_T).val_seq;
 127             new_seq := mal_vals();
 128             new_seq.EXTEND(old_seq.COUNT);
 129             FOR i IN 1..old_seq.COUNT LOOP
 130                 new_seq(i) := EVAL(old_seq(i), env);
 131             END LOOP;
 132             RETURN types.seq(M, M(ast).type_id, new_seq);
 133         ELSIF M(ast).type_id IN (10) THEN
 134             new_hm := types.hash_map(M, H, mal_vals());
 135             old_midx := TREAT(M(ast) AS mal_map_T).map_idx;
 136             new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx;
 137
 138             k := H(old_midx).FIRST();
 139             WHILE k IS NOT NULL LOOP
 140                 H(new_midx)(k) := EVAL(H(old_midx)(k), env);
 141                 k := H(old_midx).NEXT(k);
 142             END LOOP;
 143             RETURN new_hm;
 144         ELSE
 145             RETURN ast;
 146         END IF;
 147     END;
 148
 149     FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS
 150         ast      integer := orig_ast;
 151         env      integer := orig_env;
 152         el       integer;
 153         a0       integer;
 154         a0sym    varchar2(100);
 155         seq      mal_vals;
 156         let_env  integer;
 157         try_env  integer;
 158         i        integer;
 159         f        integer;
 160         cond     integer;
 161         malfn    mal_func_T;
 162         args     mal_vals;
 163     BEGIN
 164       WHILE TRUE LOOP
 165         -- io.writeline('EVAL: ' || printer.pr_str(M, H, ast));
 166         IF M(ast).type_id <> 8 THEN
 167             RETURN eval_ast(ast, env);
 168         END IF;
 169
 170         -- apply
 171         ast := macroexpand(ast, env);
 172         IF M(ast).type_id <> 8 THEN
 173             RETURN eval_ast(ast, env);
 174         END IF;
 175         IF types.count(M, ast) = 0 THEN
 176             RETURN ast; -- empty list just returned
 177         END IF;
 178
 179         -- apply
 180         a0 := types.first(M, ast);
 181         if M(a0).type_id = 7 THEN -- symbol
 182             a0sym := TREAT(M(a0) AS mal_str_T).val_str;
 183         ELSE
 184             a0sym := '__<*fn*>__';
 185         END IF;
 186
 187         CASE
 188         WHEN a0sym = 'def!' THEN
 189             RETURN env_pkg.env_set(M, E, env,
 190                 types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env));
 191         WHEN a0sym = 'let*' THEN
 192             let_env := env_pkg.env_new(M, E, env);
 193             seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq;
 194             i := 1;
 195             WHILE i <= seq.COUNT LOOP
 196                 x := env_pkg.env_set(M, E, let_env,
 197                     seq(i), EVAL(seq(i+1), let_env));
 198                 i := i + 2;
 199             END LOOP;
 200             env := let_env;
 201             ast := types.nth(M, ast, 2); -- TCO
 202         WHEN a0sym = 'quote' THEN
 203             RETURN types.nth(M, ast, 1);
 204         WHEN a0sym = 'quasiquote' THEN
 205             RETURN EVAL(quasiquote(types.nth(M, ast, 1)), env);
 206         WHEN a0sym = 'defmacro!' THEN
 207             x := EVAL(types.nth(M, ast, 2), env);
 208             malfn := TREAT(M(x) as mal_func_T);
 209             malfn.is_macro := 1;
 210             M(x) := malfn;
 211             RETURN env_pkg.env_set(M, E, env,
 212                 types.nth(M, ast, 1), x);
 213         WHEN a0sym = 'macroexpand' THEN
 214             RETURN macroexpand(types.nth(M, ast, 1), env);
 215         WHEN a0sym = 'try*' THEN
 216             DECLARE
 217                 exc     integer;
 218                 a2      integer := -1;
 219                 a20     integer := -1;
 220                 a20sym  varchar2(100);
 221             BEGIN
 222                 RETURN EVAL(types.nth(M, ast, 1), env);
 223
 224             EXCEPTION WHEN OTHERS THEN
 225                 IF types.count(M, ast) > 2 THEN
 226                     a2 := types.nth(M, ast, 2);
 227                     IF M(a2).type_id = 8 THEN
 228                         a20 := types.nth(M, a2, 0);
 229                         IF M(a20).type_id = 7 THEN
 230                             a20sym := TREAT(M(a20) AS mal_str_T).val_str;
 231                         END IF;
 232                     END IF;
 233                 END IF;
 234                 IF a20sym = 'catch*' THEN
 235                     IF SQLCODE <> -20000 THEN
 236                         IF SQLCODE < -20000 AND SQLCODE > -20100 THEN
 237                             exc := types.string(M,
 238                                 REGEXP_REPLACE(SQLERRM,
 239                                     '^ORA-200[0-9][0-9]: '));
 240                         ELSE
 241                             exc := types.string(M, SQLERRM);
 242                         END IF;
 243                     ELSE  -- mal throw
 244                         exc := err_val;
 245                         err_val := NULL;
 246                     END IF;
 247                     try_env := env_pkg.env_new(M, E, env,
 248                         types.list(M, types.nth(M, a2, 1)),
 249                         mal_vals(exc));
 250                     RETURN EVAL(types.nth(M, a2, 2), try_env);
 251                 END IF;
 252                 RAISE; -- not handled, re-raise the exception
 253             END;
 254         WHEN a0sym = 'do' THEN
 255             x := types.slice(M, ast, 1, types.count(M, ast)-2);
 256             x := eval_ast(x, env);
 257             ast := types.nth(M, ast, types.count(M, ast)-1);  -- TCO
 258         WHEN a0sym = 'if' THEN
 259             cond := EVAL(types.nth(M, ast, 1), env);
 260             IF cond = 1 OR cond = 2 THEN  -- nil or false
 261                 IF types.count(M, ast) > 3 THEN
 262                     ast := types.nth(M, ast, 3);  -- TCO
 263                 ELSE
 264                     RETURN 1;  -- nil
 265                 END IF;
 266             ELSE
 267                 ast := types.nth(M, ast, 2);  -- TCO
 268             END IF;
 269         WHEN a0sym = 'fn*' THEN
 270             RETURN types.malfunc(M, types.nth(M, ast, 2),
 271                                     types.nth(M, ast, 1),
 272                                     env);
 273         ELSE
 274             el := eval_ast(ast, env);
 275             f := types.first(M, el);
 276             args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq;
 277             IF M(f).type_id = 12 THEN
 278                 malfn := TREAT(M(f) AS mal_func_T);
 279                 env := env_pkg.env_new(M, E, malfn.env,
 280                                           malfn.params, args);
 281                 ast := malfn.ast;  -- TCO
 282             ELSE
 283                 RETURN do_builtin(f, args);
 284             END IF;
 285         END CASE;
 286
 287       END LOOP;
 288
 289     END;
 290
 291     -- hack to get around lack of function references
 292     -- functions that require special access to repl_env or EVAL
 293     -- are implemented directly here, otherwise, core.do_core_fn
 294     -- is called.
 295     FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer IS
 296         fname   varchar2(100);
 297         val     integer;
 298         f       integer;
 299         malfn   mal_func_T;
 300         fargs   mal_vals;
 301         fn_env  integer;
 302         i       integer;
 303         tseq    mal_vals;
 304     BEGIN
 305         fname := TREAT(M(fn) AS mal_str_T).val_str;
 306         CASE
 307         WHEN fname = 'do_eval' THEN
 308             RETURN EVAL(args(1), repl_env);
 309         WHEN fname = 'swap!' THEN
 310             val := TREAT(M(args(1)) AS mal_atom_T).val;
 311             f := args(2);
 312             -- slice one extra at the beginning that will be changed
 313             -- to the value of the atom
 314             fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_T).val_seq;
 315             fargs(1) := val;
 316             IF M(f).type_id = 12 THEN
 317                 malfn := TREAT(M(f) AS mal_func_T);
 318                 fn_env := env_pkg.env_new(M, E, malfn.env,
 319                                           malfn.params, fargs);
 320                 val := EVAL(malfn.ast, fn_env);
 321             ELSE
 322                 val := do_builtin(f, fargs);
 323             END IF;
 324             RETURN types.atom_reset(M, args(1), val);
 325         WHEN fname = 'apply' THEN
 326             f := args(1);
 327             fargs := mal_vals();
 328             tseq := TREAT(M(args(args.COUNT())) AS mal_seq_T).val_seq;
 329             fargs.EXTEND(args.COUNT()-2 + tseq.COUNT());
 330             FOR i IN 1..args.COUNT()-2 LOOP
 331                 fargs(i) := args(i+1);
 332             END LOOP;
 333             FOR i IN 1..tseq.COUNT() LOOP
 334                 fargs(args.COUNT()-2 + i) := tseq(i);
 335             END LOOP;
 336             IF M(f).type_id = 12 THEN
 337                 malfn := TREAT(M(f) AS mal_func_T);
 338                 fn_env := env_pkg.env_new(M, E, malfn.env,
 339                                           malfn.params, fargs);
 340                 val := EVAL(malfn.ast, fn_env);
 341             ELSE
 342                 val := do_builtin(f, fargs);
 343             END IF;
 344             RETURN val;
 345         WHEN fname = 'map' THEN
 346             f := args(1);
 347             fargs := TREAT(M(args(2)) AS mal_seq_T).val_seq;
 348             tseq := mal_vals();
 349             tseq.EXTEND(fargs.COUNT());
 350             IF M(f).type_id = 12 THEN
 351                 malfn := TREAT(M(f) AS mal_func_T);
 352                 FOR i IN 1..fargs.COUNT() LOOP
 353                     fn_env := env_pkg.env_new(M, E, malfn.env,
 354                         malfn.params,
 355                         mal_vals(fargs(i)));
 356                     tseq(i) := EVAL(malfn.ast, fn_env);
 357                 END LOOP;
 358             ELSE
 359                 FOR i IN 1..fargs.COUNT() LOOP
 360                     tseq(i) := do_builtin(f,
 361                         mal_vals(fargs(i)));
 362                 END LOOP;
 363             END IF;
 364             RETURN types.seq(M, 8, tseq);
 365         WHEN fname = 'throw' THEN
 366             err_val := args(1);
 367             raise_application_error(-20000, 'MalException', TRUE);
 368         ELSE
 369             RETURN core.do_core_func(M, H, fn, args);
 370         END CASE;
 371     END;
 372
 373
 374     -- print
 375     FUNCTION PRINT(exp integer) RETURN varchar IS
 376     BEGIN
 377         RETURN printer.pr_str(M, H, exp);
 378     END;
 379
 380     -- repl
 381     FUNCTION REP(line varchar) RETURN varchar IS
 382     BEGIN
 383         RETURN PRINT(EVAL(READ(line), repl_env));
 384     END;
 385
 386 BEGIN
 387     -- initialize memory pools
 388     M := types.mem_new();
 389     H := types.map_entry_table();
 390     E := env_pkg.env_entry_table();
 391
 392     repl_env := env_pkg.env_new(M, E, NULL);
 393
 394     argv := TREAT(M(reader.read_str(M, H, args)) AS mal_seq_T).val_seq;
 395
 396     -- core.EXT: defined using PL/SQL
 397     core_ns := core.get_core_ns();
 398     FOR cidx IN 1..core_ns.COUNT LOOP
 399         x := env_pkg.env_set(M, E, repl_env,
 400             types.symbol(M, core_ns(cidx)),
 401             types.func(M, core_ns(cidx)));
 402     END LOOP;
 403     x := env_pkg.env_set(M, E, repl_env,
 404         types.symbol(M, 'eval'),
 405         types.func(M, 'do_eval'));
 406     x := env_pkg.env_set(M, E, repl_env,
 407         types.symbol(M, '*ARGV*'),
 408         types.slice(M, argv, 1));
 409
 410     -- core.mal: defined using the language itself
 411     line := REP('(def! *host-language* "PL/SQL")');
 412     line := REP('(def! not (fn* (a) (if a false true)))');
 413     line := REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))');
 414     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)))))))');
 415     line := REP('(def! *gensym-counter* (atom 0))');
 416     line := REP('(def! gensym (fn* [] (symbol (str "G__" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))');
 417     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)))))))))');
 418
 419     IF argv.COUNT() > 0 THEN
 420         BEGIN
 421             line := REP('(load-file "' ||
 422                     TREAT(M(argv(1)) AS mal_str_T).val_str ||
 423                     '")');
 424             io.close(1);  -- close output stream
 425             RETURN 0;
 426         EXCEPTION WHEN OTHERS THEN
 427             io.writeline('Error: ' || SQLERRM);
 428             io.writeline(dbms_utility.format_error_backtrace);
 429             io.close(1);  -- close output stream
 430             RAISE;
 431         END;
 432     END IF;
 433
 434     line := REP('(println (str "Mal [" *host-language* "]"))');
 435     WHILE true LOOP
 436         BEGIN
 437             line := io.readline('user> ', 0);
 438             IF line = EMPTY_CLOB() THEN CONTINUE; END IF;
 439             IF line IS NOT NULL THEN
 440                 io.writeline(REP(line));
 441             END IF;
 442
 443             EXCEPTION WHEN OTHERS THEN
 444                 IF SQLCODE = -20001 THEN  -- io read stream closed
 445                     io.close(1);  -- close output stream
 446                     RETURN 0;
 447                 END IF;
 448                 IF SQLCODE <> -20000 THEN
 449                     io.writeline('Error: ' || SQLERRM);
 450                 ELSE
 451                     io.writeline('Error: ' || printer.pr_str(M, H, err_val));
 452                 END IF;
 453                 io.writeline(dbms_utility.format_error_backtrace);
 454         END;
 455     END LOOP;
 456 END;
 457
 458 END mal;
 459 /
 460 show errors;
 461
 462 quit;