Commit ec6c8a6556aeed117ada42cc6ce85fce541d8645 - Bhuna

Import of Bhuna 0.4 sources. catseye 12 years ago

31 changed file(s) with 1409 addition(s) and 256 deletion(s). Raw diff Collapse all Expand all

-6

eg/ack7.bhu less more

11	11	}
12	12
13	13	Num = 7
14		// Print "Ack(3,", Num, "): ", Ack(3, Num), EoL
15		Print "Ack(3,"
16		Print Num
17		Print "): "
18		Print Ack(3, Num)
19		Print EoL
	14	Print "Ack(3,", Num, "): ", Ack(3, Num), EoL

+10

-0

eg/aha.bhu less more

	0	S = "lessthanten"
	1
	2	F = ^ A {
	3	if A > 10
	4	return A
	5	else
	6	return S
	7	}
	8
	9	B = F(8)

-0

eg/confuse.bhu less more

	0	F = ^ A {
	1	if A = 0
	2	return A
	3	else
	4	return [F(A-1)]
	5	}
	6
	7	Print F(10)

+12

-0

eg/share.bhu less more

	0	A = [1, 2, 3]
	1	B = A
	2
	3	PrintAB = ^ {
	4	Print "A = ", A, EoL
	5	Print "B = ", B, EoL
	6	}
	7
	8	PrintAB;
	9
	10	B[2] = "foo"
	11	PrintAB;

-0

eg/test.bhu less more

	0	// A = [1, 5, 4]
	1	// B = A[2]
	2
	3	F = ^ A { return A + 1 }
	4
	5	G = F(10)

-0

eg/tri2.bhu less more

A = 1 * 8

-1

eg/trivial.bhu less more

0		Print 1 + 3, " is ", 4
	0	Print 7 + 3, " is ", 4
1	1

-0

eg/typo.bhu less more

	0	H = 1
	1	F = ^ A, B {
	2	Print A + B
	3	return A - B
	4	}
	5
	6	H 5, 6
	7

+12

-0

eg/typo2.bhu less more

	0	F = ^ A {
	1	if A < 10
	2	Print "return 5"
	3	else {
	4	Print "I dunno, man...", EoL
	5	// return "string!"
	6	}
	7	// return 100
	8	}
	9
	10	Print F(4)
	11

-1

src/Makefile less more

0	0	PROG= bhuna
1		SRCS= scan.c parse.c \
	1	SRCS= report.c \
	2	scan.c parse.c \
2	3	symbol.c ast.c \
	4	type.c \
3	5	mem.c pool.c \
4	6	list.c atom.c buffer.c closure.c dict.c value.c \
5	7	activation.c eval.c \

8	10	main.c
9	11
10	12	CFLAGS+=-DPOOL_VALUES
	13	CFLAGS+=-DREFCOUNTING_MACROS
11	14	CFLAGS+=-DINLINE_BUILTINS
12	15	CFLAGS+=-Wall -I/usr/local/include
13	16	.ifndef NODEBUG

-0

src/activation.c less more

161	161	a_sp -= (sizeof(struct activation) + sizeof(struct value ) a->size);
162	162	}
163	163
	164	/#ifndef REFCOUNTING_MACROS/
164	165	struct value *
165	166	activation_get_value(struct activation *a, int index, int upcount)
166	167	{

207	208	value_grab(v);
208	209	VALARY(a, index) = v;
209	210	}
	211	/#endif/
210	212
211	213	void
212	214	activation_dump(struct activation *a, int detail)

+278

-80

src/ast.c less more

7	7	#include "builtin.h"
8	8	#include "activation.h"
9	9	#include "vm.h"
10
11		#ifdef DEBUG
	10	#include "type.h"
	11	#include "scan.h"
	12
12	13	#include "symbol.h"
13		#endif
14	14
15	15	extern unsigned char program[];
	16	extern int trace_type_inference;
16	17
17	18	/*** constructors ***/
18	19

23	24
24	25	a = malloc(sizeof(struct ast));
25	26	a->type = type;
	27	a->sc = NULL;
26	28	a->label = NULL;
27
28		return(a);
29		}
30
31		struct ast *
32		ast_new_local(int index, int upcount, void *sym)
	29	a->datatype = NULL;
	30
	31	return(a);
	32	}
	33
	34	struct ast *
	35	ast_new_local(struct symbol_table stab, struct symbol sym)
33	36	{
34	37	struct ast *a;
35	38
36	39	a = ast_new(AST_LOCAL);
37		a->u.local.index = index;
38		a->u.local.upcount = upcount;
39		#ifdef DEBUG
	40	a->u.local.index = sym->index;
	41	a->u.local.upcount = stab->level - sym->in->level;
40	42	a->u.local.sym = sym;
41		#endif
42
43		return(a);
44		}
45
46		struct ast *
47		ast_new_value(struct value *v)
	43	a->datatype = sym->type;
	44
	45	#ifdef DEBUG
	46	if (trace_type_inference) {
	47	printf("(new-local)*****\n");
	48	printf("type is: ");
	49	type_print(stdout, a->datatype);
	50	printf("\n*******\n");
	51	}
	52	#endif
	53
	54	return(a);
	55	}
	56
	57	struct ast *
	58	ast_new_value(struct value v, struct type t)
48	59	{
49	60	struct ast *a;
50	61
51	62	a = ast_new(AST_VALUE);
52	63	value_grab(v);
53	64	a->u.value.value = v;
54
55		return(a);
56		}
57
58		struct ast *
59		ast_new_builtin(struct builtin bi, struct ast right)
60		{
61		struct ast *a;
	65	a->datatype = t;
	66
	67	#ifdef DEBUG
	68	if (trace_type_inference) {
	69	printf("(value)*****\n");
	70	printf("type is: ");
	71	type_print(stdout, a->datatype);
	72	printf("\n*******\n");
	73	}
	74	#endif
	75
	76	return(a);
	77	}
	78
	79	struct ast *
	80	ast_new_builtin(struct scan_st sc, struct builtin bi, struct ast *right)
	81	{
	82	struct ast *a;
	83	struct type *t;
	84	int unify = 0;
	85
	86	t = bi->ty();
	87	type_ensure_routine(t);
	88
	89	#ifdef DEBUG
	90	if (trace_type_inference) {
	91	printf("(builtin `%s`)*****\n", bi->name);
	92	printf("type of args is: ");
	93	type_print(stdout, right->datatype);
	94	printf("\ntype of builtin is: ");
	95	type_print(stdout, t);
	96	}
	97	#endif
	98
	99	unify = type_unify_crit(sc,
	100	type_representative(t)->t.closure.domain,
	101	right->datatype);
	102
	103	#ifdef DEBUG
	104	if (trace_type_inference) {
	105	printf("\nthese unify? --> %d <--", unify);
	106	printf("\n****\n");
	107	}
	108	#endif
62	109
63	110	/*
64	111	* Fold constants.

75	122	} else {
76	123	varity = bi->arity;
77	124	}
78		ar = activation_new_on_stack(varity, NULL, NULL);
79		for (g = right, i = 0;
80		g != NULL && g->type == AST_ARG && i < varity;
81		g = g->u.arg.right, i++) {
82		if (g->u.arg.left != NULL)
83		activation_initialize_value(ar, i,
84		g->u.arg.left->u.value.value);
	125
	126	if (unify) {
	127	ar = activation_new_on_stack(varity, NULL, NULL);
	128	for (g = right, i = 0;
	129	g != NULL && g->type == AST_ARG && i < varity;
	130	g = g->u.arg.right, i++) {
	131	if (g->u.arg.left != NULL)
	132	activation_initialize_value(ar, i,
	133	g->u.arg.left->u.value.value);
	134	}
	135	bi->fn(ar, &v);
	136	activation_free_from_stack(ar);
	137	} else {
	138	a = NULL;
85	139	}
86		bi->fn(ar, &v);
87		activation_free_from_stack(ar);
88		a = ast_new_value(v);
	140
	141	a = ast_new_value(v, type_representative(t)->t.closure.range);
89	142	value_release(v);
90	143
91	144	return(a);

95	148
96	149	a->u.builtin.bi = bi;
97	150	a->u.builtin.right = right;
98
99		return(a);
100		}
101
102		struct ast *
103		ast_new_apply(struct ast fn, struct ast args, int is_pure)
104		{
105		struct ast *a;
	151	a->datatype = type_representative(t)->t.closure.range;
	152
	153	return(a);
	154	}
	155
	156	struct ast *
	157	ast_new_apply(struct scan_st sc, struct ast fn, struct ast *args, int is_pure)
	158	{
	159	struct ast *a;
	160	int unify;
106	161
107	162	a = ast_new(AST_APPLY);
108	163	a->u.apply.left = fn;
109	164	a->u.apply.right = args;
110	165	a->u.apply.is_pure = is_pure;
111	166
	167	type_ensure_routine(fn->datatype);
	168
	169	#ifdef DEBUG
	170	if (trace_type_inference) {
	171	printf("(apply)*****\n");
	172	printf("type of args is: ");
	173	if (args == NULL) printf("N/A"); else type_print(stdout, args->datatype);
	174	printf("\ntype of closure is: ");
	175	type_print(stdout, fn->datatype);
	176	}
	177	#endif
	178
	179	if (args == NULL) {
	180	unify = type_unify_crit(sc,
	181	type_representative(fn->datatype)->t.closure.domain,
	182	type_new(TYPE_VOID)); /* XXX need not be new */
	183	} else {
	184	unify = type_unify_crit(sc,
	185	type_representative(fn->datatype)->t.closure.domain,
	186	args->datatype);
	187	}
	188
	189	#ifdef DEBUG
	190	if (trace_type_inference) {
	191	printf("\nthese unify? --> %d <--", unify);
	192	printf("\n****\n");
	193	}
	194	#endif
	195
	196	a->datatype = type_representative(fn->datatype)->t.closure.range;
	197
112	198	return(a);
113	199	}
114	200

120	206	a = ast_new(AST_ARG);
121	207	a->u.arg.left = left;
122	208	a->u.arg.right = right;
123
	209	if (a->u.arg.right == NULL) {
	210	a->datatype = a->u.arg.left->datatype;
	211	} else {
	212	a->datatype = type_new_arg(
	213	a->u.arg.left->datatype,
	214	a->u.arg.right->datatype);
	215	}
