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         mem_type;
  19     E         env_pkg.env_entry_table;
  20     repl_env  integer;
  21     x         integer;
  22     line      varchar2(4000);
  23     core_ns   core_ns_type;
  24     cidx      integer;
  25     argv      mal_seq_items_type;
  26     err_val   integer;
  27
  28     -- read
  29     FUNCTION READ(line varchar) RETURN integer IS
  30     BEGIN
  31         RETURN reader.read_str(M, 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_seq_items_type) 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_type).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_type).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 malfunc_type).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   malfunc_type;
  93         fargs   mal_seq_items_type;
  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_type).val_seq;
 100             if M(mac).type_id = 12 THEN
 101                 malfn := TREAT(M(mac) AS malfunc_type);
 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_seq_items_type;
 116         new_seq  mal_seq_items_type;
 117     BEGIN
 118         IF M(ast).type_id = 7 THEN
 119             RETURN env_pkg.env_get(M, E, env, ast);
 120         ELSIF M(ast).type_id IN (8,9) THEN
 121             old_seq := TREAT(M(ast) AS mal_seq_type).val_seq;
 122             new_seq := mal_seq_items_type();
 123             new_seq.EXTEND(old_seq.COUNT);
 124             FOR i IN 1..old_seq.COUNT LOOP
 125                 new_seq(i) := EVAL(old_seq(i), env);
 126             END LOOP;
 127             RETURN types.seq(M, M(ast).type_id, new_seq);
 128         ELSE
 129             RETURN ast;
 130         END IF;
 131     END;
 132
 133     FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS
 134         ast      integer := orig_ast;
 135         env      integer := orig_env;
 136         el       integer;
 137         a0       integer;
 138         a0sym    varchar2(100);
 139         seq      mal_seq_items_type;
 140         let_env  integer;
 141         try_env  integer;
 142         i        integer;
 143         f        integer;
 144         cond     integer;
 145         malfn    malfunc_type;
 146         args     mal_seq_items_type;
 147     BEGIN
 148       WHILE TRUE LOOP
 149         IF M(ast).type_id <> 8 THEN
 150             RETURN eval_ast(ast, env);
 151         END IF;
 152
 153         -- apply
 154         ast := macroexpand(ast, env);
 155         IF M(ast).type_id <> 8 THEN
 156             RETURN eval_ast(ast, env);
 157         END IF;
 158         IF types.count(M, ast) = 0 THEN
 159             RETURN ast;
 160         END IF;
 161
 162         a0 := types.first(M, ast);
 163         if M(a0).type_id = 7 THEN -- symbol
 164             a0sym := TREAT(M(a0) AS mal_str_type).val_str;
 165         ELSE
 166             a0sym := '__<*fn*>__';
 167         END IF;
 168
 169         CASE
 170         WHEN a0sym = 'def!' THEN
 171             RETURN env_pkg.env_set(M, E, env,
 172                 types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env));
 173         WHEN a0sym = 'let*' THEN
 174             let_env := env_pkg.env_new(M, E, env);
 175             seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_type).val_seq;
 176             i := 1;
 177             WHILE i <= seq.COUNT LOOP
 178                 x := env_pkg.env_set(M, E, let_env,
 179                     seq(i), EVAL(seq(i+1), let_env));
 180                 i := i + 2;
 181             END LOOP;
 182             env := let_env;
 183             ast := types.nth(M, ast, 2); -- TCO
 184         WHEN a0sym = 'quote' THEN
 185             RETURN types.nth(M, ast, 1);
 186         WHEN a0sym = 'quasiquote' THEN
 187             RETURN EVAL(quasiquote(types.nth(M, ast, 1)), env);
 188         WHEN a0sym = 'defmacro!' THEN
 189             x := EVAL(types.nth(M, ast, 2), env);
 190             malfn := TREAT(M(x) as malfunc_type);
 191             malfn.is_macro := 1;
 192             M(x) := malfn;
 193             RETURN env_pkg.env_set(M, E, env,
 194                 types.nth(M, ast, 1), x);
 195         WHEN a0sym = 'macroexpand' THEN
 196             RETURN macroexpand(types.nth(M, ast, 1), env);
 197         WHEN a0sym = 'try*' THEN
 198             DECLARE
 199                 exc     integer;
 200                 a2      integer := -1;
 201                 a20     integer := -1;
 202                 a20sym  varchar2(100);
 203             BEGIN
 204                 RETURN EVAL(types.nth(M, ast, 1), env);
 205
 206             EXCEPTION WHEN OTHERS THEN
 207                 IF types.count(M, ast) > 2 THEN
 208                     a2 := types.nth(M, ast, 2);
 209                     IF M(a2).type_id = 8 THEN
 210                         a20 := types.nth(M, a2, 0);
 211                         IF M(a20).type_id = 7 THEN
 212                             a20sym := TREAT(M(a20) AS mal_str_type).val_str;
 213                         END IF;
 214                     END IF;
 215                 END IF;
 216                 IF a20sym = 'catch*' THEN
 217                     IF SQLCODE <> -20000 THEN
 218                         IF SQLCODE < -20000 AND SQLCODE > -20100 THEN
 219                             exc := types.string(M,
 220                                 REGEXP_REPLACE(SQLERRM,
 221                                     '^ORA-200[0-9][0-9]: '));
 222                         ELSE
 223                             exc := types.string(M, SQLERRM);
 224                         END IF;
 225                     ELSE  -- mal throw
 226                         exc := err_val;
 227                         err_val := NULL;
 228                     END IF;
 229                     try_env := env_pkg.env_new(M, E, env,
 230                         types.list(M, types.nth(M, a2, 1)),
 231                         mal_seq_items_type(exc));
 232                     RETURN EVAL(types.nth(M, a2, 2), try_env);
 233                 END IF;
 234                 RAISE; -- not handled, re-raise the exception
 235             END;
 236         WHEN a0sym = 'do' THEN
 237             x := types.slice(M, ast, 1, types.count(M, ast)-2);
 238             x := eval_ast(x, env);
 239             ast := types.nth(M, ast, types.count(M, ast)-1);  -- TCO
 240         WHEN a0sym = 'if' THEN
 241             cond := EVAL(types.nth(M, ast, 1), env);
 242             IF cond = 1 OR cond = 2 THEN  -- nil or false
 243                 IF types.count(M, ast) > 3 THEN
 244                     ast := EVAL(types.nth(M, ast, 3), env);  -- TCO
 245                 ELSE
 246                     RETURN 1;  -- nil
 247                 END IF;
 248             ELSE
 249                 ast := EVAL(types.nth(M, ast, 2), env);  -- TCO
 250             END IF;
 251         WHEN a0sym = 'fn*' THEN
 252             RETURN types.malfunc(M, types.nth(M, ast, 2),
 253                                     types.nth(M, ast, 1),
 254                                     env);
 255         ELSE
 256             el := eval_ast(ast, env);
 257             f := types.first(M, el);
 258             args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_type).val_seq;
 259             IF M(f).type_id = 12 THEN
 260                 malfn := TREAT(M(f) AS malfunc_type);
 261                 env := env_pkg.env_new(M, E, malfn.env,
 262                                           malfn.params, args);
 263                 ast := malfn.ast;  -- TCO
 264             ELSE
 265                 RETURN do_builtin(f, args);
 266             END IF;
 267         END CASE;
 268
 269       END LOOP;
 270
 271     END;
 272
 273     -- hack to get around lack of function references
 274     -- functions that require special access to repl_env or EVAL
 275     -- are implemented directly here, otherwise, core.do_core_fn
 276     -- is called.
 277     FUNCTION do_builtin(fn integer, args mal_seq_items_type) RETURN integer IS
 278         fname   varchar2(100);
 279         val     integer;
 280         f       integer;
 281         malfn   malfunc_type;
 282         fargs   mal_seq_items_type;
 283         fn_env  integer;
 284         i       integer;
 285         tseq    mal_seq_items_type;
 286     BEGIN
 287         fname := TREAT(M(fn) AS mal_str_type).val_str;
 288         CASE
 289         WHEN fname = 'do_eval' THEN
 290             RETURN EVAL(args(1), repl_env);
 291         WHEN fname = 'swap!' THEN
 292             val := TREAT(M(args(1)) AS mal_atom_type).val;
 293             f := args(2);
 294             -- slice one extra at the beginning that will be changed
 295             -- to the value of the atom
 296             fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_type).val_seq;
 297             fargs(1) := val;
 298             IF M(f).type_id = 12 THEN
 299                 malfn := TREAT(M(f) AS malfunc_type);
 300                 fn_env := env_pkg.env_new(M, E, malfn.env,
 301                                           malfn.params, fargs);
 302                 val := EVAL(malfn.ast, fn_env);
 303             ELSE
 304                 val := do_builtin(f, fargs);
 305             END IF;
 306             M(args(1)) := mal_atom_type(13, val);
 307             RETURN val;
 308         WHEN fname = 'apply' THEN
 309             f := args(1);
 310             fargs := mal_seq_items_type();
 311             tseq := TREAT(M(args(args.COUNT())) AS mal_seq_type).val_seq;
 312             fargs.EXTEND(args.COUNT()-2 + tseq.COUNT());
 313             FOR i IN 1..args.COUNT()-2 LOOP
 314                 fargs(i) := args(i+1);
 315             END LOOP;
 316             FOR i IN 1..tseq.COUNT() LOOP
 317                 fargs(args.COUNT()-2 + i) := tseq(i);
 318             END LOOP;
 319             IF M(f).type_id = 12 THEN
 320                 malfn := TREAT(M(f) AS malfunc_type);
 321                 fn_env := env_pkg.env_new(M, E, malfn.env,
 322                                           malfn.params, fargs);
 323                 val := EVAL(malfn.ast, fn_env);
 324             ELSE
 325                 val := do_builtin(f, fargs);
 326             END IF;
 327             RETURN val;
 328         WHEN fname = 'map' THEN
 329             f := args(1);
 330             fargs := TREAT(M(args(2)) AS mal_seq_type).val_seq;
 331             tseq := mal_seq_items_type();
 332             tseq.EXTEND(fargs.COUNT());
 333             IF M(f).type_id = 12 THEN
 334                 malfn := TREAT(M(f) AS malfunc_type);
 335                 FOR i IN 1..fargs.COUNT() LOOP
 336                     fn_env := env_pkg.env_new(M, E, malfn.env,
 337                         malfn.params,
 338                         mal_seq_items_type(fargs(i)));
 339                     tseq(i) := EVAL(malfn.ast, fn_env);
 340                 END LOOP;
 341             ELSE
 342                 FOR i IN 1..fargs.COUNT() LOOP
 343                     tseq(i) := do_builtin(f,
 344                         mal_seq_items_type(fargs(i)));
 345                 END LOOP;
 346             END IF;
 347             RETURN types.seq(M, 8, tseq);
 348         WHEN fname = 'throw' THEN
 349             err_val := args(1);
 350             raise_application_error(-20000, 'MalException', TRUE);
 351         ELSE
 352             RETURN core.do_core_func(M, fn, args);
 353         END CASE;
 354     END;
 355
 356
 357     -- print
 358     FUNCTION PRINT(exp integer) RETURN varchar IS
 359     BEGIN
 360         RETURN printer.pr_str(M, exp);
 361     END;
 362
 363     -- repl
 364     FUNCTION REP(line varchar) RETURN varchar IS
 365     BEGIN
 366         RETURN PRINT(EVAL(READ(line), repl_env));
 367     END;
 368
 369 BEGIN
 370     M := types.mem_new();
 371     E := env_pkg.env_entry_table();
 372
 373     repl_env := env_pkg.env_new(M, E, NULL);
 374
 375     argv := TREAT(M(reader.read_str(M, args)) AS mal_seq_type).val_seq;
 376
 377     -- core.EXT: defined using PL/SQL
 378     core_ns := core.get_core_ns();
 379     FOR cidx IN 1..core_ns.COUNT LOOP
 380         x := env_pkg.env_set(M, E, repl_env,
 381             types.symbol(M, core_ns(cidx)),
 382             types.func(M, core_ns(cidx)));
 383     END LOOP;
 384     x := env_pkg.env_set(M, E, repl_env,
 385         types.symbol(M, 'eval'),
 386         types.func(M, 'do_eval'));
 387     x := env_pkg.env_set(M, E, repl_env,
 388         types.symbol(M, '*ARGV*'),
 389         types.slice(M, argv, 1));
 390
 391     -- core.mal: defined using the language itself
 392     line := REP('(def! *host-language* "PL/SQL")');
 393     line := REP('(def! not (fn* (a) (if a false true)))');
 394     line := REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))');
 395     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)))))))');
 396     line := REP('(def! *gensym-counter* (atom 0))');
 397     line := REP('(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))');
 398     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)))))))))');
 399
 400     IF argv.COUNT() > 0 THEN
 401         line := REP('(load-file "' ||
 402                 TREAT(M(argv(1)) AS mal_str_type).val_str ||
 403                 '")');
 404         RETURN 0;
 405     END IF;
 406
 407     line := REP('(println (str "Mal [" *host-language* "]"))');
 408     WHILE true LOOP
 409         BEGIN
 410             line := stream_readline('user> ', 0);
 411             IF line IS NULL THEN CONTINUE; END IF;
 412             IF line IS NOT NULL THEN
 413                 stream_writeline(REP(line));
 414             END IF;
 415
 416             EXCEPTION WHEN OTHERS THEN
 417                 IF SQLCODE = -20001 THEN  -- io streams closed
 418                     RETURN 0;
 419                 END IF;
 420                 stream_writeline('Error: ' || SQLERRM);
 421                 stream_writeline(dbms_utility.format_error_backtrace);
 422         END;
 423     END LOOP;
 424 END;
 425
 426 END mal;
 427 /
 428 show errors;
 429
 430 quit;