[jackhill/mal.git] / awk / step4_if_fn_do.awk

@include "types.awk"
@include "reader.awk"
@include "printer.awk"
@include "env.awk"
@include "core.awk"

function READ(str)
{
	return reader_read_str(str)
}

function eval_ast(ast, env,    i, idx, len, new_idx, ret)
{
	switch (ast) {
	case /^'/:
		ret = env_get(env, ast)
		if (ret !~ /^!/) {
			types_addref(ret)
		}
		return ret
	case /^[([]/:
		idx = substr(ast, 2)
		len = types_heap[idx]["len"]
		new_idx = types_allocate()
		for (i = 0; i < len; ++i) {
			ret = EVAL(types_addref(types_heap[idx][i]), env)
			if (ret ~ /^!/) {
				types_heap[new_idx]["len"] = i
				types_release(substr(ast, 1, 1) new_idx)
				return ret
			}
			types_heap[new_idx][i] = ret
		}
		types_heap[new_idx]["len"] = len
		return substr(ast, 1, 1) new_idx
	case /^\{/:
		idx = substr(ast, 2)
		new_idx = types_allocate()
		for (i in types_heap[idx]) {
			if (i ~ /^[":]/) {
				ret = EVAL(types_addref(types_heap[idx][i]), env)
				if (ret ~ /^!/) {
					types_release("{" new_idx)
					return ret
				}
				types_heap[new_idx][i] = ret
			}
		}
		return "{" new_idx
	default:
		return ast
	}
}

function EVAL_def(ast, env,    idx, sym, ret, len)
{
	idx = substr(ast, 2)
	if (types_heap[idx]["len"] != 3) {
		len = types_heap[idx]["len"]
		types_release(ast)
		env_release(env)
		return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "."
	}
	sym = types_heap[idx][1]
	if (sym !~ /^'/) {
		types_release(ast)
		env_release(env)
		return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "."
	}
	ret = EVAL(types_addref(types_heap[idx][2]), env)
	if (ret !~ /^!/) {
		env_set(env, sym, ret)
		types_addref(ret)
	}
	types_release(ast)
	env_release(env)
	return ret
}

function EVAL_let(ast, env,    idx, params, params_idx, params_len, new_env, i, sym, ret, body, len)
{
	idx = substr(ast, 2)
	if (types_heap[idx]["len"] != 3) {
		len = types_heap[idx]["len"]
		types_release(ast)
		env_release(env)
		return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "."
	}
	params = types_heap[idx][1]
	if (params !~ /^[([]/) {
		types_release(ast)
		env_release(env)
		return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "."
	}
	params_idx = substr(params, 2)
	params_len = types_heap[params_idx]["len"]
	if (params_len % 2 != 0) {
		types_release(ast)
		env_release(env)
		return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "."
	}
	new_env = env_new(env)
	env_release(env)
	for (i = 0; i < params_len; i += 2) {
		sym = types_heap[params_idx][i]
		if (sym !~ /^'/) {
			types_release(ast)
			env_release(new_env)
			return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "."
		}
		ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env)
		if (ret ~ /^!/) {
			types_release(ast)
			env_release(new_env)
			return ret
		}
		env_set(new_env, sym, ret)
	}
	types_addref(body = types_heap[idx][2])
	types_release(ast)
	ret = EVAL(body, new_env)
	env_release(new_env)
	return ret
}

function EVAL_do(ast, env,    idx, len, i, ret)
{
	idx = substr(ast, 2)
	len = types_heap[idx]["len"]
	if (len == 1) {
		types_release(ast)
		env_release(env)
		return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "."
	}
	for (i = 1; i < len - 1; ++i) {
		ret = EVAL(types_addref(types_heap[idx][i]), env)
		if (ret ~ /^!/) {
			types_release(ast)
			env_release(env)
			return ret
		}
		types_release(ret)
	}
	ret = EVAL(types_addref(types_heap[idx][len - 1]), env)
	types_release(ast)
	env_release(env)
	return ret
}

function EVAL_if(ast, env,    idx, len, ret, body)
{
	idx = substr(ast, 2)
	len = types_heap[idx]["len"]
	if (len != 3 && len != 4) {
		types_release(ast)
		env_release(env)
		return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "."
	}
	ret = EVAL(types_addref(types_heap[idx][1]), env)
	if (ret ~ /^!/) {
		types_release(ast)
		env_release(env)
		return ret
	}
	types_release(ret)
	switch (ret) {
	case "#nil":
	case "#false":
		if (len == 3) {
			types_release(ast)
			env_release(env)
			return "#nil"
		} else {
			types_addref(body = types_heap[idx][3])
		}
		break
	default:
		types_addref(body = types_heap[idx][2])
		break
	}
	ret = EVAL(body, env)
	types_release(ast)
	env_release(env)
	return ret
}

function EVAL_fn(ast, env,    idx, params, params_idx, params_len, i, sym, f_idx, len)
{
	idx = substr(ast, 2)
	if (types_heap[idx]["len"] != 3) {
		len = types_heap[idx]["len"]
		types_release(ast)
		env_release(env)
		return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "."
	}
	params = types_heap[idx][1]
	if (params !~ /^[([]/) {
		types_release(ast)
		env_release(env)
		return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "."
	}
	params_idx = substr(params, 2)
	params_len = types_heap[params_idx]["len"]
	for (i = 0; i < params_len; ++i) {
		sym = types_heap[params_idx][i]
		if (sym !~ /^'/) {
			types_release(ast)
			env_release(env)
			return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "."
		}
		if (sym == "'&" && i + 2 != params_len) {
			types_release(ast)
			env_release(env)
			return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "."
		}
	}
	f_idx = types_allocate()
	types_addref(types_heap[f_idx]["params"] = types_heap[idx][1])
	types_addref(types_heap[f_idx]["body"] = types_heap[idx][2])
	types_heap[f_idx]["env"] = env
	types_release(ast)
	return "$" f_idx
}

function EVAL(ast, env,    new_ast, ret, idx, f, f_idx)
{
	env_addref(env)
	if (ast !~ /^\(/) {
		ret = eval_ast(ast, env)
		types_release(ast)
		env_release(env)
		return ret
	}
	idx = substr(ast, 2)
	if (types_heap[idx]["len"] == 0) {
		env_release(env)
		return ast
	}
	switch (types_heap[idx][0]) {
	case "'def!":
		return EVAL_def(ast, env)
	case "'let*":
		return EVAL_let(ast, env)
	case "'do":
		return EVAL_do(ast, env)
	case "'if":
		return EVAL_if(ast, env)
	case "'fn*":
		return EVAL_fn(ast, env)
	default:
		new_ast = eval_ast(ast, env)
		types_release(ast)
		env_release(env)
		if (new_ast ~ /^!/) {
			return new_ast
		}
		idx = substr(new_ast, 2)
		f = types_heap[idx][0]
		f_idx = substr(f, 2)
		switch (f) {
		case /^\$/:
			env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx)
			if (env ~ /^!/) {
				types_release(new_ast)
				return env
			}
			types_addref(ast = types_heap[f_idx]["body"])
			types_release(new_ast)
			ret = EVAL(ast, env)
			env_release(env)
			return ret
		case /^&/:
			ret = @f_idx(idx)
			types_release(new_ast)
			return ret
		default:
			types_release(new_ast)
			return "!\"First element of list must be function, supplied " types_typename(f) "."
		}
	}
}

function PRINT(expr,    str)
{
	str = printer_pr_str(expr, 1)
	types_release(expr)
	return str
}

function rep(str,    ast, expr)
{
	ast = READ(str)
	if (ast ~ /^!/) {
		return ast
	}
	expr = EVAL(ast, repl_env)
	if (expr ~ /^!/) {
		return expr
	}
	return PRINT(expr)
}

function main(str, ret, i)
{
	repl_env = env_new()
	for (i in core_ns) {
		env_set(repl_env, i, core_ns[i])
	}

	rep("(def! not (fn* (a) (if a false true)))")

	while (1) {
		printf("user> ")
		if (getline str <= 0) {
			break
		}
		ret = rep(str)
		if (ret ~ /^!/) {
			print "ERROR: " printer_pr_str(substr(ret, 2))
		} else {
			print ret
		}
	}
}

BEGIN {
	main()
	env_check(0)
	env_dump()
	types_dump()
	exit(0)
}
Commit	Line	Data
8c7587af MK	1	@include "types.awk"
	2	@include "reader.awk"
	3	@include "printer.awk"
	4	@include "env.awk"
	5	@include "core.awk"
	6
	7	function READ(str)
	8	{
	9	return reader_read_str(str)
	10	}
	11
	12	function eval_ast(ast, env, i, idx, len, new_idx, ret)
	13	{
	14	switch (ast) {
	15	case /^'/:
	16	ret = env_get(env, ast)
	17	if (ret !~ /^!/) {
	18	types_addref(ret)
	19	}
	20	return ret
	21	case /^[([]/:
	22	idx = substr(ast, 2)
	23	len = types_heap[idx]["len"]
	24	new_idx = types_allocate()
	25	for (i = 0; i < len; ++i) {
	26	ret = EVAL(types_addref(types_heap[idx][i]), env)
	27	if (ret ~ /^!/) {
	28	types_heap[new_idx]["len"] = i
	29	types_release(substr(ast, 1, 1) new_idx)
	30	return ret
	31	}
	32	types_heap[new_idx][i] = ret
	33	}
	34	types_heap[new_idx]["len"] = len
	35	return substr(ast, 1, 1) new_idx
	36	case /^\{/:
	37	idx = substr(ast, 2)
	38	new_idx = types_allocate()
	39	for (i in types_heap[idx]) {
	40	if (i ~ /^[":]/) {
	41	ret = EVAL(types_addref(types_heap[idx][i]), env)
	42	if (ret ~ /^!/) {
	43	types_release("{" new_idx)
	44	return ret
	45	}
	46	types_heap[new_idx][i] = ret
	47	}
	48	}
	49	return "{" new_idx
	50	default:
	51	return ast
	52	}
	53	}
	54
	55	function EVAL_def(ast, env, idx, sym, ret, len)
	56	{
	57	idx = substr(ast, 2)
	58	if (types_heap[idx]["len"] != 3) {
	59	len = types_heap[idx]["len"]
	60	types_release(ast)
	61	env_release(env)
	62	return "!\"Invalid argument length for 'def!'. Expects exactly 2 arguments, supplied" (len - 1) "."
	63	}
	64	sym = types_heap[idx][1]
65	if (sym !~ /^'/) {
66	types_release(ast)
67	env_release(env)
68	return "!\"Incompatible type for argument 1 of 'def!'. Expects symbol, supplied " types_typename(sym) "."
69	}
70	ret = EVAL(types_addref(types_heap[idx][2]), env)
71	if (ret !~ /^!/) {
72	env_set(env, sym, ret)
73	types_addref(ret)
74	}
75	types_release(ast)
76	env_release(env)
77	return ret
78	}
79
80	function EVAL_let(ast, env, idx, params, params_idx, params_len, new_env, i, sym, ret, body, len)
81	{
82	idx = substr(ast, 2)
83	if (types_heap[idx]["len"] != 3) {
84	len = types_heap[idx]["len"]
85	types_release(ast)
86	env_release(env)
87	return "!\"Invalid argument length for 'let*'. Expects exactly 2 arguments, supplied " (len - 1) "."
88	}
89	params = types_heap[idx][1]
90	if (params !~ /^[([]/) {
91	types_release(ast)
92	env_release(env)
93	return "!\"Incompatible type for argument 1 of 'let*'. Expects list or vector, supplied " types_typename(params) "."
94	}
95	params_idx = substr(params, 2)
96	params_len = types_heap[params_idx]["len"]
97	if (params_len % 2 != 0) {
98	types_release(ast)
99	env_release(env)
100	return "!\"Invalid elements count for argument 1 of 'let*'. Expects even number of elements, supplied " params_len "."
101	}
102	new_env = env_new(env)
103	env_release(env)
104	for (i = 0; i < params_len; i += 2) {
105	sym = types_heap[params_idx][i]
106	if (sym !~ /^'/) {
107	types_release(ast)
108	env_release(new_env)
109	return "!\"Incompatible type for odd element of argument 1 of 'let*'. Expects symbol, supplied " types_typename(sym) "."
110	}
111	ret = EVAL(types_addref(types_heap[params_idx][i + 1]), new_env)
112	if (ret ~ /^!/) {
113	types_release(ast)
114	env_release(new_env)
115	return ret
116	}
117	env_set(new_env, sym, ret)
118	}
119	types_addref(body = types_heap[idx][2])
120	types_release(ast)
121	ret = EVAL(body, new_env)
122	env_release(new_env)
123	return ret
124	}
125
126	function EVAL_do(ast, env, idx, len, i, ret)
127	{
128	idx = substr(ast, 2)
129	len = types_heap[idx]["len"]
130	if (len == 1) {
131	types_release(ast)
132	env_release(env)
133	return "!\"Invalid argument length for 'do'. Expects at least 1 argument, supplied" (len - 1) "."
134	}
135	for (i = 1; i < len - 1; ++i) {
136	ret = EVAL(types_addref(types_heap[idx][i]), env)
137	if (ret ~ /^!/) {
138	types_release(ast)
139	env_release(env)
140	return ret
141	}
142	types_release(ret)
143	}
144	ret = EVAL(types_addref(types_heap[idx][len - 1]), env)
145	types_release(ast)
146	env_release(env)
147	return ret
148	}
149
150	function EVAL_if(ast, env, idx, len, ret, body)
151	{
152	idx = substr(ast, 2)
153	len = types_heap[idx]["len"]
154	if (len != 3 && len != 4) {
155	types_release(ast)
156	env_release(env)
157	return "!\"Invalid argument length for 'if'. Expects 2 or 3 arguments, supplied " (len - 1) "."
158	}
159	ret = EVAL(types_addref(types_heap[idx][1]), env)
160	if (ret ~ /^!/) {
161	types_release(ast)
162	env_release(env)
163	return ret
164	}
165	types_release(ret)
166	switch (ret) {
167	case "#nil":
168	case "#false":
169	if (len == 3) {
170	types_release(ast)
171	env_release(env)
172	return "#nil"
173	} else {
174	types_addref(body = types_heap[idx][3])
175	}
176	break
177	default:
178	types_addref(body = types_heap[idx][2])
179	break
180	}
181	ret = EVAL(body, env)
182	types_release(ast)
183	env_release(env)
184	return ret
185	}
186
187	function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx, len)
188	{
189	idx = substr(ast, 2)
190	if (types_heap[idx]["len"] != 3) {
191	len = types_heap[idx]["len"]
192	types_release(ast)
193	env_release(env)
194	return "!\"Invalid argument length for 'fn*'. Expects exactly 2 arguments, supplied " (len - 1) "."
195	}
196	params = types_heap[idx][1]
197	if (params !~ /^[([]/) {
198	types_release(ast)
199	env_release(env)
200	return "!\"Incompatible type for argument 1 of 'fn*'. Expects list or vector, supplied " types_typename(params) "."
201	}
202	params_idx = substr(params, 2)
203	params_len = types_heap[params_idx]["len"]
204	for (i = 0; i < params_len; ++i) {
205	sym = types_heap[params_idx][i]
206	if (sym !~ /^'/) {
207	types_release(ast)
208	env_release(env)
209	return "!\"Incompatible type for element of argument 1 of 'fn*'. Expects symbol, supplied " types_typename(sym) "."
210	}
211	if (sym == "'&" && i + 2 != params_len) {
212	types_release(ast)
213	env_release(env)
214	return "!\"Symbol '&' should be followed by last parameter. Parameter list length is " params_len ", position of symbol '&' is " (i + 1) "."
215	}
216	}
217	f_idx = types_allocate()
218	types_addref(types_heap[f_idx]["params"] = types_heap[idx][1])
219	types_addref(types_heap[f_idx]["body"] = types_heap[idx][2])
220	types_heap[f_idx]["env"] = env
221	types_release(ast)
222	return "$" f_idx
223	}
224
225	function EVAL(ast, env, new_ast, ret, idx, f, f_idx)
226	{
227	env_addref(env)
228	if (ast !~ /^\(/) {
229	ret = eval_ast(ast, env)
230	types_release(ast)
231	env_release(env)
232	return ret
233	}
234	idx = substr(ast, 2)
235	if (types_heap[idx]["len"] == 0) {
236	env_release(env)
237	return ast
238	}
239	switch (types_heap[idx][0]) {
240	case "'def!":
241	return EVAL_def(ast, env)
242	case "'let*":
243	return EVAL_let(ast, env)
244	case "'do":
245	return EVAL_do(ast, env)
246	case "'if":
247	return EVAL_if(ast, env)
248	case "'fn*":
249	return EVAL_fn(ast, env)
250	default:
251	new_ast = eval_ast(ast, env)
252	types_release(ast)
253	env_release(env)
254	if (new_ast ~ /^!/) {
255	return new_ast
256	}
257	idx = substr(new_ast, 2)
258	f = types_heap[idx][0]
259	f_idx = substr(f, 2)
260	switch (f) {
261	case /^\$/:
262	env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx)
263	if (env ~ /^!/) {
264	types_release(new_ast)
265	return env
266	}
267	types_addref(ast = types_heap[f_idx]["body"])
268	types_release(new_ast)
269	ret = EVAL(ast, env)
270	env_release(env)
271	return ret
272	case /^&/:
273	ret = @f_idx(idx)
274	types_release(new_ast)
275	return ret
276	default:
277	types_release(new_ast)
278	return "!\"First element of list must be function, supplied " types_typename(f) "."
279	}
280	}
281	}
282
283	function PRINT(expr, str)
284	{
285	str = printer_pr_str(expr, 1)
286	types_release(expr)
287	return str
288	}
289
290	function rep(str, ast, expr)
291	{
292	ast = READ(str)
293	if (ast ~ /^!/) {
294	return ast
295	}
296	expr = EVAL(ast, repl_env)
297	if (expr ~ /^!/) {
298	return expr
299	}
300	return PRINT(expr)
301	}
302
303	function main(str, ret, i)
304	{
305	repl_env = env_new()
306	for (i in core_ns) {
307	env_set(repl_env, i, core_ns[i])
308	}
309
310	rep("(def! not (fn* (a) (if a false true)))")
311
312	while (1) {
313	printf("user> ")
314	if (getline str <= 0) {
315	break
316	}
317	ret = rep(str)
318	if (ret ~ /^!/) {
319	print "ERROR: " printer_pr_str(substr(ret, 2))
320	} else {
321	print ret
322	}
323	}
324	}
325
326	BEGIN {
327	main()
328	env_check(0)
329	env_dump()
330	types_dump()
331	exit(0)
332	}