124	216	return(a);
125	217	}
126	218

134	226	a->u.routine.locals = locals;
135	227	a->u.routine.cc = cc;
136	228	a->u.routine.body = body;
	229
	230	a->datatype = a->u.routine.body->datatype;
	231
	232	#ifdef DEBUG
	233	if (trace_type_inference) {
	234	printf("(routine)*****\n");
	235	printf("type is: ");
	236	type_print(stdout, a->datatype);
	237	printf("\n****\n");
	238	}
	239	#endif
137	240
138	241	return(a);
139	242	}

153	256	a = ast_new(AST_STATEMENT);
154	257	a->u.statement.left = left;
155	258	a->u.statement.right = right;
156
157		return(a);
158		}
159
160		struct ast *
161		ast_new_assignment(struct ast left, struct ast right)
162		{
163		struct ast *a;
	259	/* XXX check that a->u.statement.left->datatype is VOID ?? */
	260	a->datatype = a->u.statement.right->datatype;
	261	/* haha... */
	262	/*
	263	a->datatype = type_new_set(a->u.statement.left->datatype,
	264	a->u.statement.right->datatype);
	265	*/
	266
	267	#ifdef DEBUG
	268	if (trace_type_inference) {
	269	printf("(statement)*****\n");
	270	printf("type is: ");
	271	type_print(stdout, a->datatype);
	272	printf("\n****\n");
	273	}
	274	#endif
	275
	276	return(a);
	277	}
	278
	279	struct ast *
	280	ast_new_assignment(struct scan_st sc, struct ast left, struct ast *right)
	281	{
	282	struct ast *a;
	283	int unify;
	284
	285	/*
	286	* Do some 'self-repairing' in the case of syntax errors that
	287	* generate a corrupt AST (e.g. Foo = <eof>)
	288	*/
	289	if (right == NULL)
	290	return(left);
164	291
165	292	a = ast_new(AST_ASSIGNMENT);
166	293	a->u.assignment.left = left;
167	294	a->u.assignment.right = right;
168	295
169		return(a);
170		}
171
172		struct ast *
173		ast_new_conditional(struct ast test, struct ast yes, struct ast *no)
174		{
175		struct ast *a;
	296	unify = type_unify_crit(sc, left->datatype, right->datatype);
	297
	298	#ifdef DEBUG
	299	if (trace_type_inference) {
	300	printf("(assign)*****\n");
	301	printf("type of LHS is: ");
	302	type_print(stdout, left->datatype);
	303	printf("\ntype of RHS is: ");
	304	type_print(stdout, right->datatype);
	305	printf("\nthese unify? --> %d <--", unify);
	306	printf("\ntype of LHS is now: ");
	307	type_print(stdout, left->datatype);
	308	printf("\n****\n");
	309	}
	310	#endif
	311
	312	return(a);
	313	}
	314
	315	struct ast *
	316	ast_new_conditional(struct scan_st sc, struct ast test, struct ast yes, struct ast no)
	317	{
	318	struct ast *a;
	319	int unify;
176	320
177	321	a = ast_new(AST_CONDITIONAL);
178	322	a->u.conditional.test = test;
179	323	a->u.conditional.yes = yes;
180	324	a->u.conditional.no = no;
181
182		return(a);
183		}
184
185		struct ast *
186		ast_new_while_loop(struct ast test, struct ast body)
187		{
188		struct ast *a;
	325	/* check that a->u.conditional.test is BOOLEAN */
	326
	327	/* XXX need not be new boolean - reuse an old one */
	328	unify = type_unify_crit(sc, test->datatype, type_new(TYPE_BOOLEAN));
	329
	330	#ifdef DEBUG
	331	if (trace_type_inference) {
	332	printf("(if)*****\n");
	333	printf("type of YES is: ");
	334	type_print(stdout, yes->datatype);
	335	printf("\ntype of NO is: ");
	336	type_print(stdout, no->datatype);
	337	}
	338	#endif
	339
	340	/* XXX check that a->u.conditional.yes is VOID */
	341	/* XXX check that a->u.conditional.no is VOID */
	342
	343	/* actually, either of these can be VOID, in which case, pick the other */
	344	/* unify = type_unify_crit(sc, yes->datatype, no->datatype); */
	345	/* haha */
	346	a->datatype = type_new_set(a->u.conditional.yes->datatype,
	347	a->u.conditional.no->datatype);
	348
	349	#ifdef DEBUG
	350	if (trace_type_inference) {
	351	printf("\nresult type is: ");
	352	type_print(stdout, a->datatype);
	353	printf("\n****\n");
	354	}
	355	#endif
	356
	357	return(a);
	358	}
	359
	360	struct ast *
	361	ast_new_while_loop(struct scan_st sc, struct ast test, struct ast *body)
	362	{
	363	struct ast *a;
	364	int unify;
189	365
190	366	a = malloc(sizeof(struct ast));
191	367	a->type = AST_WHILE_LOOP;
192	368
193	369	a->u.while_loop.test = test;
194	370	a->u.while_loop.body = body;
	371	/* XXX need not be new boolean - reuse an old one */
	372	unify = type_unify_crit(sc, test->datatype, type_new(TYPE_BOOLEAN));
	373
	374	/* XXX check that a->u.while_loop.body is VOID */
	375	/* a->datatype = type_new(TYPE_VOID); */
	376	a->datatype = body->datatype;
195	377
196	378	return(a);
197	379	}

203	385
204	386	a = ast_new(AST_RETR);
205	387	a->u.retr.body = body;
	388	/* XXX check against other return statements in same function... somehow... */
	389	a->datatype = a->u.retr.body->datatype;
	390
	391	#ifdef DEBUG
	392	if (trace_type_inference) {
	393	printf("(retr)*****\n");
	394	printf("type is: ");
	395	type_print(stdout, a->datatype);
	396	printf("\n****\n");
	397	}
	398	#endif
206	399
207	400	return(a);
208	401	}

256	449	ast_free(a->u.retr.body);
257	450	break;
258	451	}
	452	if (a->sc != NULL)
	453	scan_close(a->sc);
259	454	free(a);
260	455	}
261	456

336	531	if (a->label != NULL) {
337	532	printf("@#%d -> ", a->label - (vm_label_t)program);
338	533	}
	534	printf(ast_name(a));
	535	printf("=");
	536	type_print(stdout, a->datatype);
