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