plsql/step6_file.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 eval_ast(ast integer, env integer) RETURN integer IS
  41         i         integer;
  42         old_seq   mal_vals;
  43         new_seq   mal_vals;
  44         new_hm    integer;
  45         old_midx  integer;
  46         new_midx  integer;
  47         k         varchar2(256);
  48     BEGIN
  49         IF M(ast).type_id = 7 THEN
  50             RETURN env_pkg.env_get(M, E, env, ast);
  51         ELSIF M(ast).type_id IN (8,9) THEN
  52             old_seq := TREAT(M(ast) AS mal_seq_T).val_seq;
  53             new_seq := mal_vals();
  54             new_seq.EXTEND(old_seq.COUNT);
  55             FOR i IN 1..old_seq.COUNT LOOP
  56                 new_seq(i) := EVAL(old_seq(i), env);
  57             END LOOP;
  58             RETURN types.seq(M, M(ast).type_id, new_seq);
  59         ELSIF M(ast).type_id IN (10) THEN
  60             new_hm := types.hash_map(M, H, mal_vals());
  61             old_midx := TREAT(M(ast) AS mal_map_T).map_idx;
  62             new_midx := TREAT(M(new_hm) AS mal_map_T).map_idx;
  63
  64             k := H(old_midx).FIRST();
  65             WHILE k IS NOT NULL LOOP
  66                 H(new_midx)(k) := EVAL(H(old_midx)(k), env);
  67                 k := H(old_midx).NEXT(k);
  68             END LOOP;
  69             RETURN new_hm;
  70         ELSE
  71             RETURN ast;
  72         END IF;
  73     END;
  74
  75     FUNCTION EVAL(orig_ast integer, orig_env integer) RETURN integer IS
  76         ast      integer := orig_ast;
  77         env      integer := orig_env;
  78         el       integer;
  79         a0       integer;
  80         a0sym    varchar2(100);
  81         seq      mal_vals;
  82         let_env  integer;
  83         i        integer;
  84         f        integer;
  85         cond     integer;
  86         malfn    mal_func_T;
  87         args     mal_vals;
  88     BEGIN
  89       WHILE TRUE LOOP
  90         -- io.writeline('EVAL: ' || printer.pr_str(M, ast));
  91         IF M(ast).type_id <> 8 THEN
  92             RETURN eval_ast(ast, env);
  93         END IF;
  94         IF types.count(M, ast) = 0 THEN
  95             RETURN ast; -- empty list just returned
  96         END IF;
  97
  98         -- apply
  99         a0 := types.first(M, ast);
 100         if M(a0).type_id = 7 THEN -- symbol
 101             a0sym := TREAT(M(a0) AS mal_str_T).val_str;
 102         ELSE
 103             a0sym := '__<*fn*>__';
 104         END IF;
 105
 106         CASE
 107         WHEN a0sym = 'def!' THEN
 108             RETURN env_pkg.env_set(M, E, env,
 109                 types.nth(M, ast, 1), EVAL(types.nth(M, ast, 2), env));
 110         WHEN a0sym = 'let*' THEN
 111             let_env := env_pkg.env_new(M, E, env);
 112             seq := TREAT(M(types.nth(M, ast, 1)) AS mal_seq_T).val_seq;
 113             i := 1;
 114             WHILE i <= seq.COUNT LOOP
 115                 x := env_pkg.env_set(M, E, let_env,
 116                     seq(i), EVAL(seq(i+1), let_env));
 117                 i := i + 2;
 118             END LOOP;
 119             env := let_env;
 120             ast := types.nth(M, ast, 2); -- TCO
 121         WHEN a0sym = 'do' THEN
 122             x := types.slice(M, ast, 1, types.count(M, ast)-2);
 123             x := eval_ast(x, env);
 124             ast := types.nth(M, ast, types.count(M, ast)-1);  -- TCO
 125         WHEN a0sym = 'if' THEN
 126             cond := EVAL(types.nth(M, ast, 1), env);
 127             IF cond = 1 OR cond = 2 THEN  -- nil or false
 128                 IF types.count(M, ast) > 3 THEN
 129                     ast := types.nth(M, ast, 3);  -- TCO
 130                 ELSE
 131                     RETURN 1;  -- nil
 132                 END IF;
 133             ELSE
 134                 ast := types.nth(M, ast, 2);  -- TCO
 135             END IF;
 136         WHEN a0sym = 'fn*' THEN
 137             RETURN types.malfunc(M, types.nth(M, ast, 2),
 138                                     types.nth(M, ast, 1),
 139                                     env);
 140         ELSE
 141             el := eval_ast(ast, env);
 142             f := types.first(M, el);
 143             args := TREAT(M(types.slice(M, el, 1)) AS mal_seq_T).val_seq;
 144             IF M(f).type_id = 12 THEN
 145                 malfn := TREAT(M(f) AS mal_func_T);
 146                 env := env_pkg.env_new(M, E, malfn.env,
 147                                           malfn.params, args);
 148                 ast := malfn.ast;  -- TCO
 149             ELSE
 150                 RETURN do_builtin(f, args);
 151             END IF;
 152         END CASE;
 153
 154       END LOOP;
 155
 156     END;
 157
 158     -- hack to get around lack of function references
 159     -- functions that require special access to repl_env or EVAL
 160     -- are implemented directly here, otherwise, core.do_core_fn
 161     -- is called.
 162     FUNCTION do_builtin(fn integer, args mal_vals) RETURN integer IS
 163         fname   varchar2(100);
 164         val     integer;
 165         f       integer;
 166         malfn   mal_func_T;
 167         fargs   mal_vals;
 168         fn_env  integer;
 169     BEGIN
 170         fname := TREAT(M(fn) AS mal_str_T).val_str;
 171         CASE
 172         WHEN fname = 'do_eval' THEN
 173             RETURN EVAL(args(1), repl_env);
 174         WHEN fname = 'swap!' THEN
 175             val := TREAT(M(args(1)) AS mal_atom_T).val;
 176             f := args(2);
 177             -- slice one extra at the beginning that will be changed
 178             -- to the value of the atom
 179             fargs := TREAT(M(types.slice(M, args, 1)) AS mal_seq_T).val_seq;
 180             fargs(1) := val;
 181             IF M(f).type_id = 12 THEN
 182                 malfn := TREAT(M(f) AS mal_func_T);
 183                 fn_env := env_pkg.env_new(M, E, malfn.env,
 184                                           malfn.params, fargs);
 185                 val := EVAL(malfn.ast, fn_env);
 186             ELSE
 187                 val := do_builtin(f, fargs);
 188             END IF;
 189             RETURN types.atom_reset(M, args(1), val);
 190         ELSE
 191             RETURN core.do_core_func(M, H, fn, args);
 192         END CASE;
 193     END;
 194
 195
 196     -- print
 197     FUNCTION PRINT(exp integer) RETURN varchar IS
 198     BEGIN
 199         RETURN printer.pr_str(M, H, exp);
 200     END;
 201
 202     -- repl
 203     FUNCTION REP(line varchar) RETURN varchar IS
 204     BEGIN
 205         RETURN PRINT(EVAL(READ(line), repl_env));
 206     END;
 207
 208 BEGIN
 209     -- initialize memory pools
 210     M := types.mem_new();
 211     H := types.map_entry_table();
 212     E := env_pkg.env_entry_table();
 213
 214     repl_env := env_pkg.env_new(M, E, NULL);
 215
 216     argv := TREAT(M(reader.read_str(M, H, args)) AS mal_seq_T).val_seq;
 217
 218     -- core.EXT: defined using PL/SQL
 219     core_ns := core.get_core_ns();
 220     FOR cidx IN 1..core_ns.COUNT LOOP
 221         x := env_pkg.env_set(M, E, repl_env,
 222             types.symbol(M, core_ns(cidx)),
 223             types.func(M, core_ns(cidx)));
 224     END LOOP;
 225     x := env_pkg.env_set(M, E, repl_env,
 226         types.symbol(M, 'eval'),
 227         types.func(M, 'do_eval'));
 228     x := env_pkg.env_set(M, E, repl_env,
 229         types.symbol(M, '*ARGV*'),
 230         types.slice(M, argv, 1));
 231
 232     -- core.mal: defined using the language itself
 233     line := REP('(def! not (fn* (a) (if a false true)))');
 234     line := REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))');
 235
 236     IF argv.COUNT() > 0 THEN
 237         BEGIN
 238             line := REP('(load-file "' ||
 239                     TREAT(M(argv(1)) AS mal_str_T).val_str ||
 240                     '")');
 241             io.close(1);  -- close output stream
 242             RETURN 0;
 243         EXCEPTION WHEN OTHERS THEN
 244             io.writeline('Error: ' || SQLERRM);
 245             io.writeline(dbms_utility.format_error_backtrace);
 246             io.close(1);  -- close output stream
 247             RAISE;
 248         END;
 249     END IF;
 250
 251     WHILE true LOOP
 252         BEGIN
 253             line := io.readline('user> ', 0);
 254             IF line = EMPTY_CLOB() THEN CONTINUE; END IF;
 255             IF line IS NOT NULL THEN
 256                 io.writeline(REP(line));
 257             END IF;
 258
 259             EXCEPTION WHEN OTHERS THEN
 260                 IF SQLCODE = -20001 THEN  -- io read stream closed
 261                     io.close(1);  -- close output stream
 262                     RETURN 0;
 263                 END IF;
 264                 io.writeline('Error: ' || SQLERRM);
 265                 io.writeline(dbms_utility.format_error_backtrace);
 266         END;
 267     END LOOP;
 268 END;
 269
 270 END mal;
 271 /
 272 show errors;
 273
 274 quit;