339	537	switch (a->type) {
340	538	case AST_LOCAL:
341		printf("local(%d,%d)=", a->u.local.index, a->u.local.upcount);
	539	printf("(%d,%d)=", a->u.local.index, a->u.local.upcount);
342	540	if (a->u.local.sym != NULL)
343	541	symbol_dump(a->u.local.sym, 0);
344	542	printf("\n");
345	543	break;
346	544	case AST_VALUE:
347		printf("value(");
	545	printf("(");
348	546	value_print(a->u.value.value);
349	547	printf(")\n");
350	548	break;
351	549	case AST_BUILTIN:
352		printf("builtin `%s`{\n", a->u.builtin.bi->name);
	550	printf("`%s`{\n", a->u.builtin.bi->name);
353	551	ast_dump(a->u.builtin.right, indent + 1);
354	552	for (i = 0; i < indent; i++) printf(" "); printf("}\n");
355	553	break;
356	554	case AST_APPLY:
357		printf("apply {\n");
	555	printf("{\n");
358	556	ast_dump(a->u.apply.left, indent + 1);
359	557	ast_dump(a->u.apply.right, indent + 1);
360	558	for (i = 0; i < indent; i++) printf(" "); printf("}\n");
361	559	break;
362	560	case AST_ARG:
363		printf("arg {\n");
	561	printf("{\n");
364	562	ast_dump(a->u.arg.left, indent + 1);
365	563	ast_dump(a->u.arg.right, indent + 1);
366	564	for (i = 0; i < indent; i++) printf(" "); printf("}\n");
367	565	break;
368	566	case AST_ROUTINE:
369		printf("routine/%d (contains %d) {\n",
	567	printf("/%d (contains %d) {\n",
370	568	a->u.routine.arity, a->u.routine.cc);
371	569	ast_dump(a->u.routine.body, indent + 1);
372	570	for (i = 0; i < indent; i++) printf(" "); printf("}\n");
373	571	break;
374	572	case AST_STATEMENT:
375		printf("statement {\n");
	573	printf("{\n");
376	574	ast_dump(a->u.statement.left, indent + 1);
377	575	ast_dump(a->u.statement.right, indent + 1);
378	576	for (i = 0; i < indent; i++) printf(" "); printf("}\n");
379	577	break;
380	578	case AST_ASSIGNMENT:
381		printf("assign {\n");
	579	printf("{\n");
382	580	ast_dump(a->u.assignment.left, indent + 1);
383	581	ast_dump(a->u.assignment.right, indent + 1);
384	582	for (i = 0; i < indent; i++) printf(" "); printf("}\n");
385	583	break;
386	584	case AST_CONDITIONAL:
387		printf("conditional {\n"); /* a->u.conditional.index); */
	585	printf("{\n");
388	586	ast_dump(a->u.conditional.test, indent + 1);
389	587	ast_dump(a->u.conditional.yes, indent + 1);
390	588	if (a->u.conditional.no != NULL)

392	590	for (i = 0; i < indent; i++) printf(" "); printf("}\n");
393	591	break;
394	592	case AST_WHILE_LOOP:
395		printf("while {\n");
	593	printf("{\n");
396	594	ast_dump(a->u.while_loop.test, indent + 1);
397	595	ast_dump(a->u.while_loop.body, indent + 1);
398	596	for (i = 0; i < indent; i++) printf(" "); printf("}\n");
399	597	break;
400	598	case AST_RETR:
401		printf("retr {\n");
	599	printf("{\n");
402	600	ast_dump(a->u.retr.body, indent + 1);
403	601	for (i = 0; i < indent; i++) printf(" "); printf("}\n");
404	602	break;

+16

-12

src/ast.h less more

4	4
5	5	struct value;
6	6	struct builtin;
	7	struct type;
	8	struct symbol;
	9	struct symbol_table;
	10	struct scan_st;
7	11
8	12	struct ast_local {
9	13	int index;
10	14	int upcount;
11		#ifdef DEBUG
12	15	struct symbol *sym;
13		#endif
14	16	};
15	17
16	18	struct ast_value {

93	95	};
94	96
95	97	struct ast {
96		int type;
97		vm_label_t label;
98		union ast_union u;
	98	int type;
	99	struct scan_st *sc;
	100	struct type *datatype;
	101	vm_label_t label;
	102	union ast_union u;
99	103	};
100	104
101		struct ast ast_new_local(int, int, void );
102		struct ast ast_new_value(struct value );
103		struct ast ast_new_builtin(struct builtin , struct ast *);
104		struct ast ast_new_apply(struct ast , struct ast *, int);
	105	struct ast ast_new_local(struct symbol_table , struct symbol *);
	106	struct ast ast_new_value(struct value , struct type *);
	107	struct ast ast_new_builtin(struct scan_st , struct builtin , struct ast );
	108	struct ast ast_new_apply(struct scan_st , struct ast , struct ast , int);
105	109	struct ast ast_new_arg(struct ast , struct ast *);
106	110	struct ast ast_new_routine(int, int, int, struct ast );
107	111	struct ast ast_new_statement(struct ast , struct ast *);
108		struct ast ast_new_assignment(struct ast , struct ast *);
109		struct ast ast_new_conditional(struct ast , struct ast , struct ast );
110		struct ast ast_new_while_loop(struct ast , struct ast *);
	112	struct ast ast_new_assignment(struct scan_st , struct ast , struct ast );
	113	struct ast ast_new_conditional(struct scan_st , struct ast , struct ast , struct ast *);
	114	struct ast ast_new_while_loop(struct scan_st , struct ast , struct ast );
111	115	struct ast ast_new_retr(struct ast );
112	116	void ast_free(struct ast *);
113	117

+118

-20

src/builtin.c less more

6	6	#include "dict.h"
7	7	#include "closure.h"
8	8	#include "activation.h"
	9	#include "type.h"
9	10
10	11	/*
11	12	* Built-in operations.
12	13	*/
13	14
14	15	struct builtin builtins[] = {
15		{"Print", builtin_print, -1, 0, 1, 0},
16		{"!", builtin_not, 1, 1, 1, 1},
17		{"&", builtin_and, 2, 1, 1, 2},
18		{"\|", builtin_or, 2, 1, 1, 3},
19		{"=", builtin_equ, 2, 1, 1, 4},
20		{"!=", builtin_neq, 2, 1, 1, 5},
21		{">", builtin_gt, 2, 1, 1, 6},
22		{"<", builtin_lt, 2, 1, 1, 7},
23		{">=", builtin_gte, 2, 1, 1, 8},
24		{"<=", builtin_lte, 2, 1, 1, 9},
25		{"+", builtin_add, 2, 1, 1, 10},
26		{"-", builtin_sub, 2, 1, 1, 11},
27		{"*", builtin_mul, 2, 1, 1, 12},
28		{"/", builtin_div, 2, 1, 1, 13},
29		{"%", builtin_mod, 2, 1, 1, 14},
30		{"List", builtin_list, -1, 1, 1, 15},
31		{"Fetch", builtin_fetch, 2, 1, 1, 16},
32		{"Store", builtin_store, 3, 0, 1, 17},
33		{"Dict", builtin_dict, -1, 1, 1, 18},
34		{NULL, NULL, 0, 0, 0, 19}
	16	{"Print", builtin_print, btype_print, -1, 0, 1, 0},
	17	{"!", builtin_not, btype_unary_logic, 1, 1, 1, 1},
	18	{"&", builtin_and, btype_binary_logic, 2, 1, 1, 2},
	19	{"\|", builtin_or, btype_binary_logic, 2, 1, 1, 3},
	20	{"=", builtin_equ, btype_compare, 2, 1, 1, 4},
	21	{"!=", builtin_neq, btype_compare, 2, 1, 1, 5},
	22	{">", builtin_gt, btype_compare, 2, 1, 1, 6},
	23	{"<", builtin_lt, btype_compare, 2, 1, 1, 7},
	24	{">=", builtin_gte, btype_compare, 2, 1, 1, 8},
	25	{"<=", builtin_lte, btype_compare, 2, 1, 1, 9},
	26	{"+", builtin_add, btype_arith, 2, 1, 1, 10},
	27	{"-", builtin_sub, btype_arith, 2, 1, 1, 11},
	28	{"*", builtin_mul, btype_arith, 2, 1, 1, 12},
	29	{"/", builtin_div, btype_arith, 2, 1, 1, 13},
	30	{"%", builtin_mod, btype_arith, 2, 1, 1, 14},
	31	{"List", builtin_list, btype_list, -1, 1, 1, 15},
	32	{"Fetch", builtin_fetch, btype_fetch, 2, 1, 1, 16},
	33	{"Store", builtin_store, btype_store, 3, 0, 1, 17},
	34	{"Dict", builtin_dict, btype_dict, -1, 1, 1, 18},
	35	{NULL, NULL, NULL, 0, 0, 0, 19}
35	36	};
36	37
37	38	void

390	391	}
391	392	}
392	393	}
	394
	395	struct type *
	396	btype_print(void)
	397	{
	398	return(
	399	type_new_closure(
	400	type_new_var(1),
	401	type_new(TYPE_VOID)
	402	)
	403	);
	404	}
	405
	406	struct type *
	407	btype_unary_logic(void)
	408	{
	409	return(
	410	type_new_closure(
	411	type_new(TYPE_BOOLEAN),
	412	type_new(TYPE_BOOLEAN)
	413	)
	414	);
	415	}
	416
	417	struct type *
	418	btype_binary_logic(void)
	419	{
	420	return(
	421	type_new_closure(
	422	type_new_arg(type_new(TYPE_BOOLEAN), type_new(TYPE_BOOLEAN)),
	423	type_new(TYPE_BOOLEAN)
	424	)
	425	);
	426	}
	427
	428	struct type *
	429	btype_compare(void)
	430	{
	431	return(
	432	type_new_closure(
	433	type_new_arg(type_new(TYPE_INTEGER), type_new(TYPE_INTEGER)),
	434	type_new(TYPE_BOOLEAN)
	435	)
	436	);
	437	}
	438
	439	struct type *
	440	btype_arith(void)
	441	{
	442	return(
	443	type_new_closure(
	444	type_new_arg(type_new(TYPE_INTEGER), type_new(TYPE_INTEGER)),
	445	type_new(TYPE_INTEGER)
	446	)
	447	);
	448	}
	449
	450	struct type *
	451	btype_list(void)
	452	{
	453	return(
	454	type_new_closure(
	455	type_new_var(2),
	456	type_new_list(type_new(TYPE_INTEGER))
	457	)
	458	);
	459	}
	460
	461	struct type *
	462	btype_fetch(void)
	463	{
	464	return(
	465	type_new_closure(
	466	type_new_arg(type_new_var(5), type_new(TYPE_INTEGER)),
	467	type_new_var(5)
	468	)
	469	);
	470	}
	471
	472	struct type *
	473	btype_store(void)
	474	{
	475	return(
	476	type_new_closure(
	477	type_new_arg(
	478	type_new_var(6),
	479	type_new_arg(type_new_var(7), type_new_var(8))
	480	),
	481	type_new(TYPE_VOID)
	482	)
	483	);
	484	}
	485
	486	struct type *
	487	btype_dict(void)
	488	{
	489	return(NULL);
	490	}

+12

-0

src/builtin.h less more

2	2
3	3	struct value;
4	4	struct activation;
	5	struct type;
5	6
6	7	struct builtin {
7	8	char *name;
8	9	void (fn)(struct activation , struct value **);
	10	struct type (ty)(void);
9	11	int arity;
10	12	int is_pure;
11	13	int is_const;

61	63
62	64	void builtin_dict(struct activation , struct value *);
63	65
	66	struct type *btype_print(void);
	67	struct type *btype_unary_logic(void);
	68	struct type *btype_binary_logic(void);
	69	struct type *btype_compare(void);
	70	struct type *btype_arith(void);
	71	struct type *btype_list(void);
	72	struct type *btype_fetch(void);
	73	struct type *btype_store(void);
	74	struct type *btype_dict(void);
	75
64	76	#endif

-0

src/closure.c less more

8	8	#include "activation.h"
9	9	#include "vm.h"
10	10
	11	#include "type.h"
	12
11	13	struct closure *
12	14	closure_new(struct ast a, struct activation ar)
13	15	{
14	16	struct closure *c;
15	17
16	18	c = bhuna_malloc(sizeof(struct closure));
	19
17	20	c->ast = a;
18	21	c->ar = ar;
19	22

+17

-3

src/main.c less more

10	10	#include "value.h"
11	11	#include "activation.h"
12	12	#include "vm.h"
	13	#include "type.h"
	14	#include "report.h"
13	15
14	16	#ifdef POOL_VALUES
15	17	#include "pool.h"

26	28	int trace_vm = 0;
27	29	int trace_gen = 0;
28	30	int trace_pool = 0;
	31	int trace_type_inference = 0;
29	32
30	33	int num_vars_created = 0;
31	34	int num_vars_grabbed = 0;

39	42	#endif
40	43
41	44	#ifdef DEBUG
42		#define OPTS "acdfg:klmnoprstvxz"
	45	#define OPTS "acdfg:klmnoprstvxyz"
43	46	#define RUN_PROGRAM run_program
44	47	#else
45	48	#define OPTS "g:x"

77	80	#endif
78	81	fprintf(stderr, " -x: execute bytecode (unless -n)\n");
79	82	#ifdef DEBUG
	83	fprintf(stderr, " -y: trace type inference\n");
80	84	fprintf(stderr, " -z: dump symbol table after run\n");
81	85	#endif
82	86	exit(1);

94	98	sym = symbol_define(stab, b[i].name, SYM_KIND_COMMAND, v);
95	99	sym->is_pure = b[i].is_pure;
96	100	sym->builtin = &b[i];
	101	sym->type = b[i].ty();
97	102	value_release(v);
98	103	}
99	104
100	105	/* XXX */
101	106	v = value_new_string("\n");
102	107	sym = symbol_define(stab, "EoL", SYM_KIND_VARIABLE, v);
	108	sym->type = type_new(TYPE_STRING);
103	109	value_release(v);
104	110
105	111	v = value_new_boolean(1);
106	112	sym = symbol_define(stab, "True", SYM_KIND_VARIABLE, v);
	113	sym->type = type_new(TYPE_BOOLEAN);
107	114	value_release(v);
108	115
109	116	v = value_new_boolean(0);
110	117	sym = symbol_define(stab, "False", SYM_KIND_VARIABLE, v);
	118	sym->type = type_new(TYPE_BOOLEAN);
111	119	value_release(v);
112	120	}
113	121

121	129	char *source = NULL;
122	130	int opt;
123	131	int use_vm = 0;
	132	int err_count = 0;
124	133	#ifdef DEBUG
125	134	int run_program = 1;
126	135	int dump_symbols_beforehand = 0;

199	208	use_vm = 1;
200	209	break;
201	210	#ifdef DEBUG
	211	case 'y':
	212	trace_type_inference++;
	213	break;
202	214	case 'z':
203	215	dump_symbols_afterwards = 1;
204	216	break;

221	233	stab = symbol_table_new(NULL, 0);
222	234	global_ar = activation_new_on_stack(100, NULL, NULL);
223	235	load_builtins(stab, builtins);
	236	report_start();
224	237	a = parse_program(sc, stab);
225	238	scan_close(sc);
226	239	current_ar = global_ar;

234	247	#ifndef DEBUG
235	248	symbol_table_free(stab);
236	249	#endif
237		if (sc->errors == 0 && use_vm) {
	250	err_count = report_finish();
	251	if (err_count == 0 && use_vm) {
238	252	unsigned char *program;
239	253
240	254	program = ast_gen(a);

245	259	vm_release(program);
246	260	/value_dump_global_table();/
247	261	#ifdef RECURSIVE_AST_EVALUATOR
248		} else if (sc->errors == 0 && RUN_PROGRAM) {
	262	} else if (err_count == 0 && RUN_PROGRAM) {
249	263	v = value_new_integer(76);
250	264	ast_eval_init();
251	265	ast_eval(a, &v);

-0

src/mem.h less more

47	47	char bhuna_strdup(char );
48	48	void bhuna_free(void *);
49	49	#else*/
	50	#include <stdlib.h>
50	51	#define bhuna_malloc(x) malloc(x)
51	52	#define bhuna_strdup(x) strdup(x)
52	53	#define bhuna_free(x) free(x)

+111

-87

src/parse.c less more

47	47	#include "value.h"
48	48	#include "atom.h"
49	49	#include "ast.h"
	50	#include "type.h"
	51	#include "report.h"
50	52
51	53	#define VAR_LOCAL 0
52	54	#define VAR_GLOBAL 1

61	63	* Convenience function to create AST for a named arity-2 function call.
62	64	*/
63	65	static struct ast *
64		ast_new_call2(char name, struct symbol_table stab,
	66	ast_new_call2(char name, struct scan_st sc, struct symbol_table *stab,
65	67	struct ast left, struct ast right)
66	68	{
67	69	struct symbol *sym;
68	70	struct ast *a;
69	71
70		left = ast_new_arg(left, NULL);
71	72	right = ast_new_arg(right, NULL);
72		left->u.arg.right = right;
	73	left = ast_new_arg(left, right);
73	74
74	75	sym = symbol_lookup(stab, name, VAR_GLOBAL);
75	76	assert(sym != NULL && sym->builtin != NULL);
76		a = ast_new_builtin(sym->builtin, left);
	77	a = ast_new_builtin(sc, sym->builtin, left);
77	78
78	79	return(a);
79	80	}
80	81
81	82	static struct ast *
82		ast_new_call3(char name, struct symbol_table stab,
	83	ast_new_call3(char name, struct scan_st sc, struct symbol_table *stab,
83	84	struct ast left, struct ast index, struct ast *right)
84	85	{
85	86	struct symbol *sym;
86	87	struct ast *a;
87	88
88		left = ast_new_arg(left, NULL);
89		index = ast_new_arg(index, NULL);
90	89	right = ast_new_arg(right, NULL);
91		left->u.arg.right = index;
92		index->u.arg.right = right;
	90	index = ast_new_arg(index, right);
	91	left = ast_new_arg(left, index);
93	92
94	93	sym = symbol_lookup(stab, name, VAR_GLOBAL);
95	94	assert(sym != NULL && sym->builtin != NULL);
96		a = ast_new_builtin(sym->builtin, left);
	95	a = ast_new_builtin(sc, sym->builtin, left);
97	96
98	97	return(a);
99	98	}

169	168	} else {
170	169	r = NULL;
171	170	}
172		a = ast_new_conditional(a, l, r);
	171	a = ast_new_conditional(sc, a, l, r);
173	172	} else if (tokeq(sc, "while")) {
174	173	scan(sc);
175	174	l = parse_expr(sc, stab, 0, NULL, cc);
176	175	istab = symbol_table_new(stab, 0);
177	176	r = parse_block(sc, stab, &istab, cc);
178		a = ast_new_while_loop(l, r);
	177	a = ast_new_while_loop(sc, l, r);
179	178	} else if (tokeq(sc, "return")) {
180	179	scan(sc);
181	180	a = parse_expr(sc, stab, 0, NULL, cc);

234	233	r = parse_expr(sc, stab, 0, sym, cc);
235	234	if (is_const) {
236	235	if (r == NULL \|\| r->type != AST_VALUE) {
237		scan_error(sc, "Expression must be constant");
	236	report(REPORT_ERROR, sc, "Expression must be constant");
238	237	} else {
239	238	symbol_set_value(sym, r->u.value.value);
240	239	ast_free(l);

242	241	}
243	242	return(NULL);
244	243	} else {
245		return(ast_new_assignment(l, r));
	244	return(ast_new_assignment(sc, l, r));
246	245	}
247	246	}
248	247

251	250	int *cc)
252	251	{
253	252	struct symbol *sym;
254		struct ast a, l, r, z;
	253	struct ast a, l, *r;
255	254
256	255	a = parse_var(sc, stab, &sym, VAR_GLOBAL, VAR_MUST_EXIST, NULL);
257	256

272	271	*/
273	272	scan(sc);
274	273	r = parse_expr(sc, stab, 0, NULL, cc);
275		a = ast_new_call3("Store", stab, a, l, r);
	274	a = ast_new_call3("Store", sc, stab, a, l, r);
276	275	return(a);
277	276	} else if (tokne(sc, "[") && tokne(sc, ".")) {
278	277	/*

283	282	/*
284	283	* Still more to go.
285	284	*/
286		a = ast_new_call2("Fetch", stab, a, l);
	285	a = ast_new_call2("Fetch", sc, stab, a, l);
287	286	}
288	287	} else if (tokeq(sc, ".")) {
289	288	scan(sc);
290	289	r = parse_literal(sc, stab);
291		a = ast_new_call2("Fetch", stab, a, r);
	290	a = ast_new_call2("Fetch", sc, stab, a, r);
292	291	}
293	292	}
294	293

298	297	*/
299	298	if (tokeq(sc, "=")) {
300	299	if (sym->value != NULL) {
301		scan_error(sc, "Value not modifiable");
	300	report(REPORT_ERROR, sc, "Value not modifiable");
302	301	} else {
303	302	scan(sc);
304	303	r = parse_expr(sc, stab, 0, NULL, cc);
305		a = ast_new_assignment(a, r);
	304	a = ast_new_assignment(sc, a, r);
306	305	}
307	306	return(a);
	307	}
	308
	309	if (tokne(sc, "}") && tokne(sc, ";") && sc->type != TOKEN_EOF) {
	310	l = parse_expr_list(sc, stab, NULL, cc);
	311	} else {
	312	l = NULL;
308	313	}
309	314
310	315	/*
311	316	* Otherwise, it's a command.
312	317	*/
313		if (tokne(sc, "}") && tokne(sc, ";") && sc->type != TOKEN_EOF) {
314		l = parse_expr(sc, stab, 0, NULL, cc);
315		l = ast_new_arg(l, NULL);
316		z = l;
317		while (tokeq(sc, ",")) {
318		scan_expect(sc, ",");
319		r = parse_expr(sc, stab, 0, NULL, cc);
320		r = ast_new_arg(r, NULL);
321		z->u.arg.right = r;
322		z = r;
323		}
324		} else {
325		l = NULL;
326		}
	318	if (!type_is_possibly_routine(sym->type)) {
	319	report(REPORT_ERROR, sc, "Command application of non-routine variable");
	320	/return(NULL);/
	321	}
	322	type_ensure_routine(sym->type);
	323	if (!type_is_void(type_representative(sym->type)->t.closure.range)) {
	324	report(REPORT_ERROR, sc, "Command application of function variable");
	325	/return(NULL);/
	326	}
	327
327	328	if (sym->builtin != NULL) {
328		a = ast_new_builtin(sym->builtin, l);
329		} else {
330		a = ast_new_apply(a, l, 0);
331		}
332
333		return(a);
	329	a = ast_new_builtin(sc, sym->builtin, l);
	330	} else {
	331	a = ast_new_apply(sc, a, l, 0);
	332	}
	333
	334	return(a);
	335	}
	336
	337	struct ast *
	338	parse_expr_list(struct scan_st sc, struct symbol_table stab,
	339	struct symbol excl, int cc)
	340	{
	341	struct ast a, b;
	342
	343	a = parse_expr(sc, stab, 0, excl, cc);
	344	if (tokeq(sc, ",")) {
	345	scan(sc);
	346	b = parse_expr_list(sc, stab, excl, cc);
	347	} else {
	348	b = NULL;
	349	}
	350	return(ast_new_arg(a, b));
334	351	}
335	352
336	353	/* ------------------------- EXPRESSIONS ------------------------ */

365	382	scan(sc);
366	383	done = 0;
367	384	r = parse_expr(sc, stab, level + 1, excl, cc);
368		l = ast_new_call2(the_op, stab, l, r);
	385	l = ast_new_call2(the_op, sc, stab, l, r);
369	386	break;
370	387	}
371	388	}

378	395	parse_primitive(struct scan_st sc, struct symbol_table stab,
379	396	struct symbol excl, int cc)
380	397	{
381		struct ast a, l, r, z;
	398	struct ast a, l, *r;
382	399	struct value *v;
383	400	struct symbol *sym;
384	401	struct symbol_table *istab;

390	407	} else if (tokeq(sc, "^")) {
391	408	int my_cc = 0;
392	409	int my_arity = 0;
	410	struct type *a_type = NULL;
393	411
394	412	/*
395	413	* Enclosing block contains a closure:

401	419	a = parse_var(sc, istab, &sym,
402	420	VAR_LOCAL, VAR_MUST_NOT_EXIST, NULL);
403	421	ast_free(a);
	422	if (a_type == NULL)
	423	a_type = sym->type;
	424	else
	425	a_type = type_new_arg(sym->type, a_type);
404	426	my_arity++;
	427	/*
	428	printf("ARG TYPE:");
	429	type_print(stdout, a_type);
	430	printf("\n");
	431	*/
405	432	if (tokeq(sc, ","))
406	433	scan(sc);
407	434	}
	435	if (a_type == NULL)
	436	a_type = type_new(TYPE_VOID);
408	437	a = parse_block(sc, stab, &istab, &my_cc);
409	438	a = ast_new_routine(my_arity, symbol_table_size(istab) - my_arity, my_cc, a);
	439	if (type_is_set(a->datatype) && type_set_contains_void(a->datatype)) {
	440	report(REPORT_ERROR, sc, "Routine must be either function or command");
	441	}
410	442	v = value_new_closure(a, NULL);
411		a = ast_new_value(v);
	443	a = ast_new_value(v,
	444	type_new_closure(a_type, a->datatype));
412	445	value_release(v);
413	446	} else if (tokeq(sc, "!")) {
414	447	scan(sc);
415	448	a = parse_primitive(sc, stab, excl, cc);
416	449	sym = symbol_lookup(stab, "!", 1);
417		a = ast_new_apply(ast_new_local(
418		sym->index,
419		stab->level - sym->in->level,
420		sym), a, 1);
	450	/* XXX builtin */
	451	a = ast_new_apply(sc, ast_new_local(stab, sym), a, 1);
421	452	} else if (tokeq(sc, "[")) {
422	453	scan(sc);
423	454	v = value_new_list();
424		a = ast_new_value(v);
	455	a = ast_new_value(v, NULL); /* XXX list */
425	456	value_release(v);
426	457	if (tokne(sc, "]")) {
427		ast_free(a);
428		l = parse_expr(sc, stab, 0, excl, cc);
429		r = ast_new_arg(l, NULL);
430		z = r;
431		while (tokeq(sc, ",")) {
432		scan(sc);
433		l = parse_expr(sc, stab, 0, excl, cc);
434		l = ast_new_arg(l, NULL);
435		z->u.arg.right = l;
436		z = l;
437		}
	458	l = parse_expr_list(sc, stab, excl, cc);
438	459	sym = symbol_lookup(stab, "List", VAR_GLOBAL);
439	460	assert(sym->builtin != NULL);
440		a = ast_new_builtin(sym->builtin, r);
	461	a = ast_new_builtin(sc, sym->builtin, l);
441	462	}
442	463	scan_expect(sc, "]");
443	464	} else if (sc->type == TOKEN_BAREWORD && isupper(sc->token[0])) {
444	465	a = parse_var(sc, stab, &sym, VAR_GLOBAL, VAR_MUST_EXIST, NULL);
445	466	if (sym == excl) {
446		scan_error(sc, "Initializer cannot refer to variable being defined");
	467	report(REPORT_ERROR, sc, "Initializer cannot refer to variable being defined");
447	468	return(NULL);
448	469	}
449	470	while (tokeq(sc, "(") \|\| tokeq(sc, "[") \|\| tokeq(sc, ".")) {
450	471	if (tokeq(sc, "(")) {
451	472	scan(sc);
452	473	if (tokne(sc, ")")) {
453		l = parse_expr(sc, stab, 0, excl, cc);
454		l = ast_new_arg(l, NULL);
455		z = l;
456		while (tokeq(sc, ",")) {
457		scan(sc);
458		r = parse_expr(sc, stab, 0, excl, cc);
459		r = ast_new_arg(r, NULL);
460		z->u.arg.right = r;
461		z = r;
462		}
	474	l = parse_expr_list(sc, stab, excl, cc);
463	475	} else {
464	476	l = NULL;
465	477	}
466	478	scan_expect(sc, ")");
	479
	480	if (!type_is_possibly_routine(sym->type)) {
	481	report(REPORT_ERROR, sc, "Function application of non-routine variable");
	482	/return(NULL);/
	483	}
	484	type_ensure_routine(sym->type);
	485	if (type_is_void(type_representative(sym->type)->t.closure.range)) {
	486	report(REPORT_ERROR, sc, "Function application of command variable");
	487	/return(NULL);/
	488	}
	489
467	490	if (sym->builtin != NULL) {
468		a = ast_new_builtin(sym->builtin, l);
	491	a = ast_new_builtin(sc, sym->builtin, l);
469	492	} else {
470		a = ast_new_apply(a, l, sym->is_pure);
	493	a = ast_new_apply(sc, a, l, sym->is_pure);
471	494	}
472	495	} else if (tokeq(sc, "[")) {
473	496	scan(sc);
474	497	r = parse_expr(sc, stab, 0, excl, cc);
475	498	scan_expect(sc, "]");
476		a = ast_new_call2("Fetch", stab, a, r);
	499	a = ast_new_call2("Fetch", sc, stab, a, r);
477	500	} else if (tokeq(sc, ".")) {
478	501	scan(sc);
479	502	r = parse_literal(sc, stab);
480		a = ast_new_call2("Fetch", stab, a, r);
	503	a = ast_new_call2("Fetch", sc, stab, a, r);
481	504	}
482	505	}
483	506	} else {

495	518
496	519	if (sc->type == TOKEN_BAREWORD && islower(sc->token[0])) {
497	520	v = value_new_atom(atom_resolve(sc->token));
498		a = ast_new_value(v);
	521	a = ast_new_value(v, type_new(TYPE_ATOM));
499	522	value_release(v);
500	523	scan(sc);
501	524	} else if (sc->type == TOKEN_NUMBER) {
502	525	v = value_new_integer(atoi(sc->token));
503		a = ast_new_value(v);
	526	a = ast_new_value(v, type_new(TYPE_INTEGER));
504	527	value_release(v);
505	528	scan(sc);
506	529	} else if (sc->type == TOKEN_QSTRING) {
507	530	v = value_new_string(sc->token);
508		a = ast_new_value(v);
	531	a = ast_new_value(v, type_new(TYPE_STRING));
509	532	value_release(v);
510	533	scan(sc);
511	534	} else {
512		scan_error(sc, "Illegal literal");
	535	report(REPORT_ERROR, sc, "Illegal literal");
513	536	scan(sc);
514	537	a = NULL;
515	538	}

528	551	*sym = symbol_lookup(stab, sc->token, globality);
529	552	if (*sym == NULL) {
530	553	if (existence == VAR_MUST_EXIST) {
531		scan_error(sc, "Undefined symbol");
	554	report(REPORT_ERROR, sc, "Undefined symbol");
532	555	}
533	556	*sym = symbol_define(stab, sc->token, SYM_KIND_VARIABLE, v);
	557	symbol_set_type(*sym, type_brand_new_var());
534	558	} else {
535	559	if (existence == VAR_MUST_NOT_EXIST) {
536		scan_error(sc, "Symbol already defined");
	560	report(REPORT_ERROR, sc, "Symbol already defined");
537	561	}
538	562	}
539	563	scan(sc);
540	564
541	565	if ((*sym)->value != NULL) {
542		a = ast_new_value((*sym)->value);
543		} else {
544		a = ast_new_local((sym)->index, stab->level - (sym)->in->level, (*sym));
545		}
546		return(a);
547		}
	566	a = ast_new_value((sym)->value, (sym)->type);
	567	} else {
	568	a = ast_new_local(stab, (*sym));
	569	}
	570	return(a);
	571	}

-1

src/parse.h less more

21	21	int *);
22	22	struct ast parse_command_or_assignment(struct scan_st , struct symbol_table *,
23	23	int *);
	24	struct ast parse_expr_list(struct scan_st , struct symbol_table *,
	25	struct symbol , int );
24	26	struct ast parse_expr(struct scan_st , struct symbol_table *, int,
25	27	struct symbol , int );
26	28	struct ast parse_primitive(struct scan_st , struct symbol_table *,
27	29	struct symbol , int );
28		/struct ast parse_list_elem(struct scan_st , struct symbol_table );*/
29	30	struct ast parse_literal(struct scan_st , struct symbol_table *);
30	31	struct ast parse_var(struct scan_st , struct symbol_table *,
31	32	struct symbol *, int, int, struct value );

+120

-0

src/report.c less more

	0	/*
	1	* Copyright (c)2004 Cat's Eye Technologies. All rights reserved.
	2	*
	3	* Redistribution and use in source and binary forms, with or without
	4	* modification, are permitted provided that the following conditions
	5	* are met:
	6	*
	7	* Redistributions of source code must retain the above copyright
	8	* notice, this list of conditions and the following disclaimer.
	9	*
	10	* Redistributions in binary form must reproduce the above copyright
	11	* notice, this list of conditions and the following disclaimer in
	12	* the documentation and/or other materials provided with the
	13	* distribution.
	14	*
	15	* Neither the name of Cat's Eye Technologies nor the names of its
	16	* contributors may be used to endorse or promote products derived
	17	* from this software without specific prior written permission.
	18	*
	19	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
	20	* ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
	21	* LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
	22	* FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
	23	* COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
	24	* INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
	25	* (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
	26	* SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
	27	* HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
	28	* STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
	29	* ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
	30	* OF THE POSSIBILITY OF SUCH DAMAGE.
	31	*/
	32	/*
	33	* report.c
	34	* Translation error/warning reporter for Bhuna.
	35	* $Id: scan.c 54 2004-04-23 22:51:09Z catseye $
	36	*/
	37
	38	#include <stdarg.h>
	39	#include <stdio.h>
	40	/*
	41	#include <stdlib.h>
	42	#include <string.h>
	43	*/
	44
	45	#include "mem.h"
	46	#include "scan.h"
	47	#include "report.h"
	48
	49	#include "type.h"
	50	#include "symbol.h"
	51
	52	static int errors;
	53	static int warnings;
	54	static FILE *rfile;
	55
	56	void
	57	report_start(void)
	58	{
	59	rfile = stderr;
	60	errors = 0;
	61	warnings = 0;
	62	}
	63
	64	int
	65	report_finish(void)
	66	{
	67	/* if verbose */
	68	fprintf(rfile, "Translation finished with %d errors and %d warnings\n",
	69	errors, warnings);
	70	return(errors);
	71	}
	72
	73	void
	74	report(int rtype, struct scan_st sc, char fmt, ...)
	75	{
	76	va_list args;
	77	int i;
	78
	79	if (sc != NULL) {
	80	fprintf(rfile, "%s (line %d, column %d, token '%s'): ",
	81	rtype == REPORT_ERROR ? "Error" : "Warning",
	82	sc->lino, sc->columno, sc->token);
	83	} else {
	84	fprintf(rfile, "%s (line ?, column ?, token ?): ",
	85	rtype == REPORT_ERROR ? "Error" : "Warning");
	86	}
	87
	88	va_start(args, fmt);
	89	for (i = 0; fmt[i] != '\0'; i++) {
	90	if (fmt[i] == '%') {
	91	i++;
	92	switch (fmt[i]) {
	93	case 't':
	94	type_print(rfile, va_arg(args, struct type *));
	95	break;
	96	case 'S':
	97	symbol_print(rfile, va_arg(args, struct symbol *));
	98	break;
	99	case 's':
	100	fprintf(stderr, "%s", va_arg(args, char *));
	101	break;
	102	case 'd':
	103	fprintf(stderr, "%d", va_arg(args, int));
	104	break;
	105	}
	106	} else {
	107	fprintf(rfile, "%c", fmt[i]);
	108	}
	109	}
	110	va_end(args);
	111
	112	fprintf(rfile, ".\n");
	113
	114	if (rtype == REPORT_ERROR) {
	115	errors++;
	116	} else {
	117	warnings++;
	118	}
	119	}

+22

-0

src/report.h less more

	0	/*
	1	* report.h
	2	* Error/warning reporter for Bhuna.
	3	* $Id$
	4	*/
	5
	6	#ifndef __REPORT_H_
	7	#define __REPORT_H_
	8
	9	#include <stdio.h>
	10
	11	struct scan_st;
	12
	13	#define REPORT_ERROR 1
	14	#define REPORT_WARNING 0
	15
	16	extern void report_start(void);
	17	extern int report_finish(void);
	18
	19	extern void report(int, struct scan_st , char , ...);
	20
	21	#endif /* !__SCAN_H_ */

+27

-28

src/scan.c less more

42	42
43	43	#include "mem.h"
44	44	#include "scan.h"
	45	#include "report.h"
45	46
46	47	struct scan_st *
47	48	scan_open(char *filename)
48	49	{
49	50	struct scan_st *sc;
50	51
51		if ((sc = bhuna_malloc(sizeof(struct scan_st))) == 0) {
52		return(NULL);
53		}
54		if ((sc->token = (char )bhuna_malloc(256 sizeof(char))) == NULL) {
55		bhuna_free(sc);
56		return(NULL);
57		}
	52	sc = bhuna_malloc(sizeof(struct scan_st));
	53	sc->token = (char )bhuna_malloc(256 sizeof(char));
	54
58	55	if ((sc->in = fopen(filename, "r")) == NULL) {
59	56	bhuna_free(sc->token);
60	57	bhuna_free(sc);

63	60
64	61	sc->lino = 1;
65	62	sc->columno = 1;
66		sc->errors = 0;
67	63	scan(sc); /* prime the pump */
68	64
69	65	return(sc);
70	66	}
71	67
	68	/*
	69	* This is just to ease error reporting, so we don't copy the file or nothin'.
	70	*/
	71	struct scan_st *
	72	scan_dup(struct scan_st *orig)
	73	{
	74	struct scan_st *sc;
	75
	76	sc = bhuna_malloc(sizeof(struct scan_st));
	77	sc->token = bhuna_strdup(orig->token);
	78	sc->in = NULL;
	79	sc->lino = orig->lino;
	80	sc->columno = orig->columno;
	81
	82	return(sc);
	83	}
	84
72	85	void
73	86	scan_close(struct scan_st *sc)
74		{
75		fclose(sc->in);
	87	{
	88	if (sc->in != NULL)
	89	fclose(sc->in);
76	90	bhuna_free(sc->token);
77	91	bhuna_free(sc);
78		}
79
80		void
81		scan_error(struct scan_st sc, char fmt, ...)
82		{
83		va_list args;
84		char err[256];
85
86		va_start(args, fmt);
87		vsnprintf(err, 255, fmt, args);
88
89		printf("Error (line %d, column %d, token '%s'): %s.\n",
90		sc->lino, sc->columno, sc->token, err);
91
92		sc->errors++;
93	92	}
94	93
95	94	void

231	230	if (!strcmp(sc->token, x)) {
232	231	scan(sc);
233	232	} else {
234		scan_error(sc, "Expected '%s'", x);
235		}
236		}
	233	report(REPORT_ERROR, sc, "Expected '%s'", x);
	234	}
	235	}

-2

src/scan.h less more

24	24	int type; /* type of token that was scanned */
25	25	int lino; /* current line number, 1-based */
26	26	int columno; /* current column number, 1-based */
27		int errors; /* # of errors encountered so far */
28	27	};
29	28
30	29	#define tokeq(sc, x) (strcmp(sc->token, x) == 0)
31	30	#define tokne(sc, x) (strcmp(sc->token, x) != 0)
32	31
33	32	extern struct scan_st scan_open(char );
	33	extern struct scan_st scan_dup(struct scan_st );
34	34	extern void scan_close(struct scan_st *);
35		extern void scan_error(struct scan_st , char , ...);
36	35	extern void scan(struct scan_st *);
37	36	extern void scan_expect(struct scan_st , char );
38	37

+23

-0

src/symbol.c less more

44	44
45	45	#include "mem.h"
46	46	#include "symbol.h"
	47	#include "type.h"
47	48	#include "value.h"
48	49
49	50	/* GLOBALS */

69	70	sym->in = NULL;
70	71	sym->index = -1;
71	72	sym->is_pure = 0;
	73	sym->type = NULL;
72	74	sym->value = NULL;
73	75	sym->builtin = NULL;
74	76

78	80	static void
79	81	symbol_free(struct symbol *sym)
80	82	{
	83	type_free(&sym->type);
81	84	value_release(sym->value);
82	85	bhuna_free(sym->token);
83	86	bhuna_free(sym);

205	208	}
206	209
207	210	void
	211	symbol_set_type(struct symbol sym, struct type t)
	212	{
	213	if (sym->type != NULL) {
	214	type_free(&sym->type);
	215	}
	216	sym->type = t;
	217	}
	218
	219	void
208	220	symbol_set_value(struct symbol sym, struct value v)
209	221	{
210	222	assert(sym->value != NULL);

247	259	for (i = 0; i < stab_indent; i++)
248	260	printf(" ");
249	261	printf("`%s'(%08lx)", sym->token, (unsigned long)sym);
	262	type_print(stdout, sym->type);
250	263	if (sym->value != NULL) {
251	264	printf("=");
252	265	value_print(sym->value);
253	266	}
254	267	#endif
255	268	}
	269
	270	void
	271	symbol_print(FILE f, struct symbol sym)
	272	{
	273	#ifdef DEBUG
	274	fprintf(f, "symbol `%s' (type = ", sym->token);
	275	type_print(f, sym->type);
	276	fprintf(f, ")");
	277	#endif
	278	}

-0

src/symbol.h less more

6	6	#ifndef __SYMBOL_H_
7	7	#define __SYMBOL_H_
8	8
	9	#include <stdio.h>
	10
9	11	struct value;
	12	struct type;
10	13
11	14	struct symbol_table {
12	15	struct symbol_table parent; / link to scopes above us */

20	23	struct symbol next; / next symbol in symbol table */
21	24	char token; / lexeme making up the symbol */
22	25	int kind; /* kind of symbol */
	26	struct type type; / data type */
23	27
24	28	struct builtin *builtin;
25	29	int is_pure; /* if true, symbol represents a function which is ref.transp. */

46	50
47	51	int symbol_is_global(struct symbol *);
48	52
	53	void symbol_set_type(struct symbol , struct type );
49	54	void symbol_set_value(struct symbol , struct value );
50	55
51	56	void symbol_table_dump(struct symbol_table *, int);
52	57	void symbol_dump(struct symbol *, int);
53	58
	59	void symbol_print(FILE f, struct symbol );
	60
54	61	#endif /* !__SYMBOL_H_ */

+463

-0

src/type.c less more

	0	#include <assert.h>
	1	#include <stdio.h>
	2
	3	#include "mem.h"
	4	#include "type.h"
	5	#include "report.h"
	6	#include "scan.h"
	7
	8	static struct type *t_head = NULL;
	9
	10	struct type *
	11	type_new(int tclass)
	12	{
	13	struct type *t;
	14
	15	t = bhuna_malloc(sizeof(struct type));
	16	t->tclass = tclass;
	17	t->unifier = NULL;
	18	t->next = t_head;
	19	t_head = NULL;
	20
	21	return(t);
	22	}
	23
	24	struct type *
	25	type_new_list(struct type *contents)
	26	{
	27	struct type *t = type_new(TYPE_LIST);
	28
	29	t->t.list.contents = contents;
	30
	31	return(t);
	32	}
	33
	34	struct type *
	35	type_new_dict(struct type index, struct type contents)
	36	{
	37	struct type *t = type_new(TYPE_DICT);
	38
	39	t->t.dict.index = index;
	40	t->t.dict.contents = contents;
	41
	42	return(t);
	43	}
	44
	45	struct type *
	46	type_new_closure(struct type domain, struct type range)
	47	{
	48	struct type *t = type_new(TYPE_CLOSURE);
	49
	50	t->t.closure.domain = domain;
	51	t->t.closure.range = range;
	52
	53	return(t);
	54	}
	55
	56	struct type *
	57	type_new_arg(struct type left, struct type right)
	58	{
	59	struct type *t = type_new(TYPE_ARG);
	60
	61	t->t.arg.left = left;
	62	t->t.arg.right = right;
	63
	64	return(t);
	65	}
	66
	67	struct type *
	68	type_new_set(struct type left, struct type right)
	69	{
	70	struct type *t;
	71
	72	/*
	73	printf("constructing set from:\n1: ");
	74	type_print(stdout, left);
	75	printf("\n2: ");
	76	type_print(stdout, right);
	77	printf("\n");
	78	*/
	79
	80	if (type_equal(type_representative(left), type_representative(right)))
	81	return(left);
	82
	83	/* ???
	84	if (type_is_void(left))
	85	return(right);
	86	if (type_is_void(right))
	87	return(left);
	88	*/
	89
	90	t = type_new(TYPE_SET);
	91	t->t.set.left = left;
	92	t->t.set.right = right;
	93
	94	return(t);
	95	}
	96
	97	struct type *
	98	type_new_var(int num)
	99	{
	100	struct type *t = type_new(TYPE_VAR);
	101
	102	t->t.var.num = num;
	103
	104	return(t);
	105	}
	106
	107	static int next_var_num = 10;
	108
	109	struct type *
	110	type_brand_new_var(void)
	111	{
	112	struct type *t = type_new(TYPE_VAR);
	113
	114	t->t.var.num = next_var_num++;
	115
	116	return(t);
	117	}
	118
	119	void
	120	type_free(struct type **ty)
	121	{
	122	/*
	123	struct type *t;
	124
	125	if (ty == NULL \|\| *ty == NULL)
	126	return;
	127
	128	t = *ty;
	129	printf("freeing ");
	130	type_print(stdout, t);
	131	printf("...\n");
	132
	133	switch (t->tclass) {
	134	case TYPE_LIST:
	135	type_free(&t->t.list.contents);
	136	break;
	137	case TYPE_DICT:
	138	type_free(&t->t.dict.index);
	139	type_free(&t->t.dict.contents);
	140	break;
	141	case TYPE_CLOSURE:
	142	type_free(&t->t.closure.domain);
	143	type_free(&t->t.closure.range);
	144	break;
	145	case TYPE_ARG:
	146	type_free(&t->t.arg.left);
	147	type_free(&t->t.arg.right);
	148	break;
	149	}
	150
	151	bhuna_free(t);
	152	*ty = NULL;
	153	*/
	154	}
	155
	156	/*
	157	struct type *
	158	type_dup(struct type *t)
	159	{
	160	struct type *n;
	161
	162	if (t == NULL)
	163	return(NULL);
	164
	165	n = type_new(t->tclass);
	166	switch (t->tclass) {
	167	case TYPE_VAR:
	168	n->t.var.num = t->t.var.num; unless...
	169	n->unifier = t->unifier;
	170	break;
	171	case TYPE_LIST:
	172	n->t.list.contents = type_dup(t->t.list.contents);
	173	break;
	174	case TYPE_DICT:
	175	n->t.dict.index = type_dup(t->t.dict.index);
	176	n->t.dict.contents = type_dup(t->t.dict.contents);
	177	break;
	178	case TYPE_CLOSURE:
	179	n->t.closure.domain = type_dup(t->t.closure.domain);
	180	n->t.closure.range = type_dup(t->t.closure.range);
	181	case TYPE_ARG:
	182	n->t.arg.left = type_dup(t->t.arg.left);
	183	n->t.arg.right = type_dup(t->t.arg.right);
	184	}
	185
	186	return(n);
	187	}
	188	*/
	189
	190	/*
	191	* Structural equivalence.
	192	*/
	193	int
	194	type_equal(struct type a, struct type b)
	195	{
	196	if (a == NULL && b == NULL)
	197	return(1);
	198	if (a == NULL \|\| b == NULL)
	199	return(0);
	200	if (a->tclass != b->tclass)
	201	return(0);
	202
	203	switch (a->tclass) {
	204	case TYPE_LIST:
	205	return(type_equal(a->t.list.contents, b->t.list.contents));
	206	case TYPE_DICT:
	207	return(type_equal(a->t.dict.index, b->t.dict.index) &&
	208	type_equal(a->t.dict.contents, b->t.dict.contents));
	209	case TYPE_CLOSURE:
	210	return(type_equal(a->t.closure.domain, b->t.closure.domain) &&
	211	type_equal(a->t.closure.range, b->t.closure.range));
	212	case TYPE_ARG:
	213	return(type_equal(a->t.arg.left, b->t.arg.left) &&
	214	type_equal(a->t.arg.right, b->t.arg.right));
	215	case TYPE_SET:
	216	return(type_equal(a->t.set.left, b->t.set.left) &&
	217	type_equal(a->t.set.right, b->t.set.right));
	218	}
	219	return(1);
	220	}
	221
	222	/********** TYPE INFERENCE ***********/
	223
	224	/*
	225	* Unification algorithm
	226	* Shamelessly adapted from the Dragon Book.
	227	*/
	228
	229	/*
	230	* Find the representative of the equivalence class of a type.
	231	* This is used by external code to get the concrete type
	232	* lurking behind a (bound) type variable.
	233	*/
	234	struct type *
	235	type_representative(struct type *q)
	236	{
	237	struct type *p = q;
	238
	239	while (p->unifier != NULL) {
	240	p = p->unifier;
	241	}
	242
	243	return(p);
	244	}
	245
	246	/*
	247	* Merge the two equivalence classes of the two types.
	248	*/
	249	void
	250	type_union(struct type m, struct type n)
	251	{
	252	struct type s, t;
	253
	254	s = type_representative(m);
	255	t = type_representative(n);
	256
	257	if (s->tclass != TYPE_VAR) {
	258	t->unifier = s;
	259	} else if (t->tclass != TYPE_VAR) {
	260	s->unifier = t;
	261	} else {
	262	s->unifier = t;
	263	}
	264	}
	265
	266	/*
	267	* Make two type expressions equal through substitutions.
	268	*/
	269	int
	270	type_unify(struct type m, struct type n)
	271	{
	272	struct type s, t;
	273
	274	s = type_representative(m);
	275	t = type_representative(n);
	276
	277	if (s == t) {
	278	return(1);
	279	} else if (s->tclass == TYPE_DICT && t->tclass == TYPE_DICT) {
	280	type_union(s, t);
	281	return(type_unify(s->t.dict.index, t->t.dict.index) &&
	282	type_unify(s->t.dict.contents, t->t.dict.contents));
	283	} else if (s->tclass == TYPE_LIST && t->tclass == TYPE_LIST) {
	284	type_union(s, t);
	285	return(type_unify(s->t.list.contents, t->t.list.contents));
	286	} else if (s->tclass == TYPE_CLOSURE && t->tclass == TYPE_CLOSURE) {
	287	type_union(s, t);
	288	return(type_unify(s->t.closure.domain, t->t.closure.domain) &&
	289	type_unify(s->t.closure.range, t->t.closure.range));
	290	} else if (s->tclass == TYPE_ARG && t->tclass == TYPE_ARG) {
	291	type_union(s, t);
	292	return(type_unify(s->t.arg.left, t->t.arg.left) &&
	293	type_unify(s->t.arg.right, t->t.arg.right));
	294	} else if (s->tclass == TYPE_SET && t->tclass == TYPE_SET) {
	295	/* XXX actually we should also check when one is a set and one isn't,
	296	and succeed if the one that isn't the set is in the set... */
	297	type_union(s, t);
	298	return(type_unify(s->t.set.left, t->t.set.left) &&
	299	type_unify(s->t.set.right, t->t.set.right));
	300	} else if (s->tclass == TYPE_VAR \|\| t->tclass == TYPE_VAR) {
	301	type_union(s, t);
	302	return(1);
	303	} else if (s->tclass == t->tclass) {
	304	return(1);
	305	} else {
	306	return(0);
	307	}
	308	}
	309
	310	int
	311	type_unify_crit(struct scan_st sc, struct type m, struct type *n)
	312	{
	313	int unified;
	314
	315	if (!(unified = type_unify(m, n))) {
	316	report(REPORT_ERROR, sc,
	317	"Failed to unify types %t and %t",
	318	m, n);
	319	}
	320
	321	return(unified);
	322	}
	323
	324	/*
	325	* If the given type is an unbound variable, unify it with a function
	326	* from a (fresh) unbound variable to another (fresh) unbound variable.
	327	* This way we can handle unifying just the domain or just the range
	328	* part of a (variable) type with another type.
	329	*/
	330	void
	331	type_ensure_routine(struct type *t)
	332	{
	333	struct type r, n;
	334
	335	/*
	336	printf("ENSURING ROUTINE:");
	337	type_print(stdout, t);
	338	printf("\n");
	339	*/
	340
	341	r = type_representative(t);
	342	if (r->tclass == TYPE_VAR) {
	343	n = type_new_closure(type_brand_new_var(), type_brand_new_var());
	344	r->unifier = n;
	345	}
	346	}
	347
	348	int
	349	type_is_possibly_routine(struct type *t)
	350	{
	351	struct type *r;
	352
	353	r = type_representative(t);
	354	return(r->tclass == TYPE_VAR \|\| r->tclass == TYPE_CLOSURE);
	355	}
	356
	357	int
	358	type_is_void(struct type *t)
	359	{
	360	struct type *r;
	361
	362	r = type_representative(t);
	363	return(r->tclass == TYPE_VOID);
	364	}
	365
	366	int
	367	type_is_set(struct type *t)
	368	{
	369	struct type *r;
	370
	371	r = type_representative(t);
	372	return(r->tclass == TYPE_SET);
	373	}
	374
	375	int
	376	type_set_contains_void(struct type *t)
	377	{
	378	struct type *r;
	379
	380	r = type_representative(t);
	381	if (r->tclass == TYPE_VOID) {
	382	return(1);
	383	} else if (r->tclass == TYPE_SET) {
	384	return(type_set_contains_void(r->t.set.left) \|\|
	385	type_set_contains_void(r->t.set.right));
	386	} else {
	387	return(0);
	388	}
	389	}
	390
	391	void
	392	type_print(FILE f, struct type t)
	393	{
	394	#ifdef DEBUG
	395	if (t == NULL) {
	396	fprintf(f, "(?null?)");
	397	return;
	398	}
	399	switch (t->tclass) {
	400	case TYPE_VOID:
	401	fprintf(f, "void");
	402	break;
	403	case TYPE_INTEGER:
	404	fprintf(f, "integer");
	405	break;
	406	case TYPE_BOOLEAN:
	407	fprintf(f, "boolean");
	408	break;
	409	case TYPE_ATOM:
	410	fprintf(f, "atom");
	411	break;
	412	case TYPE_STRING:
	413	fprintf(f, "string");
	414	break;
	415	case TYPE_LIST:
	416	fprintf(f, "list of ");
	417	type_print(f, t->t.list.contents);
	418	break;
	419	case TYPE_ERROR:
	420	fprintf(f, "error");
	421	break;
	422	case TYPE_BUILTIN:
	423	fprintf(f, "builtin");
	424	break;
	425	case TYPE_OPAQUE:
	426	fprintf(f, "opaque");
	427	break;
	428	case TYPE_VAR:
	429	fprintf(f, "Type%d", t->t.var.num);
	430	if (t->unifier != NULL) {
	431	fprintf(f, "=(");
	432	type_print(f, t->unifier);
	433	fprintf(f, ")");
	434	}
	435	break;
	436	case TYPE_ARG:
	437	type_print(f, t->t.arg.left);
	438	fprintf(f, ", ");
	439	type_print(f, t->t.arg.right);
	440	break;
	441	case TYPE_SET:
	442	fprintf(f, "(");
	443	type_print(f, t->t.arg.left);
	444	fprintf(f, " \| ");
	445	type_print(f, t->t.arg.right);
	446	fprintf(f, ")");
	447	break;
	448	case TYPE_DICT:
	449	fprintf(f, "dict from ");
	450	type_print(f, t->t.dict.index);
	451	fprintf(f, " to ");
	452	type_print(f, t->t.dict.contents);
	453	break;
	454	case TYPE_CLOSURE:
	455	fprintf(f, "fn from ");
	456	type_print(f, t->t.closure.domain);
	457	fprintf(f, " to ");
	458	type_print(f, t->t.closure.range);
	459	break;
	460	}
	461	#endif
	462	}

+89

-0

src/type.h less more

	0	#include <stdio.h>
	1
	2	struct scan_st;
	3
	4	#define TYPE_VOID 0
	5	#define TYPE_INTEGER 1
	6	#define TYPE_BOOLEAN 2
	7	#define TYPE_ATOM 3
	8	#define TYPE_STRING 4
	9	#define TYPE_LIST 5
	10	#define TYPE_ERROR 6
	11	#define TYPE_BUILTIN 7
	12	#define TYPE_CLOSURE 8
	13	#define TYPE_DICT 9
	14	#define TYPE_OPAQUE 15
	15	#define TYPE_VAR 16
	16	#define TYPE_ARG 17
	17	#define TYPE_SET 18
	18
	19	struct type_list {
	20	struct type *contents;
	21	};
	22
	23	struct type_dict {
	24	struct type *index;
	25	struct type *contents;
	26	};
	27
	28	struct type_closure {
	29	struct type *domain;
	30	struct type *range;
	31	};
	32
	33	/* type of a list of arguments given to a function, c.f. ast_arg */
	34	struct type_arg {
	35	struct type *left;
	36	struct type *right;
	37	};
	38
	39	/* union of several heterogenous types... :) */
	40	struct type_set {
	41	struct type *left;
	42	struct type *right;
	43	};
	44
	45	struct type_var {
	46	int num;
	47	};
	48
	49	union type_union {
	50	struct type_list list;
	51	struct type_dict dict;
	52	struct type_closure closure;
	53	struct type_arg arg;
	54	struct type_set set;
	55	struct type_var var;
	56	};
	57
	58	struct type {
	59	struct type next; / for freein' */
	60	int tclass;
	61	struct type unifier; / equiv. class under type unif. */
	62	union type_union t;
	63	};
	64
	65	struct type *type_new(int);
	66	struct type type_new_list(struct type );
	67	struct type type_new_dict(struct type , struct type *);
	68	struct type type_new_closure(struct type , struct type *);
	69	struct type type_new_arg(struct type , struct type *);
	70	struct type type_new_set(struct type , struct type *);
	71	struct type *type_new_var(int);
	72	struct type *type_brand_new_var(void);
	73
	74	void type_free(struct type **);
	75	/struct type type_dup(struct type );/
	76
	77	int type_equal(struct type , struct type );
	78	int type_unify(struct type , struct type );
	79	struct type type_representative(struct type );
	80
	81	void type_ensure_routine(struct type *);
	82	int type_is_possibly_routine(struct type *);
	83	int type_unify_crit(struct scan_st , struct type , struct type *);
	84	int type_is_void(struct type *);
	85	int type_is_set(struct type *);
	86	int type_set_contains_void(struct type *);
	87
	88	void type_print(FILE , struct type );

-1

src/value.c less more

47	47	#include "dict.h"
48	48	#include "closure.h"
49	49
	50	#include "type.h"
	51
50	52	#ifdef POOL_VALUES
51	53	#include "pool.h"
52	54	#endif

252	254
253	255	/* DESTRUCTOR */
254	256
255		static void
	257	void
256	258	value_free(struct value *v)
257	259	{
258	260	if (v == NULL)

286	288
287	289	/* REFCOUNTERS */
288	290
	291	#ifndef REFCOUNTING_MACROS
289	292	void
290	293	value_grab(struct value *v)
291	294	{

321	324	if (v->refcount == 0)
322	325	value_free(v);
323	326	}
	327	#endif
324	328
325	329	/* SPECIFIC CONSTRUCTORS */
326	330

+13

-5

src/value.h less more

25	25	#define VALUE_ATOM 3
26	26	#define VALUE_STRING 4
27	27	#define VALUE_LIST 5
28		#define VALUE_STAB 6
29		#define VALUE_ERROR 7
30		#define VALUE_BUILTIN 8
31		#define VALUE_CLOSURE 9
32		#define VALUE_DICT 10
	28	#define VALUE_ERROR 6
	29	#define VALUE_BUILTIN 7
	30	#define VALUE_CLOSURE 8
	31	#define VALUE_DICT 9
33	32	#define VALUE_OPAQUE 15
34	33
35	34	union value_union {

50	49	union value_union v;
51	50	};
52	51
	52	#ifdef REFCOUNTING_MACROS
	53	#define value_release(v) \
	54	if ((v) != NULL && (--((v)->refcount)) == 0) value_free((v));
	55	#define value_grab(v) \
	56	if ((v) != NULL) (v)->refcount++;
	57	#else
53	58	void value_grab(struct value *);
54	59	void value_release(struct value *);
	60	#endif
	61
	62	void value_free(struct value *);
55	63
56	64	struct value value_dup(struct value );
57	65

+16

-9

src/vm.c less more

36	36
37	37	extern int trace_vm;
38	38	static int i;
39
	39	/static int subs = 0;/
	40
	41	#ifdef DEBUG
40	42	static void
41	43	dump_stack()
42	44	{

49	51	printf("\n");
50	52	}
51	53	}
	54	#endif
52	55
53	56	void
54	57	vm_run(vm_label_t program)

58	61	struct value l = NULL, r = NULL, *v = NULL;
59	62	struct activation *ar;
60	63	int varity;
	64	/int upcount, index; /
61	65
62	66	#ifdef DEBUG
63	67	if (trace_vm) {

113	117	case INDEX_BUILTIN_EQU:
114	118	POP_VALUE(r);
115	119	POP_VALUE(l);
116		if (l->type == VALUE_INTEGER && r->type == VALUE_INTEGER) {
	120	//if (l->type == VALUE_INTEGER && r->type == VALUE_INTEGER) {
117	121	v = value_new_boolean(l->v.i == r->v.i);
118		} else {
119		v = value_new_error("type mismatch");
120		}
	122	//} else {
	123	// v = value_new_error("type mismatch");
	124	//}
121	125	PUSH_VALUE(v);
122	126	value_release(l);
123	127	value_release(r);

186	190	case INDEX_BUILTIN_ADD:
187	191	POP_VALUE(r);
188	192	POP_VALUE(l);
189		if (l->type == VALUE_INTEGER && r->type == VALUE_INTEGER) {
	193	//if (l->type == VALUE_INTEGER && r->type == VALUE_INTEGER) {
190	194	v = value_new_integer(l->v.i + r->v.i);
191		} else {
192		v = value_new_error("type mismatch");
193		}
	195	//} else {
	196	// v = value_new_error("type mismatch");
	197	//}
194	198	PUSH_VALUE(v);
195	199	value_release(l);
196	200	value_release(r);

210	214	case INDEX_BUILTIN_SUB:
211	215	POP_VALUE(r);
212	216	POP_VALUE(l);
	217	//subs++;
213	218	if (l->type == VALUE_INTEGER && r->type == VALUE_INTEGER) {
214	219	v = value_new_integer(l->v.i - r->v.i);
215	220	} else {

267	272
268	273	case INSTR_PUSH_LOCAL:
269	274	l = activation_get_value(current_ar, (pc + 1), (pc + 2));
	275
270	276	#ifdef DEBUG
271	277	if (trace_vm) {
272	278	printf("INSTR_PUSH_LOCAL:\n");

476	482	if (trace_vm) {
477	483	printf("___ virtual machine finished ___\n");
478	484	}
	485	/printf("subs = %d\n", subs);/
479	486	#endif
480	487	}
481	488