Commit adb911dd46e3b76e0b987bedde35149e1dfa72e8 - Bhuna

Import of Bhuna 0.7 sources. catseye 10 years ago

56 changed file(s) with 2072 addition(s) and 1364 deletion(s). Raw diff Collapse all Expand all

+11

-0

doc/tally.pl less more

	0	#!/usr/bin/perl
	1
	2	while ($d = <STDIN>) {
	3	$ary[$1]++ if $d =~ /^\#(\d+)\:/;
	4	}
	5
	6	printf "%8s %8s\n", "Instr#", "Count";
	7	for ($i = 0; $i <= $#ary; $i++) {
	8	printf "%8d %8d\n", $i, $ary[$i] if $ary[$i] > 0;
	9	}
	10

+25

-0

eg/clobj3.bhu less more

	0	Stack = ^ Size {
	1	S = [1,2,3,4,5,6,7]
	2	SP = 1
	3
	4	Push = ^ E {
	5	//S[SP] = E
	6	Store S, SP, E
	7	SP = SP + 1
	8	}
	9
	10	Pop = ^ {
	11	SP = SP - 1
	12	return S[SP]
	13	}
	14
	15	return ^{}
	16	}
	17
	18	Q = Stack(256)
	19
	20	Print Q.1, EoL
	21	Print Q.2, EoL
	22	Print Q.3, EoL
	23	Print Q.4, EoL
	24	Print Q.5, EoL

-5

eg/clobject.bhu less more

23	23	T_Push = T[1]
24	24	T_Pop = T[2]
25	25
26		T_Push 23
	26	// T_Push 23
27	27
28		Q_Push 15
29		Print Q_Pop(), EoL
	28	// Q_Push 15
	29	// Print Q_Pop(), EoL
30	30
31		T_Push 71
32		Print T_Pop(), " ", T_Pop(), EoL
	31	// T_Push 71
	32	// Print T_Pop(), " ", T_Pop(), EoL
33	33

+18

-0

eg/fibspawn2.bhu less more

	0	Fib = ^ X {
	1	if X > 2
	2	return Fib(X - 1) + Fib(X - 2)
	3	else
	4	return 1
	5	}
	6
	7	MakeFibPrinter = ^ X {
	8	return ^ { Print "Fib(", X, ")=", Fib(X), EoL }
	9	}
	10
	11	I = 1
	12	while I <= 25 {
	13	Q = MakeFibPrinter(I)
	14	Pid = Spawn(Q)
	15	Print "Pid was ", Pid, EoL
	16	I = I + 1
	17	}

+25

-0

eg/msg.bhu less more

	0	Task = ^ {
	1	Done = False
	2	Ctr = 0
	3	while !Done {
	4	Msg = Recv(100)
	5	Print Ctr, ": Recv'd ", Msg, EoL
	6	Ctr = Ctr + 1
	7	}
	8	}
	9
	10	Pid = Spawn(Task)
	11
	12	MainDone = False
	13	while !MainDone {
	14	I = 0 J = 0
	15	while I < 1000000 {
	16	while J < 1000000 {
	17	J = J + 1
	18	}
	19	I = I + 1
	20	}
	21	Send Pid, "hello"
	22	// MainDone = True
	23	}
	24

+41

-0

eg/prod2.bhu less more

	0	Producer = ^ N, NP, Main {
	1	if N = 0 {
	2	// Print "Producer done w/", NP, EoL
	3	Send Main, [Self(), NP]
	4	} else {
	5	Msg = Recv(1000)
	6	// Print "Producing ", NP, EoL
	7	Send Msg, NP
	8	Producer N - 1, NP + 1, Main
	9	}
	10	}
	11
	12	Consumer = ^ N, NC, P, Main {
	13	if N = 0 {
	14	// Print "Consumer done w/", NC, EoL
	15	Send Main, [Self(), NC]
	16	} else {
	17	// Print "Consumer wanting next", EoL
	18	Send P, Self()
	19	// Print "Consuming...", EoL
	20	Msg = Recv(1000)
	21	// Print "Consumer got ", Msg, EoL
	22	Consumer N - 1, NC + 1, P, Main
	23	}
	24	}
	25
	26	N = 100000
	27	Main = Self()
	28	P = Spawn(^{ Producer N, 0, Main })
	29	C = Spawn(^{ Consumer N, 0, P, Main })
	30
	31	NP = 0
	32	NC = 0
	33
	34	while NP = 0 \| NC = 0 {
	35	Msg = Recv(1000)
	36	if Msg[1] = P { NP = Msg[2] }
	37	if Msg[1] = C { NC = Msg[2] }
	38	}
	39
	40	Print NP, " ", NC, EoL

+32

-0

eg/prodcons-orig.bhu less more

	0	Producer = ^ N, NP, Main {
	1	if N = 0
	2	Send Main, <Self(), NP>
	3	else
	4	Msg = Recv(1000)
	5	Send Msg[1], <data, NP>
	6	Producer N - 1, NP + 1, Main
	7	}
	8
	9	Consumer = ^ N, NC, P, Main {
	10	if N = 0
	11	Send Main, <Self(), NC>
	12	else
	13	Send P, <Self(), next>
	14	Msg = Recv(1000)
	15	Consumer N - 1, NC + 1, P, Main
	16	}
	17
	18	N = 100000
	19	P = Spawn(^{ Producer N, 0, Self() })
	20	C = Spawn(^{ Consumer N, 0, P, Self() })
	21
	22	NP = 0
	23	NC = 0
	24
	25	while NP = 0 & NC = 0 {
	26	Msg = Recv(1000)
	27	if Msg[1] = P { NP = Msg[2] }
	28	if Msg[1] = C { NC = Msg[2] }
	29	}
	30
	31	Print NP, " ", NC, EoL

+41

-0

eg/prodcons.bhu less more

	0	Producer = ^ N, NP, Main {
	1	if N = 0 {
	2	// Print "Producer done w/", NP, EoL
	3	Send Main, [Self(), NP]
	4	} else {
	5	Msg = Recv(1000)
	6	// Print "Producing ", NP, EoL
	7	Send Msg[1], [data, NP]
	8	Producer N - 1, NP + 1, Main
	9	}
	10	}
	11
	12	Consumer = ^ N, NC, P, Main {
	13	if N = 0 {
	14	// Print "Consumer done w/", NC, EoL
	15	Send Main, [Self(), NC]
	16	} else {
	17	// Print "Consumer wanting next", EoL
	18	Send P, [Self(), next]
	19	// Print "Consuming...", EoL
	20	Msg = Recv(1000)
	21	// Print "Consumer got ", Msg, EoL
	22	Consumer N - 1, NC + 1, P, Main
	23	}
	24	}
	25
	26	N = 100000
	27	Main = Self()
	28	P = Spawn(^{ Producer N, 0, Main })
	29	C = Spawn(^{ Consumer N, 0, P, Main })
	30
	31	NP = 0
	32	NC = 0
	33
	34	while NP = 0 \| NC = 0 {
	35	Msg = Recv(1000)
	36	if Msg[1] = P { NP = Msg[2] }
	37	if Msg[1] = C { NC = Msg[2] }
	38	}
	39
	40	Print NP, " ", NC, EoL

-0

eg/tlist.bhu less more

	0	I = 0
	1	while I < 100000 {
	2	L= [I, atom]
	3	Print L, EoL
	4	I = I + 1
	5	}

-0

eg/um.bhu less more

	0	D = 7
	1	F = 0
	2
	3	if D > 0 F = 8 else G = 9
	4
	5	Print F, EoL

-0

src/Makefile less more

4	4	( cd modules && make strip )
5	5	( cd driver && make strip )
6	6
	7	static:
	8	( cd driver && make static )
	9
7	10	.include <bsd.subdir.mk>

-0

src/Makefile.inc less more

17	17
18	18	.ifdef PROFILED
19	19	CFLAGS+=-pg
	20	.else
	21	NOPROFILE=yes
20	22	.endif
	23
	24	.ifdef STATIC
	25	STATIC=-static
	26	.else
	27	STATIC=
	28	.endif

+20

-1

src/driver/Makefile less more

4	4	all: bhuna
5	5
6	6	bhuna: main.o
7		gcc main.o -L../lib -lbhuna -o bhuna
	7	gcc $(CFLAGS) main.o $(STATIC) -L../lib -lbhuna -o bhuna
	8
	9	OBJS= ../lib/report.o \
	10	../lib/scan.o ../lib/parse.o \
	11	../lib/symbol.o ../lib/ast.o \
	12	../lib/type.o \
	13	../lib/mem.o ../lib/pool.o ../lib/gc.o \
	14	../lib/list.o ../lib/atom.o ../lib/buffer.o ../lib/closure.o ../lib/dict.o ../lib/value.o \
	15	../lib/activation.o \
	16	../lib/icode.o \
	17	../lib/gen.o ../lib/vm.o \
	18	../lib/process.o \
	19	../lib/builtin.o \
	20	../lib/trace.o \
	21	../lib/utf8.o
	22
	23	static: main.o $(OBJS)
	24	gcc $(CFLAGS) main.o $(OBJS) -o bhuna
	25	strip bhuna
	26	ls -lah bhuna
8	27
9	28	main.o: main.c
10	29	gcc $(CFLAGS) -c main.c -o main.o

+20

-23

src/driver/main.c less more

18	18	#include "process.h"
19	19	#include "icode.h"
20	20
21		#ifdef POOL_VALUES
22		#include "pool.h"
23		#endif
24
25	21	#ifdef DEBUG
26	22	#define OPTS "cdgG:ilmnopsvy"
27	23	#define RUN_PROGRAM run_program

46	42	fprintf(stderr, " -g: trace garbage collection\n");
47	43	#endif
48	44	fprintf(stderr, " -G int: set garbage collection threshold\n");
49		fprintf(stderr, " -i: create and dump intermediate format\n");
50		#ifdef DEBUG
	45	#ifdef DEBUG
	46	fprintf(stderr, " -i: dump intermediate format\n");
51	47	fprintf(stderr, " -l: trace bytecode generation (implies -x)\n");
52	48	fprintf(stderr, " -m: trace virtual machine\n");
53	49	fprintf(stderr, " -n: don't actually run program\n");

74	70	int run_program = 1;
75	71	int dump_symbols = 0;
76	72	int dump_program = 0;
77		#endif
78		int make_icode = 0;
	73	int dump_icode = 0;
	74	#endif
79	75
80	76	#ifdef DEBUG
81	77	setvbuf(stdout, NULL, _IOLBF, 0);

102	98	case 'G':
103	99	gc_trigger = atoi(optarg);
104	100	break;
	101	#ifdef DEBUG
105	102	case 'i':
106		make_icode++;
107		break;
108		#ifdef DEBUG
	103	dump_icode++;
	104	break;
109	105	case 'l':
110	106	trace_gen++;
111	107	break;

176	172
177	173	program = bhuna_malloc(16384);
178	174
179		if (make_icode > 0) {
180		ip = ast_gen_iprogram(a);
181		iprogram_eliminate_nops(ip);
182		iprogram_optimize_tail_calls(ip);
183		iprogram_optimize_push_small_ints(ip);
184		iprogram_eliminate_dead_code(ip);
185		iprogram_gen(&program, ip);
186		if (make_icode > 1)
187		iprogram_dump(ip, program);
188		} else {
189		ast_gen(&program, a);
190		}
	175	ip = ast_gen_iprogram(a);
	176	iprogram_eliminate_nops(ip);
	177	iprogram_eliminate_useless_jumps(ip);
	178	iprogram_optimize_tail_calls(ip);
	179	iprogram_optimize_push_small_ints(ip);
	180	iprogram_eliminate_dead_code(ip);
	181	iprogram_gen(&program, ip);
	182	#ifdef DEBUG
	183	if (dump_icode > 0)
	184	iprogram_dump(ip, program);
	185	#endif
191	186
192	187	vm = vm_new(program, 16384);
193	188	vm_set_pc(vm, program);

209	204	symbol_table_free(stab);
210	205	types_free();
211	206	if (trace_valloc > 0) {
	207	/*
212	208	value_dump_global_table();
	209	*/
213	210	printf("Created: %8d\n", num_vars_created);
214	211	printf("Cached: %8d\n", num_vars_cached);
215	212	printf("Freed: %8d\n", num_vars_freed);

-3

src/lib/Makefile less more

0	0	LIB= bhuna
1	1
2	2	SRCS= report.c \
3		scan.c parse.c \
	3	utf8.c scan.c parse.c \
4	4	symbol.c ast.c \
5	5	type.c \
6	6	mem.c pool.c gc.c \

15	15	NOMAN= y
16	16
17	17	# DESTDIR=/usr/local/sbin
18		strip: libbhuna.so.0
	18	strip: libbhuna.so.0 libbhuna.a
19	19	strip libbhuna.so.0
20	20	ls -lah libbhuna.so.0
21	21
22	22	SHLIB_MAJOR=0
23		NOPROFILE=yes
24	23	USELIBDIR=/usr/local/lib
25	24	USESHLIBDIR=/usr/local/lib
26	25

+16

-18

src/lib/activation.c less more

23	23	struct activation *a;
24	24
25	25	a = bhuna_malloc(sizeof(struct activation) +
26		sizeof(struct value ) size);
	26	sizeof(struct value) * size);
27	27	#ifdef BZERO
28	28	bzero(a, sizeof(struct activation) +
29		sizeof(struct value ) size);
	29	sizeof(struct value) * size);
30	30	#endif
31	31	a->size = size;
32	32	a->admin = 0;

62	62	a = activation_new_on_heap(size, caller, enclosing);
63	63	#else
64	64	a = (struct activation *)vm->astack_ptr;
65		vm->astack_ptr += sizeof(struct activation) + sizeof(struct value ) size;
	65	vm->astack_ptr += sizeof(struct activation) + sizeof(struct value) * size;
66	66	if (vm->astack_ptr > vm->astack_hi)
67	67	vm->astack_hi = vm->astack_ptr;
68	68

113	113	#endif
114	114
115	115	vm->astack_ptr -= (sizeof(struct activation) +
116		sizeof(struct value ) a->size);
117		#endif
118		}
119
120		struct value *
	116	sizeof(struct value) * a->size);
	117	#endif
	118	}
	119
	120	struct value
121	121	activation_get_value(struct activation *a, int index, int upcount)
122	122	{
123	123	assert(a != NULL);

128	128	#ifdef DEBUG
129	129	assert(index < a->size);
130	130	#endif
131		return(((struct value *)((char )a + sizeof(struct activation)))[index]);
	131	return(VALARY(a, index));
132	132	}
133	133
134	134	void
135	135	activation_set_value(struct activation *a, int index, int upcount,
136		struct value *v)
137		{
138		struct value *d;
139
	136	struct value v)
	137	{
140	138	assert(a != NULL);
141	139	for (; upcount > 0; upcount--) {
142	140	a = a->enclosing;

151	149	*/
152	150	assert(index < a->size);
153	151	#endif
	152	/*
154	153	v->refcount++;
155		d = VALARY(a, index);
156		if (d != NULL)
157		d->refcount--;
	154	VALARY(a, index)->refcount--;
	155	*/
158	156	VALARY(a, index) = v;
159	157	}
160	158
161	159	void
162	160	activation_initialize_value(struct activation *a, int index,
163		struct value *v)
	161	struct value v)
164	162	{
165	163	assert(a != NULL);
166	164	assert(index < a->size);

183	181	if (detail > 0) {
184	182	for (i = 0; i < a->size; i++) {
185	183	printf(" ");
186		if (VALARY(a, i) != NULL && VALARY(a, i)->type == VALUE_CLOSURE) {
	184	if (VALARY(a, i).type == VALUE_CLOSURE) {
187	185	printf("(closure) ");
188	186	} else {
189	187	value_print(VALARY(a, i));

-6

src/lib/activation.h less more

0		struct value;
	0	#include "value.h"
	1
1	2	struct vm;
2	3
3	4	#define AR_ADMIN_MARKED 1

16	17	struct activation caller; / recursively shallower activation record */
17	18	struct activation enclosing; / lexically enclosing activation record */
18	19	/*
19		struct value *value[];
	20	struct value value[];
20	21	*/
21	22	};
22	23
23	24	#define VALARY(a,i) \
24		((struct value *)((char )a + sizeof(struct activation)))[i]
	25	((struct value )((unsigned char )a + sizeof(struct activation)))[i]
25	26
26	27	struct activation activation_new_on_heap(int, struct activation , struct activation *);
27	28	struct activation activation_new_on_stack(int, struct activation , struct activation , struct vm );
28	29	void activation_free_from_heap(struct activation *);
29	30	void activation_free_from_stack(struct activation , struct vm );
30	31
31		struct value activation_get_value(struct activation , int, int);
32		void activation_set_value(struct activation , int, int, struct value );
33		void activation_initialize_value(struct activation , int, struct value );
	32	struct value activation_get_value(struct activation *, int, int);
	33	void activation_set_value(struct activation *, int, int, struct value);
	34	void activation_initialize_value(struct activation *, int, struct value);
34	35
35	36	void activation_dump(struct activation *, int);

+43

-17

src/lib/ast.c less more

0	0	#include <stdio.h>
1	1	#include <stdlib.h>
2	2	#include <string.h>
3
	3
4	4	#include "ast.h"
5	5	#include "list.h"
6	6	#include "value.h"

9	9	#include "vm.h"
10	10	#include "type.h"
11	11	#include "scan.h"
	12	#include "utf8.h"
12	13
13	14	#include "symbol.h"
14	15	#include "report.h"

55	56	}
56	57
57	58	struct ast *
58		ast_new_value(struct value v, struct type t)
	59	ast_new_value(struct value v, struct type *t)
59	60	{
60	61	struct ast *a;
61	62

79	80	ast_new_builtin(struct scan_st sc, struct builtin bi, struct ast *right)
80	81	{
81	82	struct ast *a;
82		struct type *t;
	83	struct type t, tr;
83	84	int unify = 0;
84	85
85	86	t = bi->ty();

87	88
88	89	#ifdef DEBUG
89	90	if (trace_type_inference) {
90		printf("(builtin `%s`)*****\n", bi->name);
	91	printf("(builtin `");
	92	fputsu8(stdout, bi->name);
	93	printf("`)*****\n");
91	94	printf("type of args is: ");
92		type_print(stdout, right->datatype);
	95	if (right != NULL)
	96	type_print(stdout, right->datatype);
93	97	printf("\ntype of builtin is: ");
94	98	type_print(stdout, t);
95	99	}
96	100	#endif
97	101
	102	if (right == NULL)
	103	tr = type_new(TYPE_VOID);
	104	else
	105	tr = right->datatype;
	106
98	107	unify = type_unify_crit(sc,
99		type_representative(t)->t.closure.domain,
100		right->datatype);
	108	type_representative(t)->t.closure.domain, tr);
101	109
102	110	#ifdef DEBUG
103	111	if (trace_type_inference) {

110	118	* Fold constants.
111	119	*/
112	120	if (bi->is_pure && ast_is_constant(right)) {
113		struct value *v = NULL;
	121	struct value v;
114	122	struct activation *ar;
115	123	struct ast *g;
116	124	int i = 0;

131	139	activation_initialize_value(ar, i,
132	140	g->u.arg.left->u.value.value);
133	141	}
134		bi->fn(ar, &v);
	142	v = bi->fn(ar);
135	143	} else {
136	144	a = NULL;
137	145	}

199	207	ast_new_arg(struct ast left, struct ast right)
200	208	{
201	209	struct ast *a;
	210
	211	if (left == NULL)
	212	return(NULL);
202	213
203	214	a = ast_new(AST_ARG);
204	215	a->u.arg.left = left;

221	232	a = ast_new(AST_ROUTINE);
222	233	a->u.routine.body = body;
223	234
224		a->datatype = a->u.routine.body->datatype;
	235	if (a->u.routine.body != NULL)
	236	a->datatype = a->u.routine.body->datatype;
	237	else
	238	a->datatype = type_new(TYPE_VOID);
225	239
226	240	#ifdef DEBUG
227	241	if (trace_type_inference) {

271	285	}
272	286
273	287	struct ast *
274		ast_new_assignment(struct scan_st sc, struct ast left, struct ast *right)
	288	ast_new_assignment(struct scan_st sc, struct ast left, struct ast *right,
	289	int defining)
275	290	{
276	291	struct ast *a;
277	292	int unify;

286	301	a = ast_new(AST_ASSIGNMENT);
287	302	a->u.assignment.left = left;
288	303	a->u.assignment.right = right;
	304	a->u.assignment.defining = defining;
289	305
290	306	unify = type_unify_crit(sc, left->datatype, right->datatype);
291	307

312	328	{
313	329	struct ast *a;
314	330	int unify;
	331	struct type *t;
315	332
316	333	a = ast_new(AST_CONDITIONAL);
317	334	a->u.conditional.test = test;

327	344	printf("(if)*****\n");
328	345	printf("type of YES is: ");
329	346	type_print(stdout, yes->datatype);
330		printf("\ntype of NO is: ");
331		type_print(stdout, no->datatype);
	347	if (no != NULL) {
	348	printf("\ntype of NO is: ");
	349	type_print(stdout, no->datatype);
	350	}
332	351	}
333	352	#endif
334	353

338	357	/* actually, either of these can be VOID, in which case, pick the other */
339	358	/* unify = type_unify_crit(sc, yes->datatype, no->datatype); */
340	359	/* haha */
341		a->datatype = type_new_set(a->u.conditional.yes->datatype,
342		a->u.conditional.no->datatype);
	360	if (no == NULL) {
	361	t = type_new(TYPE_VOID);
	362	} else {
	363	t = a->u.conditional.no->datatype;
	364	}
	365	a->datatype = type_new_set(a->u.conditional.yes->datatype, t);
343	366
344	367	#ifdef DEBUG
345	368	if (trace_type_inference) {

562	585	printf(")\n");
563	586	break;
564	587	case AST_BUILTIN:
565		printf("`%s`{\n", a->u.builtin.bi->name);
	588	printf("`");
	589	fputsu8(stdout, a->u.builtin.bi->name);
	590	printf("`{\n");
566	591	ast_dump(a->u.builtin.right, indent + 1);
567	592	for (i = 0; i < indent; i++) printf(" "); printf("}\n");
568	593	break;

590	615	for (i = 0; i < indent; i++) printf(" "); printf("}\n");
591	616	break;
592	617	case AST_ASSIGNMENT:
593		printf("{\n");
	618	printf("(%s){\n", a->u.assignment.defining ?
	619	"definition" : "application");
594	620	ast_dump(a->u.assignment.left, indent + 1);
595	621	ast_dump(a->u.assignment.right, indent + 1);
596	622	for (i = 0; i < indent; i++) printf(" "); printf("}\n");

-7

src/lib/ast.h less more

1	1	#define __AST_H_
2	2
3	3	#include "vm.h"
	4	#include "value.h"
4	5
5		struct value;
6	6	struct builtin;
7	7	struct type;
8	8	struct symbol;

16	16	};
17	17
18	18	struct ast_value {
19		struct value *value;
	19	struct value value;
20	20	};
21	21
22	22	struct ast_builtin {

47	47	struct ast_assignment {
48	48	struct ast left; / ISA var */
49	49	struct ast right; / ISA apply/var */
	50	int defining;
50	51	};
51	52
52	53	struct ast_conditional {

100	101	};
101	102
102	103	struct ast ast_new_local(struct symbol_table , struct symbol *);
103		struct ast ast_new_value(struct value , struct type *);
	104	struct ast ast_new_value(struct value, struct type );
104	105	struct ast ast_new_builtin(struct scan_st , struct builtin , struct ast );
105	106	struct ast ast_new_apply(struct scan_st , struct ast , struct ast , int);
106	107	struct ast ast_new_arg(struct ast , struct ast *);
107	108	struct ast ast_new_routine(struct ast );
108	109	struct ast ast_new_statement(struct ast , struct ast *);
109		struct ast ast_new_assignment(struct scan_st , struct ast , struct ast );
	110	struct ast ast_new_assignment(struct scan_st , struct ast , struct ast , int);
110	111	struct ast ast_new_conditional(struct scan_st , struct ast , struct ast , struct ast *);
111	112	struct ast ast_new_while_loop(struct scan_st , struct ast , struct ast );
112	113	struct ast ast_new_retr(struct ast );

119	120	void ast_dump(struct ast *, int);
120	121	char ast_name(struct ast );
121	122
122		void ast_eval_init(void);
123		void ast_eval(struct ast , struct value *);
124
125	123	#endif /* !__AST_H_ */

-3

src/lib/atom.c less more

0	0	#include <string.h>
1	1	#include <stdlib.h>
	2	#include <wchar.h>
2	3
3	4	#include "mem.h"
4	5	#include "atom.h"

7	8	static int next_atom = 0;
8	9
9	10	int
10		atom_resolve(char *lexeme)
	11	atom_resolve(wchar_t *lexeme)
11	12	{
12	13	struct atom_entry *ae;
13	14
14	15	/* find lexeme in atom table */
15	16	for (ae = atom_entry_head; ae != NULL; ae = ae->next) {
16		if (strcmp(ae->lexeme, lexeme) == 0)
	17	if (wcscmp(ae->lexeme, lexeme) == 0)
17	18	return(ae->atom);
18	19	}
19	20	/* create new atom */
20	21	ae = bhuna_malloc(sizeof(struct atom_entry));
21	22	ae->next = atom_entry_head;
22		ae->lexeme = strdup(lexeme);
	23	ae->lexeme = bhuna_wcsdup(lexeme);
23	24	ae->atom = next_atom++;
24	25	atom_entry_head = ae;
25	26

-2

src/lib/atom.h less more

5	5	#ifndef __ATOM_H_
6	6	#define __ATOM_H_
7	7
	8	#include <wchar.h>
	9
8	10	struct atom_entry {
9	11	struct atom_entry *next;
10		char *lexeme;
	12	wchar_t *lexeme;
11	13	int atom;
12	14	};
13	15
14		int atom_resolve(char *);
	16	int atom_resolve(wchar_t *);
15	17
16	18	#endif /* !__ATOM_H_ */

+387

-292

src/lib/builtin.c less more

0	0	#include <stdio.h>
1	1	#include <stdlib.h>
	2	#include <wchar.h>
2	3
3	4	#include <dlfcn.h>
4	5

10	11	#include "activation.h"
11	12	#include "type.h"
12	13	#include "symbol.h"
	14	#include "utf8.h"
13	15
14	16	#include "ast.h"
15	17	#include "vm.h"

20	22	*/
21	23
22	24	struct builtin builtins[] = {
23		{"Print", builtin_print, btype_print, -1, 0, 1, 0},
24		{"!", builtin_not, btype_unary_logic, 1, 1, 1, 1},
25		{"&", builtin_and, btype_binary_logic, 2, 1, 1, 2},
26		{"\|", builtin_or, btype_binary_logic, 2, 1, 1, 3},
27		{"=", builtin_equ, btype_compare, 2, 1, 1, 4},
28		{"!=", builtin_neq, btype_compare, 2, 1, 1, 5},
29		{">", builtin_gt, btype_compare, 2, 1, 1, 6},
30		{"<", builtin_lt, btype_compare, 2, 1, 1, 7},
31		{">=", builtin_gte, btype_compare, 2, 1, 1, 8},
32		{"<=", builtin_lte, btype_compare, 2, 1, 1, 9},
33		{"+", builtin_add, btype_arith, 2, 1, 1, 10},
34		{"-", builtin_sub, btype_arith, 2, 1, 1, 11},
35		{"*", builtin_mul, btype_arith, 2, 1, 1, 12},
36		{"/", builtin_div, btype_arith, 2, 1, 1, 13},
37		{"%", builtin_mod, btype_arith, 2, 1, 1, 14},
38		{"List", builtin_list, btype_list, -1, 1, 1, 15},
39		{"Fetch", builtin_fetch, btype_fetch, 2, 1, 1, 16},
40		{"Store", builtin_store, btype_store, 3, 0, 1, 17},
41		{"Dict", builtin_dict, btype_dict, -1, 1, 1, 18},
42		{"Spawn", builtin_spawn, btype_spawn, 1, 0, 1, 19},
43		{NULL, NULL, NULL, 0, 0, 0, 0}
	25	{L"Print", builtin_print, btype_print, -1, 0, 0, 1, 0},
	26	{L"!", builtin_not, btype_unary_logic, 1, 1, 1, 1, 1},
	27	{L"&", builtin_and, btype_binary_logic, 2, 1, 1, 1, 2},
	28	{L"\|", builtin_or, btype_binary_logic, 2, 1, 1, 1, 3},
	29	{L"=", builtin_equ, btype_equality, 2, 1, 1, 1, 4},
	30	{L"!=", builtin_neq, btype_equality, 2, 1, 1, 1, 5},
	31	{L">", builtin_gt, btype_compare, 2, 1, 1, 1, 6},
	32	{L"<", builtin_lt, btype_compare, 2, 1, 1, 1, 7},
	33	{L">=", builtin_gte, btype_compare, 2, 1, 1, 1, 8},
	34	{L"<=", builtin_lte, btype_compare, 2, 1, 1, 1, 9},
	35	{L"+", builtin_add, btype_arith, 2, 1, 1, 1, 10},
	36	{L"-", builtin_sub, btype_arith, 2, 1, 1, 1, 11},
	37	{L"*", builtin_mul, btype_arith, 2, 1, 1, 1, 12},
	38	{L"/", builtin_div, btype_arith, 2, 1, 1, 1, 13},
	39	{L"%", builtin_mod, btype_arith, 2, 1, 1, 1, 14},
	40	{L"List", builtin_list, btype_list, -1, 1, 1, 1, 15},
	41	{L"Fetch", builtin_fetch, btype_fetch, 2, 1, 1, 1, 16},
	42	{L"Store", builtin_store, btype_store, 3, 0, 0, 1, 17},
	43	{L"Dict", builtin_dict, btype_dict, -1, 1, 1, 1, 18},
	44	{L"Spawn", builtin_spawn, btype_spawn, 1, 1, 0, 1, 19},
	45	{L"Send", builtin_send, btype_send, 2, 0, 0, 1, 20},
	46	{L"Recv", builtin_recv, btype_recv, 1, 1, 0, 1, 21},
	47	{L"Self", builtin_self, btype_self, 0, 1, 0, 1, 22},
	48	{NULL, NULL, NULL, 0, 0, 0, 0, 0}
44	49	};
45	50
46		void
47		builtin_print(struct activation ar, struct value *q)
	51	struct value
	52	builtin_print(struct activation *ar)
48	53	{
49	54	int i;
50		/struct list l;*/
51		struct value *v = NULL;
	55	struct value v;
52	56
53	57	for (i = 0; i < ar->size; i++) {
54	58	v = activation_get_value(ar, i, 0);
55		if (v == NULL) {
56		printf("(null)");
57		continue;
58		}
59
60		switch (v->type) {
	59
	60	switch (v.type) {
61	61	case VALUE_INTEGER:
62		printf("%d", v->v.i);
	62	printf("%d", v.v.i);
63	63	break;
64	64	case VALUE_BOOLEAN:
65		printf("%s", v->v.b ? "true" : "false");
	65	printf("%s", v.v.b ? "true" : "false");
66	66	break;
67	67	case VALUE_STRING:
68		printf("%s", v->v.s);
	68	fputsu8(stdout, v.v.s->v.s);
69	69	break;
70	70	case VALUE_LIST:
71	71	/*

73	73	for (l = v->v.l; l != NULL; l = l->next) {
74	74	*/
75	75
76		list_dump(v->v.l);
	76	list_dump(v.v.s->v.l);
77	77	break;
78	78	case VALUE_ERROR:
79		printf("#ERR<%s>", v->v.e);
	79	printf("#ERR<%s>", v.v.s->v.e);
80	80	break;
81	81	case VALUE_BUILTIN:
82		printf("#BIF<%08lx>", (unsigned long)v->v.bi);
	82	printf("#BIF<%08lx>", (unsigned long)v.v.bi);
83	83	break;
84	84	case VALUE_CLOSURE:
85		closure_dump(v->v.k);
	85	closure_dump(v.v.s->v.k);
86	86	break;
87	87	case VALUE_DICT:
88		dict_dump(v->v.d);
	88	dict_dump(v.v.s->v.d);
	89	break;
	90	case VALUE_OPAQUE:
	91	printf("#OPAQUE<%08lx>", (unsigned long)v.v.ptr);
89	92	break;
90	93	default:
91		printf("???unknown(%d)???", v->type);
	94	printf("???unknown(%d)???", v.type);
92	95	break;
93	96	}
94	97	}
95
96		*q = v;
	98	return(value_null());
97	99	}
98	100
99	101	/* logical */
100	102
101		void
102		builtin_not(struct activation ar, struct value *v)
103		{
104		struct value *q = activation_get_value(ar, 0, 0);
105
106		if (q->type == VALUE_BOOLEAN) {
107		*v = value_new_boolean(!q->v.b);
108		} else {
109		*v = value_new_error("type mismatch");
110		}
111		}
112
113		void
114		builtin_and(struct activation ar, struct value *v)
115		{
116		struct value *l = activation_get_value(ar, 0, 0);
117		struct value *r = activation_get_value(ar, 1, 0);
118
119		if (l->type == VALUE_BOOLEAN && r->type == VALUE_BOOLEAN) {
120		value_new_boolean(l->v.b && r->v.b);
121		} else {
122		*v = value_new_error("type mismatch");
123		}
124		}
125
126		void
127		builtin_or(struct activation ar, struct value *v)
128		{
129		struct value *l = activation_get_value(ar, 0, 0);
130		struct value *r = activation_get_value(ar, 1, 0);
131
132		if (l->type == VALUE_BOOLEAN && r->type == VALUE_BOOLEAN) {
133		*v = value_new_boolean(l->v.b \|\| r->v.b);
134		} else {
135		*v = value_new_error("type mismatch");
	103	struct value
	104	builtin_not(struct activation *ar)
	105	{
	106	struct value q = activation_get_value(ar, 0, 0);
	107
	108	if (q.type == VALUE_BOOLEAN) {
	109	return(value_new_boolean(!q.v.b));
	110	} else {
	111	return(value_new_error("type mismatch"));
	112	}
	113	}
	114
	115	struct value
	116	builtin_and(struct activation *ar)
	117	{
	118	struct value l = activation_get_value(ar, 0, 0);
	119	struct value r = activation_get_value(ar, 1, 0);
	120
	121	if (l.type == VALUE_BOOLEAN && r.type == VALUE_BOOLEAN) {
	122	return(value_new_boolean(l.v.b && r.v.b));
	123	} else {
	124	return(value_new_error("type mismatch"));
	125	}
	126	}
	127
	128	struct value
	129	builtin_or(struct activation *ar)
	130	{
	131	struct value l = activation_get_value(ar, 0, 0);
	132	struct value r = activation_get_value(ar, 1, 0);
	133
	134	if (l.type == VALUE_BOOLEAN && r.type == VALUE_BOOLEAN) {
	135	return(value_new_boolean(l.v.b \|\| r.v.b));
	136	} else {
	137	return(value_new_error("type mismatch"));
136	138	}
137	139	}
138	140
139	141	/* comparison */
140	142
141		void
142		builtin_equ(struct activation ar, struct value *v)
143		{
144		struct value *l = activation_get_value(ar, 0, 0);
145		struct value *r = activation_get_value(ar, 1, 0);
146
147		if (l->type == VALUE_INTEGER && r->type == VALUE_INTEGER) {
148		*v = value_new_boolean(l->v.i == r->v.i);
149		} else {
150		*v = value_new_error("type mismatch");
151		}
152		}
153
154		void
155		builtin_neq(struct activation ar, struct value *v)
156		{
157		struct value *l = activation_get_value(ar, 0, 0);
158		struct value *r = activation_get_value(ar, 1, 0);
159
160		if (l->type == VALUE_INTEGER && r->type == VALUE_INTEGER) {
161		*v = value_new_boolean(l->v.i != r->v.i);
162		} else {
163		*v = value_new_error("type mismatch");
164		}
165		}
166
167		void
168		builtin_gt(struct activation ar, struct value *v)
169		{
170		struct value *l = activation_get_value(ar, 0, 0);
171		struct value *r = activation_get_value(ar, 1, 0);
172
173		if (l->type == VALUE_INTEGER && r->type == VALUE_INTEGER) {
174		*v = value_new_boolean(l->v.i > r->v.i);
175		} else {
176		*v = value_new_error("type mismatch");
177		}
178		}
179
180		void
181		builtin_lt(struct activation ar, struct value *v)
182		{
183		struct value *l = activation_get_value(ar, 0, 0);
184		struct value *r = activation_get_value(ar, 1, 0);
185
186		if (l->type == VALUE_INTEGER && r->type == VALUE_INTEGER) {
187		*v = value_new_boolean(l->v.i < r->v.i);
188		} else {
189		*v = value_new_error("type mismatch");
190		}
191		}
192
193		void
194		builtin_gte(struct activation ar, struct value *v)
195		{
196		struct value *l = activation_get_value(ar, 0, 0);
197		struct value *r = activation_get_value(ar, 1, 0);
198
199		if (l->type == VALUE_INTEGER && r->type == VALUE_INTEGER) {
200		*v = value_new_boolean(l->v.i >= r->v.i);
201		} else {
202		*v = value_new_error("type mismatch");
203		}
204		}
205
206		void
207		builtin_lte(struct activation ar, struct value *v)
208		{
209		struct value *l = activation_get_value(ar, 0, 0);
210		struct value *r = activation_get_value(ar, 1, 0);
211
212		if (l->type == VALUE_INTEGER && r->type == VALUE_INTEGER) {
213		*v = value_new_boolean(l->v.i <= r->v.i);
214		} else {
215		*v = value_new_error("type mismatch");
	143	struct value
	144	builtin_equ(struct activation *ar)
	145	{
	146	struct value l = activation_get_value(ar, 0, 0);
	147	struct value r = activation_get_value(ar, 1, 0);
	148
	149	if (l.type == VALUE_INTEGER && r.type == VALUE_INTEGER) {
	150	return value_new_boolean(l.v.i == r.v.i);
	151	} else if (l.type == VALUE_OPAQUE && r.type == VALUE_OPAQUE) {
	152	return value_new_boolean(l.v.ptr == r.v.ptr);
	153	} else {
	154	return value_new_error("type mismatch");
	155	}
	156	}
	157
	158	struct value
	159	builtin_neq(struct activation *ar)
	160	{
	161	struct value l = activation_get_value(ar, 0, 0);
	162	struct value r = activation_get_value(ar, 1, 0);
	163
	164	if (l.type == VALUE_INTEGER && r.type == VALUE_INTEGER) {
	165	return value_new_boolean(l.v.i != r.v.i);
	166	} else {
	167	return value_new_error("type mismatch");
	168	}
	169	}
	170
	171	struct value
	172	builtin_gt(struct activation *ar)
	173	{
	174	struct value l = activation_get_value(ar, 0, 0);
	175	struct value r = activation_get_value(ar, 1, 0);
	176
	177	if (l.type == VALUE_INTEGER && r.type == VALUE_INTEGER) {
	178	return value_new_boolean(l.v.i > r.v.i);
	179	} else {
	180	return value_new_error("type mismatch");
	181	}
	182	}
	183
	184	struct value
	185	builtin_lt(struct activation *ar)
	186	{
	187	struct value l = activation_get_value(ar, 0, 0);
	188	struct value r = activation_get_value(ar, 1, 0);
	189
	190	if (l.type == VALUE_INTEGER && r.type == VALUE_INTEGER) {
	191	return value_new_boolean(l.v.i < r.v.i);
	192	} else {
	193	return value_new_error("type mismatch");
	194	}
	195	}
	196
	197	struct value
	198	builtin_gte(struct activation *ar)
	199	{
	200	struct value l = activation_get_value(ar, 0, 0);
	201	struct value r = activation_get_value(ar, 1, 0);
	202
	203	if (l.type == VALUE_INTEGER && r.type == VALUE_INTEGER) {
	204	return value_new_boolean(l.v.i >= r.v.i);
	205	} else {
	206	return value_new_error("type mismatch");
	207	}
	208	}
	209
	210	struct value
	211	builtin_lte(struct activation *ar)
	212	{
	213	struct value l = activation_get_value(ar, 0, 0);
	214	struct value r = activation_get_value(ar, 1, 0);
	215
	216	if (l.type == VALUE_INTEGER && r.type == VALUE_INTEGER) {
	217	return value_new_boolean(l.v.i <= r.v.i);
	218	} else {
	219	return value_new_error("type mismatch");
216	220	}
217	221	}
218	222
219	223	/* arithmetic */
220	224
221		void
222		builtin_add(struct activation ar, struct value *v)
223		{
224		struct value *l = activation_get_value(ar, 0, 0);
225		struct value *r = activation_get_value(ar, 1, 0);
226
227		if (l->type == VALUE_INTEGER && r->type == VALUE_INTEGER) {
228		*v = value_new_integer(l->v.i + r->v.i);
229		} else {
230		*v = value_new_error("type mismatch");
231		}
232		}
233
234		void
235		builtin_mul(struct activation ar, struct value *v)
236		{
237		struct value *l = activation_get_value(ar, 0, 0);
238		struct value *r = activation_get_value(ar, 1, 0);
	225	struct value
	226	builtin_add(struct activation *ar)
	227	{
	228	struct value l = activation_get_value(ar, 0, 0);
	229	struct value r = activation_get_value(ar, 1, 0);
	230
	231	if (l.type == VALUE_INTEGER && r.type == VALUE_INTEGER) {
	232	return value_new_integer(l.v.i + r.v.i);
	233	} else {
	234	return value_new_error("type mismatch");
	235	}
	236	}
	237
	238	struct value
	239	builtin_mul(struct activation *ar)
	240	{
	241	struct value l = activation_get_value(ar, 0, 0);
	242	struct value r = activation_get_value(ar, 1, 0);
239	243
240	244	#if 0
241	245	printf("IN MUL, L = ");

245	249	printf("\n");
246	250	#endif
247	251
248		if (l->type == VALUE_INTEGER && r->type == VALUE_INTEGER) {
249		v = value_new_integer(l->v.i r->v.i);
250		} else {
251		*v = value_new_error("type mismatch");
252		}
253		}
254
255		void
256		builtin_sub(struct activation ar, struct value *v)
257		{
258		struct value *l = activation_get_value(ar, 0, 0);
259		struct value *r = activation_get_value(ar, 1, 0);
260
261		if (l->type == VALUE_INTEGER && r->type == VALUE_INTEGER) {
262		*v = value_new_integer(l->v.i - r->v.i);
263		} else {
264		*v = value_new_error("type mismatch");
265		}
266		}
267
268		void
269		builtin_div(struct activation ar, struct value *v)
270		{
271		struct value *l = activation_get_value(ar, 0, 0);
272		struct value *r = activation_get_value(ar, 1, 0);
273
274		if (l->type == VALUE_INTEGER && r->type == VALUE_INTEGER) {
275		if (r->v.i == 0)
276		*v = value_new_error("division by zero");
	252	if (l.type == VALUE_INTEGER && r.type == VALUE_INTEGER) {
	253	return value_new_integer(l.v.i * r.v.i);
	254	} else {
	255	return value_new_error("type mismatch");
	256	}
	257	}
	258
	259	struct value
	260	builtin_sub(struct activation *ar)
	261	{
	262	struct value l = activation_get_value(ar, 0, 0);
	263	struct value r = activation_get_value(ar, 1, 0);
	264
	265	if (l.type == VALUE_INTEGER && r.type == VALUE_INTEGER) {
	266	return value_new_integer(l.v.i - r.v.i);
	267	} else {
	268	return value_new_error("type mismatch");
	269	}
	270	}
	271
	272	struct value
	273	builtin_div(struct activation *ar)
	274	{
	275	struct value l = activation_get_value(ar, 0, 0);
	276	struct value r = activation_get_value(ar, 1, 0);
	277
	278	if (l.type == VALUE_INTEGER && r.type == VALUE_INTEGER) {
	279	if (r.v.i == 0)
	280	return value_new_error("division by zero");
277	281	else
278		*v = value_new_integer(l->v.i / r->v.i);
279		} else {
280		*v = value_new_error("type mismatch");
281		}
282		}
283
284		void
285		builtin_mod(struct activation ar, struct value *v)
286		{
287		struct value *l = activation_get_value(ar, 0, 0);
288		struct value *r = activation_get_value(ar, 1, 0);
289
290		if (l->type == VALUE_INTEGER && r->type == VALUE_INTEGER) {
291		if (r->v.i == 0)
292		*v = value_new_error("modulo by zero");
	282	return value_new_integer(l.v.i / r.v.i);
	283	} else {
	284	return value_new_error("type mismatch");
	285	}
	286	}
	287
	288	struct value
	289	builtin_mod(struct activation *ar)
	290	{
	291	struct value l = activation_get_value(ar, 0, 0);
	292	struct value r = activation_get_value(ar, 1, 0);
	293
	294	if (l.type == VALUE_INTEGER && r.type == VALUE_INTEGER) {
	295	if (r.v.i == 0)
	296	return value_new_error("modulo by zero");
293	297	else
294		*v = value_new_integer(l->v.i % r->v.i);
295		} else {
296		*v = value_new_error("type mismatch");
	298	return value_new_integer(l.v.i % r.v.i);
	299	} else {
	300	return value_new_error("type mismatch");
297	301	}
298	302	}
299	303
300	304	/* list */
301	305
302		void
303		builtin_list(struct activation ar, struct value *v)
	306	struct value
	307	builtin_list(struct activation *ar)
304	308	{
305	309	int i;
306		struct value *x = NULL;
307
308		*v = value_new_list();
	310	struct value v, x;
	311
	312	v = value_new_list();
309	313
310	314	for (i = ar->size - 1; i >= 0; i--) {
311	315	x = activation_get_value(ar, i, 0);
312	316	value_list_append(v, x);
313	317	}
314		}
315
316		void
317		builtin_fetch(struct activation ar, struct value *v)
318		{
319		struct value *l = activation_get_value(ar, 0, 0);
320		struct value *r = activation_get_value(ar, 1, 0);
321		struct value *q;
	318
	319	return(v);
	320	}
	321
	322	struct value
	323	builtin_fetch(struct activation *ar)
	324	{
	325	struct value l = activation_get_value(ar, 0, 0);
	326	struct value r = activation_get_value(ar, 1, 0);
322	327	int count;
323	328	struct list *li;
324	329
325		if (l->type == VALUE_CLOSURE && r->type == VALUE_INTEGER) {
326		int i = r->v.i - 1;
	330	if (l.type == VALUE_CLOSURE && r.type == VALUE_INTEGER) {
	331	int i = r.v.i - 1;
327	332	/*
328	333	* This is _EVIL_!
329	334	*/
330		if (i >= 0 && i < l->v.k->ar->size) {
331		q = activation_get_value(l->v.k->ar, i, 0);
332		*v = q;
	335	if (i >= 0 && i < l.v.s->v.k->ar->size) {
	336	return(activation_get_value(l.v.s->v.k->ar, i, 0));
333	337	} else {
334		*v = value_new_error("out of bounds");
	338	return(value_new_error("out of bounds"));
335	339	}
336		} else if (l->type == VALUE_DICT) {
337		q = dict_fetch(l->v.d, r);
338		*v = q;
339		} else if (l->type == VALUE_LIST && r->type == VALUE_INTEGER) {
340		li = l->v.l;
341		for (count = 1; li != NULL && count < r->v.i; count++)
	340	} else if (l.type == VALUE_DICT) {
	341	return(dict_fetch(l.v.s->v.d, r));
	342	} else if (l.type == VALUE_LIST && r.type == VALUE_INTEGER) {
	343	li = l.v.s->v.l;
	344	for (count = 1; li != NULL && count < r.v.i; count++)
342	345	li = li->next;
343	346	if (li == NULL)
344		*v = value_new_error("out of bounds");
	347	return value_new_error("out of bounds");
345	348	else {
346		*v = li->value;
	349	return li->value;
347	350	}
348	351	} else {
349		*v = value_new_error("type mismatch");
350		}
351		}
352
353		void
354		builtin_store(struct activation ar, struct value *v)
355		{
356		struct value *d = activation_get_value(ar, 0, 0);
357		struct value *i = activation_get_value(ar, 1, 0);
358		struct value *p = activation_get_value(ar, 2, 0);
	352	return value_new_error("type mismatch");
	353	}
	354	}
	355
	356	struct value
	357	builtin_store(struct activation *ar)
	358	{
	359	struct value d = activation_get_value(ar, 0, 0);
	360	struct value i = activation_get_value(ar, 1, 0);
	361	struct value p = activation_get_value(ar, 2, 0);
359	362	int count;
360	363	struct list *li;
361	364
362		if (d->type == VALUE_DICT) {
363		dict_store(d->v.d, i, p);
364		*v = d;
365		} else if (d->type == VALUE_LIST && i->type == VALUE_INTEGER) {
366		li = d->v.l;
367		for (count = 1; li != NULL && count < i->v.i; count++)
	365	if (d.type == VALUE_DICT) {
	366	dict_store(d.v.s->v.d, i, p);
	367	return(d);
	368	} else if (d.type == VALUE_LIST && i.type == VALUE_INTEGER) {
	369	li = d.v.s->v.l;
	370	for (count = 1; li != NULL && count < i.v.i; count++)
368	371	li = li->next;
369	372	if (li == NULL)
370		*v = value_new_error("no such element");
	373	return(value_new_error("no such element"));
371	374	else {
372	375	li->value = p;
373		*v = d;
	376	return(d);
374	377	}
375	378	} else {
376		*v = value_new_error("type mismatch");
377		}
378		}
379
380		void
381		builtin_dict(struct activation ar, struct value *v)
	379	return(value_new_error("type mismatch"));
	380	}
	381	}
	382
	383	struct value
	384	builtin_dict(struct activation *ar)
382	385	{
383	386	int i;
384		struct value key = NULL, val = NULL;
385
386		*v = value_new_dict();
	387	struct value key, val, v;
	388
	389	v = value_new_dict();
387	390
388	391	if (ar->size % 2 != 0) {
389		*v = value_new_error("number of argument must be even");
	392	return(value_new_error("number of arguments must be even"));
390	393	} else {
391	394	for (i = 0; i < ar->size; i += 2) {
392	395	key = activation_get_value(ar, i, 0);

394	397	value_dict_store(v, key, val);
395	398	}
396	399	}
	400
	401	return(v);
397	402	}
398	403
399	404	/* multiprocessing */
400	405
401		void
402		builtin_spawn(struct activation ar, struct value *v)
403		{
404		struct value *q = activation_get_value(ar, 0, 0);
405
406		if (q->type == VALUE_CLOSURE) {
407		(void)process_spawn(q->v.k);
408		*v = value_new_boolean(1);
409		} else {
410		*v = value_new_error("type mismatch");
411		}
	406	struct value
	407	builtin_spawn(struct activation *ar)
	408	{
	409	struct value q = activation_get_value(ar, 0, 0);
	410	struct process *p;
	411
	412	if (q.type == VALUE_CLOSURE) {
	413	p = process_spawn(q.v.s->v.k);
	414	return value_new_opaque(p);
	415	} else {
	416	return value_new_error("type mismatch");
	417	}
	418	}
	419
	420	struct value
	421	builtin_send(struct activation *ar)
	422	{
	423	struct value pv = activation_get_value(ar, 0, 0);
	424	struct value mv = activation_get_value(ar, 1, 0);
	425	struct process *p;
	426
	427	if (pv.type == VALUE_OPAQUE) {
	428	p = (struct process *)pv.v.ptr;
	429	process_send(p, mv);
	430	return value_null();
	431	} else {
	432	return value_new_error("type mismatch");
	433	}
	434	}
	435
	436	/*
	437	* This can't really be done here - it should be done in the vm.
	438	*/
	439	struct value
	440	builtin_recv(struct activation *ar)
	441	{
	442	struct value tv = activation_get_value(ar, 0, 0);
	443	struct value rv = value_null();
	444
	445	if (tv.type == VALUE_INTEGER) {
	446	process_recv(&rv);
	447	return(rv);
	448	} else {
	449	return value_new_error("type mismatch");
	450	}
	451	}
	452
	453	/*
	454	* This can't really be done here - it should be done in the vm.
	455	*/
	456	struct value
	457	builtin_self(struct activation *ar)
	458	{
	459	return(value_new_opaque(current_process));
412	460	}
413	461
414	462	/* TYPES */

441	489	return(
442	490	type_new_closure(
443	491	type_new_arg(type_new(TYPE_BOOLEAN), type_new(TYPE_BOOLEAN)),
	492	type_new(TYPE_BOOLEAN)
	493	)
	494	);
	495	}
	496
	497	struct type *
	498	btype_equality(void)
	499	{
	500	return(
	501	type_new_closure(
	502	type_new_arg(type_new_var(9), type_new_var(9)),
444	503	type_new(TYPE_BOOLEAN)
445	504	)
446	505	);

519	578	type_new(TYPE_VOID),
520	579	type_new(TYPE_VOID)
521	580	),
522		type_new(TYPE_VOID) /* XXX actually, pid */
	581	type_new_opaque("pid")
	582	)
	583	);
	584	}
	585
	586	struct type *
	587	btype_send(void)
	588	{
	589	return(
	590	type_new_closure(
	591	type_new_arg(
	592	type_new_opaque("pid"),
	593	type_new_var(10)
	594	),
	595	type_new(TYPE_VOID)
	596	)
	597	);
	598	}
	599
	600	struct type *
	601	btype_recv(void)
	602	{
	603	return(
	604	type_new_closure(
	605	type_new(TYPE_INTEGER),
	606	type_new_var(11)
	607	)
	608	);
	609	}
	610
	611	struct type *
	612	btype_self(void)
	613	{
	614	return(
	615	type_new_closure(
	616	type_new(TYPE_VOID),
	617	type_new_opaque("pid")
523	618	)
524	619	);
525	620	}

529	624	struct symbol *
530	625	register_builtin(struct symbol_table stab, struct builtin b)
531	626	{
532		struct value *v;
	627	struct value v;
533	628	struct symbol *sym;
534	629
535	630	v = value_new_builtin(b);
536	631	value_deregister(v); /* don't garbage-collect it */
537		sym = symbol_define(stab, b->name, SYM_KIND_COMMAND, v);
	632	sym = symbol_define(stab, b->name, SYM_KIND_COMMAND, &v);
538	633	sym->is_pure = b->is_pure;
539	634	sym->builtin = b;
540	635	sym->type = b->ty();

546	641	register_std_builtins(struct symbol_table *stab)
547	642	{
548	643	int i;
549		struct value *v;
	644	struct value v;
550	645	struct symbol *sym;
551	646
552	647	for (i = 0; builtins[i].name != NULL; i++)

557	652	/* And/or we should have "constant builtins" that have a va()
558	653	function that returns the constant value, hmm.... */
559	654
560		v = value_new_string("\n");
	655	v = value_new_string(L"\n");
561	656	value_deregister(v);
562		sym = symbol_define(stab, "EoL", SYM_KIND_VARIABLE, v);
	657	sym = symbol_define(stab, L"EoL", SYM_KIND_VARIABLE, &v);
563	658	sym->type = type_new(TYPE_STRING);
564	659
565	660	v = value_new_boolean(1);
566	661	value_deregister(v);
567		sym = symbol_define(stab, "True", SYM_KIND_VARIABLE, v);
	662	sym = symbol_define(stab, L"True", SYM_KIND_VARIABLE, &v);
568	663	sym->type = type_new(TYPE_BOOLEAN);
569	664
570	665	v = value_new_boolean(0);
571	666	value_deregister(v);
572		sym = symbol_define(stab, "False", SYM_KIND_VARIABLE, v);
	667	sym = symbol_define(stab, L"False", SYM_KIND_VARIABLE, &v);
573	668	sym->type = type_new(TYPE_BOOLEAN);
574	669	}
575	670

596	691	}
597	692
598	693	for (i = 0; ext_builtins[i].name != NULL; i++) {
599		printf("Registering ext builtin `%s'...\n", ext_builtins[i].name);
	694	/* printf("Registering ext builtin `%s'...\n", ext_builtins[i].name); */
600	695	register_builtin(stab, &ext_builtins[i]);
601	696	}
602	697

+36

-22

src/lib/builtin.h less more

0	0	#ifndef __BUILTIN_H_
1	1	#define __BUILTIN_H_
	2
	3	#include <wchar.h>
2	4
3	5	struct value;
4	6	struct activation;

7	9	struct symbol_table;
8	10
9	11	struct builtin {
10		char *name;
11		void (fn)(struct activation , struct value **);
	12	wchar_t *name;
	13	struct value (fn)(struct activation );
12	14	struct type (ty)(void);
13	15	int arity;
	16	int retval;
14	17	int is_pure;
15	18	int is_const;
16	19	int index;

36	39	#define INDEX_BUILTIN_STORE 17
37	40	#define INDEX_BUILTIN_DICT 18
38	41	#define INDEX_BUILTIN_SPAWN 19
	42	#define INDEX_BUILTIN_SEND 20
	43	#define INDEX_BUILTIN_RECV 21
	44	#define INDEX_BUILTIN_SELF 22
39	45
40	46	#define INDEX_BUILTIN_LAST 127
41	47
42	48	extern struct builtin builtins[];
43	49
44		void builtin_print(struct activation , struct value *);
	50	struct value builtin_print(struct activation *);
45	51
46		void builtin_not(struct activation , struct value *);
47		void builtin_and(struct activation , struct value *);
48		void builtin_or(struct activation , struct value *);
	52	struct value builtin_not(struct activation *);
	53	struct value builtin_and(struct activation *);
	54	struct value builtin_or(struct activation *);
49	55
50		void builtin_equ(struct activation , struct value *);
51		void builtin_neq(struct activation , struct value *);
52		void builtin_gt(struct activation , struct value *);
53		void builtin_lt(struct activation , struct value *);
54		void builtin_gte(struct activation , struct value *);
55		void builtin_lte(struct activation , struct value *);
	56	struct value builtin_equ(struct activation *);
	57	struct value builtin_neq(struct activation *);
	58	struct value builtin_gt(struct activation *);
	59	struct value builtin_lt(struct activation *);
	60	struct value builtin_gte(struct activation *);
	61	struct value builtin_lte(struct activation *);
56	62
57		void builtin_add(struct activation , struct value *);
58		void builtin_mul(struct activation , struct value *);
59		void builtin_sub(struct activation , struct value *);
60		void builtin_div(struct activation , struct value *);
61		void builtin_mod(struct activation , struct value *);
	63	struct value builtin_add(struct activation *);
	64	struct value builtin_mul(struct activation *);
	65	struct value builtin_sub(struct activation *);
	66	struct value builtin_div(struct activation *);
	67	struct value builtin_mod(struct activation *);
62	68
63		void builtin_list(struct activation , struct value *);
64		void builtin_fetch(struct activation , struct value *);
65		void builtin_store(struct activation , struct value *);
	69	struct value builtin_list(struct activation *);
	70	struct value builtin_fetch(struct activation *);
	71	struct value builtin_store(struct activation *);
66	72
67		void builtin_dict(struct activation , struct value *);
	73	struct value builtin_dict(struct activation *);
68	74
69		void builtin_spawn(struct activation , struct value *);
	75	struct value builtin_spawn(struct activation *);
	76	struct value builtin_send(struct activation *);
	77	struct value builtin_recv(struct activation *);
	78	struct value builtin_self(struct activation *);
70	79
71	80	struct type *btype_print(void);
72	81	struct type *btype_unary_logic(void);
73	82	struct type *btype_binary_logic(void);
	83	struct type *btype_equality(void);
74	84	struct type *btype_compare(void);
75	85	struct type *btype_arith(void);
76	86	struct type *btype_list(void);
77	87	struct type *btype_fetch(void);
78	88	struct type *btype_store(void);
79	89	struct type *btype_dict(void);
	90
80	91	struct type *btype_spawn(void);
	92	struct type *btype_send(void);
	93	struct type *btype_recv(void);
	94	struct type *btype_self(void);
81	95
82	96	struct symbol register_builtin(struct symbol_table , struct builtin *);
83	97	void register_std_builtins(struct symbol_table *);

+17

-17

src/lib/dict.c less more

111	111	* by Aho, Sethi, & Ullman (a.k.a. "The Dragon Book", 2nd edition.)
112	112	*/
113	113	static size_t
114		hashpjw(struct value *key, size_t table_size) {
	114	hashpjw(struct value key, size_t table_size) {
115	115	char *p;
116	116	unsigned long int h = 0, g;
117	117

120	120	* This is naff... for certain values this will work.
121	121	* For others, it won't...
122	122	*/
123		if (key->type == VALUE_INTEGER \|\|
124		key->type == VALUE_BOOLEAN \|\|
125		key->type == VALUE_ATOM) {
126		for (p = (char )key; p - (char )key < sizeof(int); p++) {
	123	if (key.type == VALUE_INTEGER \|\|
	124	key.type == VALUE_BOOLEAN \|\|
	125	key.type == VALUE_ATOM) {
	126	for (p = (char )&key.v.i; p - (char )&key.v.i < sizeof(int); p++) {
127	127	h = (h << 4) + (*p);
128	128	if ((g = h & 0xf0000000))
129	129	h = (h ^ (g >> 24)) ^ g;

139	139	* Create a new bucket (not called directly by client code.)
140	140	*/
141	141	static struct chain *
142		chain_new(struct value key, struct value value)
	142	chain_new(struct value key, struct value value)
143	143	{
144	144	struct chain *c;
145	145

157	157	* chain link itself if such a key exists (or NULL if it could not be found.)
158	158	*/
159	159	static void
160		dict_locate(struct dict d, struct value key,
	160	dict_locate(struct dict *d, struct value key,
161	161	size_t b_index, struct chain *c)
162	162	{
163	163	*b_index = hashpjw(key, d->num_buckets);

172	172	/*
173	173	* Retrieve a value from a dictionary, given its key.
174	174	*/
175		struct value *
176		dict_fetch(struct dict d, struct value k)
	175	struct value
	176	dict_fetch(struct dict *d, struct value k)
177	177	{
178	178	struct chain *c;
179	179	size_t i;

182	182	if (c != NULL) {
183	183	return(c->value);
184	184	} else {
185		return(NULL);
	185	return(value_null());
186	186	}
187	187	}
188	188

190	190	* Insert a value into a dictionary.
191	191	*/
192	192	void
193		dict_store(struct dict d, struct value k, struct value *v)
	193	dict_store(struct dict *d, struct value k, struct value v)
194	194	{
195	195	struct chain *c;
196	196	size_t i;

208	208	}
209	209
210	210	int
211		dict_exists(struct dict d, struct value key)
212		{
213		struct value *v;
	211	dict_exists(struct dict *d, struct value key)
	212	{
	213	struct value v;
214	214
215	215	v = dict_fetch(d, key);
216		return(v != NULL);
	216	return(v.type != VALUE_NULL);
217	217	}
218	218
219	219	/*

248	248	return(d->cursor == NULL);
249	249	}
250	250
251		struct value *
	251	struct value
252	252	dict_getkey(struct dict *d)
253	253	{
254	254	if (d->cursor == NULL) {
255		return(NULL);
	255	return(value_null());
256	256	} else {
257	257	/* XXX grab? */
258	258	return(d->cursor->key);

-7

src/lib/dict.h less more

6	6	#ifndef __DICT_H_
7	7	#define __DICT_H_
8	8
9		struct value;
	9	#include "value.h"
10	10
11	11	struct dict {
12	12	struct chain **bucket;

17	17
18	18	struct chain {
19	19	struct chain *next;
20		struct value *key;
21		struct value *value;
	20	struct value key;
	21	struct value value;
22	22	};
23	23
24	24	struct dict *dict_new(void);
25	25	struct dict dict_dup(struct dict );
26	26	void dict_free(struct dict *);
27	27
28		struct value dict_fetch(struct dict , struct value *);
29		int dict_exists(struct dict , struct value );
30		void dict_store(struct dict , struct value , struct value *);
	28	struct value dict_fetch(struct dict *, struct value);
	29	int dict_exists(struct dict *, struct value);
	30	void dict_store(struct dict *, struct value, struct value);
31	31
32	32	void dict_rewind(struct dict *);
33	33	int dict_eof(struct dict *);
34		struct value dict_getkey(struct dict );
	34	struct value dict_getkey(struct dict *);
35	35	void dict_next(struct dict *);
36	36
37	37	size_t dict_size(struct dict *);

+19

-65

src/lib/gc.c less more

12	12	#include "vm.h"
13	13	#include "process.h"
14	14
15		#ifdef POOL_VALUES
16		#include "pool.h"
17		#endif
18
19	15	#ifdef DEBUG
20	16	extern int trace_gc;
21	17	#endif

25	21
26	22	extern struct activation *a_head;
27	23
28		#ifdef HASH_CONSING
29		extern struct hc_chain *hc_bucket[HASH_CONS_SIZE];
30		extern struct hc_chain *hc_c;
31		#else
32		extern struct value *v_head;
33		#endif
	24	extern struct s_value *sv_head;
34	25
35	26	/*
36	27	* Garbage collector. Not a cheesy little reference counter, but

44	35	static void activation_mark(struct activation *a);
45	36
46	37	static void
47		value_mark(struct value *v)
	38	value_mark(struct value v)
48	39	{
49	40	struct list *l;
50	41
51		if (v == NULL \|\| v->admin & ADMIN_MARKED) /* \|\| v->admin & ADMIN_PERMANENT) */
	42	if (!(v.type & VALUE_STRUCTURED) \|\| v.v.s->admin & ADMIN_MARKED)
52	43	return;
53	44
54	45	#ifdef DEBUG

59	50	}
60	51	#endif
61	52
62		v->admin \|= ADMIN_MARKED;
63		switch (v->type) {
	53	v.v.s->admin \|= ADMIN_MARKED;
	54	switch (v.type) {
64	55	case VALUE_LIST:
65		for (l = v->v.l; l != NULL; l = l->next) {
	56	for (l = v.v.s->v.l; l != NULL; l = l->next) {
66	57	value_mark(l->value);
67	58	}
68	59	break;
69	60	case VALUE_CLOSURE:
70		activation_mark(v->v.k->ar);
	61	activation_mark(v.v.s->v.k->ar);
71	62	break;
72	63	case VALUE_DICT:
73	64	/* XXX for each key in v->v.d, value_mark(d[k]) */

121	112	struct process *p;
122	113	struct activation a, a_next;
123	114	struct activation *ta_head = NULL;
124		struct value *v;
125		struct value **vsc;
126		#ifdef HASH_CONSING
127		struct hc_chain **hccp;
128		struct hc_chain hc_next, hc_prev;
129		#else
130		struct value v_next, tv_head = NULL;
131		#endif
	115
	116	struct value *vsc;
	117	struct s_value sv, sv_next, *tsv_head = NULL;
132	118
133	119	/*
134	120	* Mark...

162	148
163	149	a_head = ta_head;
164	150
165		#ifdef HASH_CONSING
166		for (hccp = hc_bucket; hccp - hc_bucket < HASH_CONS_SIZE; hccp++) {
167		hc_prev = NULL;
168		for (hc_c = *hccp; hc_c != NULL; hc_c = hc_next) {
169		hc_next = hc_c->next;
170		v = hc_c->v;
171		if (v->admin & ADMIN_MARKED \|\| v->admin & ADMIN_PERMANENT) {
172		v->admin &= ~ADMIN_MARKED;
173		hc_prev = hc_c;
174		} else {
175		#ifdef DEBUG
176		if (trace_gc > 1) {
177		printf("[GC] FOUND UNREACHABLE VALUE ");
178		value_print(v);
179		printf("\n");
180		}
181		#endif
182		value_free(v);
183
184		if (hc_prev != NULL)
185		hc_prev->next = hc_next;
186		else
187		*hccp = hc_next;
188		bhuna_free(hc_c);
189		}
190		}
191		}
192		#else
193		for (v = v_head; v != NULL; v = v_next) {
194		v_next = v->next;
195		if (v->admin & ADMIN_MARKED \|\| v->admin & ADMIN_PERMANENT) {
196		v->admin &= ~ADMIN_MARKED;
197		v->next = tv_head;
198		tv_head = v;
	151	for (sv = sv_head; sv != NULL; sv = sv_next) {
	152	sv_next = sv->next;
	153	if (sv->admin & ADMIN_MARKED \|\| sv->admin & ADMIN_PERMANENT) {
	154	sv->admin &= ~ADMIN_MARKED;
	155	sv->next = tsv_head;
	156	tsv_head = sv;
199	157	} else {
200	158	#ifdef DEBUG
201	159	if (trace_gc > 1) {
202	160	printf("[GC] FOUND UNREACHABLE VALUE ");
203		value_print(v);
	161	/value_print(v);/
204	162	printf("\n");
205	163	}
206	164	#endif
207		value_free(v);
	165	s_value_free(sv);
208	166	}
209	167	}
210	168
211		v_head = tv_head;
212		#endif
213		#ifdef POOL_VALUES
214		clean_pools();
215		#endif
	169	sv_head = tsv_head;
216	170	}

+22

-6

src/lib/gen.c less more

15	15
16	16	static vm_label_t gptr, program;
17	17
	18	/*
18	19	vm_label_t patch_stack[4096];
19	20	int psp = 0;
20	21
21	22	unsigned char *last_ins_at = NULL;
22	23	unsigned char last_ins = 255;
	24	*/
	25
	26	#if 0
23	27
24	28	/* backpatcher */
25	29

276	280	assert(a->u.assignment.left != NULL);
277	281	assert(a->u.assignment.left->type == AST_LOCAL);
278	282	ast_gen_r(a->u.assignment.right);
279		/gen_deep_copy();/
280		gen_pop_local(a->u.assignment.left->u.local.index,
281		a->u.assignment.left->u.local.upcount);
	283	if (a->u.assignment.defining) {
	284	/* XXX */
	285	/*
	286	gen_init_local(a->u.assignment.left->u.local.index,
	287	a->u.assignment.left->u.local.upcount);
	288	*/
	289	} else {
	290	gen_pop_local(a->u.assignment.left->u.local.index,
	291	a->u.assignment.left->u.local.upcount);
	292	}
282	293	break;
283	294	case AST_CONDITIONAL:
284	295	ast_gen_r(a->u.conditional.test);

316	327	*gptr++ = INSTR_HALT;
317	328	}
318	329
	330	#else
	331	#define gen(x) *gptr++ = x
	332	#endif
	333
319	334	/* gen VM from iprogram */
320	335
321	336	void

338	353	gen(ic->opcode);
339	354	switch (ic->opcode) {
340	355	case INSTR_PUSH_VALUE:
341		if (ic->operand.value->type == VALUE_CLOSURE) {
342		k[ki++] = ic->operand.value->v.k;
	356	if (ic->operand.value.type == VALUE_CLOSURE) {
	357	k[ki++] = ic->operand.value.v.s->v.k;
343	358	}
344		(((struct value *)gptr)++) = ic->operand.value;
	359	(((struct value )gptr)++) = ic->operand.value;
345	360	break;
346	361	case INSTR_PUSH_LOCAL:
347	362	case INSTR_POP_LOCAL:
348	363	case INSTR_COW_LOCAL:
	364	case INSTR_INIT_LOCAL:
349	365	*gptr++ = (unsigned char)ic->operand.local.index;
350	366	*gptr++ = (unsigned char)ic->operand.local.upcount;
351	367	break;

+54

-27

src/lib/icode.c less more

8	8	#include "builtin.h"
9	9	#include "value.h"
10	10	#include "closure.h"
	11	#include "utf8.h"
11	12
12	13	/* iprograms */
13	14

101	102	}
102	103
103	104	struct icode *
104		icode_new_value(struct iprogram ip, int opcode, struct value value)
	105	icode_new_value(struct iprogram *ip, int opcode, struct value value)
105	106	{
106	107	struct icode *ic;
107	108

194	195
195	196	/************* intermediate code generator **************/
196	197
197		/*
198		#include <assert.h>
199		#include <stdio.h>
200		#include <stdlib.h>
201		#include <string.h>
202
203		#include "vm.h"
204		#include "ast.h"
205		#include "value.h"
206		#include "list.h"
207		#include "closure.h"
208		#include "activation.h"
209		#include "builtin.h"
210		*/
211
212	198	static void
213	199	ast_gen_r(struct iprogram ip, struct ast a)
214	200	{
215	201	struct icode ic1, ic2, ic3, ic4;
216		struct value *v;
	202	struct value v;
217	203
218	204	if (a == NULL)
219	205	return;

226	212	break;
227	213	case AST_VALUE:
228	214	icode_new_value(ip, INSTR_PUSH_VALUE, a->u.value.value);
229		if (a->u.value.value->type == VALUE_CLOSURE) {
	215	if (a->u.value.value.type == VALUE_CLOSURE) {
230	216	icode_new(ip, INSTR_SET_ACTIVATION);
231	217	ic1 = icode_new(ip, INSTR_JMP);
232	218	ic2 = icode_new(ip, INSTR_NOP);
233		icode_set_closure_entry_point(a->u.value.value->v.k, ic2);
234		ast_gen_r(ip, a->u.value.value->v.k->ast);
	219	icode_set_closure_entry_point(a->u.value.value.v.s->v.k, ic2);
	220	ast_gen_r(ip, a->u.value.value.v.s->v.k->ast);
235	221	icode_new(ip, INSTR_RET);
236	222	ic3 = icode_new(ip, INSTR_NOP);
237	223	icode_set_branch(ic1, ic3);

273	259	assert(a->u.assignment.left != NULL);
274	260	assert(a->u.assignment.left->type == AST_LOCAL);
275	261	ast_gen_r(ip, a->u.assignment.right);
276		icode_new_local(ip, INSTR_POP_LOCAL,
277		a->u.assignment.left->u.local.index,
278		a->u.assignment.left->u.local.upcount);
	262	if (a->u.assignment.defining) {
	263	icode_new_local(ip, INSTR_INIT_LOCAL,
	264	a->u.assignment.left->u.local.index,
	265	a->u.assignment.left->u.local.upcount);
	266	} else {
	267	icode_new_local(ip, INSTR_POP_LOCAL,
	268	a->u.assignment.left->u.local.index,
	269	a->u.assignment.left->u.local.upcount);
	270	}
279	271	break;
280	272	case AST_CONDITIONAL:
281	273	ast_gen_r(ip, a->u.conditional.test);

382	374	printf("POP_LOCAL (%d,%d)",
383	375	ic->operand.local.index, ic->operand.local.upcount);
384	376	break;
	377	case INSTR_INIT_LOCAL:
	378	printf("INIT_LOCAL (%d,%d)",
	379	ic->operand.local.index, ic->operand.local.upcount);
	380	break;
385	381	case INSTR_JZ:
386	382	printf("JZ %s", icode_addr(ic->operand.branch, program));
387	383	break;

404	400	printf("COW_LOCAL (%d,%d)",
405	401	ic->operand.local.index, ic->operand.local.upcount);
406	402	case INSTR_EXTERNAL:
407		printf("EXTERNAL `%s'", ic->operand.builtin->name);
	403	printf("EXTERNAL `"),
	404	fputsu8(stdout, ic->operand.builtin->name);
	405	printf("'");
408	406	break;
409	407	case INSTR_NOP:
410	408	printf("NOP");
411	409	break;
412	410
413	411	default:
414		printf("BUILTIN `%s'", builtins[ic->opcode].name);
	412	printf("BUILTIN `");
	413	fputsu8(stdout, builtins[ic->opcode].name);
	414	printf("'");
415	415	}
416	416	printf("\n");
417	417	}

527	527	for (ic = ip->head; ic != NULL; ic = ic_next) {
528	528	ic_next = ic->next;
529	529	if (ic->opcode == INSTR_PUSH_VALUE &&
530		ic->operand.value->type == VALUE_INTEGER) {
531		switch (ic->operand.value->v.i) {
	530	ic->operand.value.type == VALUE_INTEGER) {
	531	switch (ic->operand.value.v.i) {
532	532	case 0:
533	533	ic->opcode = INSTR_PUSH_ZERO;
534	534	break;

542	542	}
543	543	}
544	544	}
	545
	546	int
	547	count_referrers(struct icode *ic)
	548	{
	549	struct icomefrom *icf;
	550	int i = 0;
	551
	552	for (icf = ic->referrers; icf != NULL; icf = icf->next)
	553	i++;
	554
	555	return(i);
	556	}
	557
	558	void
	559	iprogram_eliminate_useless_jumps(struct iprogram *ip)
	560	{
	561	struct icode ic, ic_next;
	562
	563	for (ic = ip->head; ic != NULL; ic = ic_next) {
	564	ic_next = ic->next;
	565	if (ic->opcode == INSTR_JMP &&
	566	ic->operand.branch->opcode == INSTR_RET) {
	567	referrer_unwire(ic, ic->operand.branch);
	568	ic->opcode = INSTR_RET;
	569	}
	570	}
	571	}

-3

src/lib/icode.h less more

6	6
7	7	#include "vm.h"
8	8
9		struct value;
	9	#include "value.h"
	10
10	11	struct ast;
11	12	struct builtin;
12	13

20	21	int index;
21	22	int upcount;
22	23	} local;
23		struct value *value;
	24	struct value value;
24	25	struct icode *branch;
25	26	struct builtin *builtin;
26	27	};

53	54
54	55	struct icode icode_new(struct iprogram , int);
55	56	struct icode icode_new_local(struct iprogram , int, int, int);
56		struct icode icode_new_value(struct iprogram , int, struct value *);
	57	struct icode icode_new_value(struct iprogram , int, struct value);
57	58	struct icode icode_new_builtin(struct iprogram , struct builtin *);
58	59
59	60	void icode_free(struct iprogram , struct icode );

66	67	void iprogram_eliminate_dead_code(struct iprogram *);
67	68	void iprogram_optimize_tail_calls(struct iprogram *);
68	69	void iprogram_optimize_push_small_ints(struct iprogram *);
	70	void iprogram_eliminate_useless_jumps(struct iprogram *);
69	71
70	72	void referrer_unwire(struct icode , struct icode );
71	73	void referrers_rewire(struct icode , struct icode );

-3

src/lib/list.c less more

6	6	#include "value.h"
7	7
8	8	void
9		list_cons(struct list *l, struct value v)
	9	list_cons(struct list **l, struct value v)
10	10	{
11	11	struct list *n;
12	12

19	19	struct list *
20	20	list_dup(struct list *l)
21	21	{
22		struct list *n;
	22	struct list *n = l;
23	23
24	24	/* ... XXX ... */
25	25

55	55	* Full comparison used here.
56	56	*/
57	57	int
58		list_contains(struct list l, struct value v)
	58	list_contains(struct list *l, struct value v)
59	59	{
60	60	while (l != NULL) {
61	61	if (value_equal(l->value, v))

-4

src/lib/list.h less more

7	7
8	8	#include <sys/types.h>
9	9
10		struct value;
	10	#include "value.h"
11	11
12	12	struct list {
13	13	struct list *next;
14		struct value *value;
	14	struct value value;
15	15	};
16	16
17		void list_cons(struct list *, struct value );
	17	void list_cons(struct list **, struct value);
18	18	struct list list_dup(struct list );
19	19	void list_free(struct list **);
20	20	size_t list_length(struct list *);
21		int list_contains(struct list , struct value );
	21	int list_contains(struct list *, struct value);
22	22
23	23	void list_dump(struct list *);
24	24

+12

-0

src/lib/mem.c less more

6	6	#include <assert.h>
7	7	#include <stdlib.h>
8	8	#include <string.h>
	9	#include <wchar.h>
9	10
10	11	void *
11	12	bhuna_malloc(size_t size, char *what)

32	33	return(ptr);
33	34	}
34	35
	36	wchar_t *
	37	bhuna_wcsdup(wchar_t *w)
	38	{
	39	wchar_t *n;
	40
	41	n = bhuna_malloc((wcslen(w) + 1) * sizeof(wchar_t), "wcsdup");
	42	wcscpy(n, w);
	43
	44	return(n);
	45	}
	46
35	47	void
36	48	bhuna_free(void *ptr)
37	49	{

-0

src/lib/mem.h less more

7	7	#define __MEM_H_
8	8
9	9	#include <sys/types.h>
	10	#include <wchar.h>
10	11
	12	wchar_t bhuna_wcsdup(wchar_t );
11	13	#ifdef DEBUG
12	14	void *bhuna_malloc(size_t);
13	15	char bhuna_strdup(char );

+117

-100

src/lib/parse.c less more

8	8	#include <stdio.h>
9	9	#include <stdlib.h>
10	10	#include <string.h>
	11	#include <wchar.h>
11	12
12	13	#include "scan.h"
13	14	#include "parse.h"

18	19	#include "type.h"
19	20	#include "report.h"
20	21	#include "builtin.h"
	22	#include "utf8.h"
21	23
22	24	#define VAR_LOCAL 0
23	25	#define VAR_GLOBAL 1

32	34	* Convenience function to create AST for a named arity-2 function call.
33	35	*/
34	36	static struct ast *
35		ast_new_call2(char name, struct scan_st sc, struct symbol_table *stab,
	37	ast_new_call2(wchar_t name, struct scan_st sc, struct symbol_table *stab,
36	38	struct ast left, struct ast right)
37	39	{
38	40	struct symbol *sym;
39	41	struct ast *a;
	42	wchar_t *tname;
	43
	44	if (wcscmp(name, L"\x2264") == 0) {
	45	tname = L"<=";
	46	} else if (wcscmp(name, L"\x2265") == 0) {
	47	tname = L">=";
	48	} else if (wcscmp(name, L"\x2260") == 0) {
	49	tname = L"!=";
	50	} else {
	51	tname = name;
	52	}
40	53
41	54	right = ast_new_arg(right, NULL);
42	55	left = ast_new_arg(left, right);
43	56
44		sym = symbol_lookup(stab, name, VAR_GLOBAL);
	57	sym = symbol_lookup(stab, tname, VAR_GLOBAL);
45	58	assert(sym != NULL && sym->builtin != NULL);
46	59	a = ast_new_builtin(sc, sym->builtin, left);
47	60

49	62	}
50	63
51	64	static struct ast *
52		ast_new_call3(char name, struct scan_st sc, struct symbol_table *stab,
	65	ast_new_call3(wchar_t name, struct scan_st sc, struct symbol_table *stab,
53	66	struct ast left, struct ast index, struct ast *right)
54	67	{
55	68	struct symbol *sym;

95	108
96	109	assert(*istab != NULL);
97	110
98		if (tokeq(sc, "{")) {
99		scan_expect(sc, "{");
100		while (tokne(sc, "}") && sc->type != TOKEN_EOF && !retr) {
	111	if (tokeq(sc, L"{")) {
	112	scan_expect(sc, L"{");
	113	while (tokne(sc, L"}") && sc->type != TOKEN_EOF && !retr) {
101	114	a = ast_new_statement(a,
102	115	parse_statement(sc, *istab, &retr, cc));
103	116	}
104		scan_expect(sc, "}");
	117	scan_expect(sc, L"}");
105	118	} else {
106	119	a = parse_statement(sc, *istab, &retr, cc);
107	120	}

122	135	struct symbol_table *istab;
123	136	struct ast a, l, *r;
124	137
125		if (tokeq(sc, "{")) {
	138	if (tokeq(sc, L"{")) {
126	139	istab = symbol_table_new(stab, 0);
127	140	a = parse_block(sc, stab, &istab, cc);
128		} else if (tokeq(sc, "if")) {
	141	} else if (tokeq(sc, L"if")) {
129	142	scan(sc);
130	143	a = parse_expr(sc, stab, 0, NULL, cc);
131	144	istab = symbol_table_new(stab, 0);
132	145	l = parse_block(sc, stab, &istab, cc);
133		if (tokeq(sc, "else")) {
	146	if (tokeq(sc, L"else")) {
134	147	scan(sc);
135	148	istab = symbol_table_new(stab, 0);
136	149	r = parse_block(sc, stab, &istab, cc);

138	151	r = NULL;
139	152	}
140	153	a = ast_new_conditional(sc, a, l, r);
141		} else if (tokeq(sc, "while")) {
	154	} else if (tokeq(sc, L"while")) {
142	155	scan(sc);
143	156	l = parse_expr(sc, stab, 0, NULL, cc);
144	157	istab = symbol_table_new(stab, 0);
145	158	r = parse_block(sc, stab, &istab, cc);
146	159	a = ast_new_while_loop(sc, l, r);
147		} else if (tokeq(sc, "return")) {
	160	} else if (tokeq(sc, L"return")) {
148	161	scan(sc);
149	162	a = parse_expr(sc, stab, 0, NULL, cc);
150	163	a = ast_new_retr(a);
151	164	*retr = 1;
152		} else if (tokeq(sc, "import")) {
	165	} else if (tokeq(sc, L"import")) {
153	166	scan(sc);
154	167	if (sc->type == TOKEN_QSTRING) {
155		load_builtins(stab, sc->token);
	168	/* XXX convert wchar_t -> char */
	169	load_builtins(stab, (char *)sc->token);
156	170	scan(sc);
157	171	} else {
158	172	report(REPORT_ERROR, sc, "Expected quoted string");

162	176	int is_const = 0;
163	177	int is_def = 0;
164	178
165		while (tokeq(sc, "local") \|\| tokeq(sc, "const")) {
	179	while (tokeq(sc, L"local") \|\| tokeq(sc, L"const")) {
166	180	is_def = 1;
167		if (tokeq(sc, "local")) {
	181	if (tokeq(sc, L"local")) {
168	182	scan(sc);
169	183	/* Not much, mere presence works. */
170		} else if (tokeq(sc, "const")) {
	184	} else if (tokeq(sc, L"const")) {
171	185	scan(sc);
172	186	is_const = 1;
173	187	}

186	200	a = parse_command_or_assignment(sc, stab, cc);
187	201	}
188	202	}
189		if (tokeq(sc, ";"))
	203	if (tokeq(sc, L";"))
190	204	scan(sc);
191	205	return(a);
192	206	}

197	211	{
198	212	struct symbol *sym;
199	213	struct ast l, r;
200		struct value *v = NULL;
201
202		if (is_const) {
203		/*
204		* This is just a placeholder.
205		*/
206		v = value_new_integer(42);
207		value_deregister(v);
208		}
209		l = parse_var(sc, stab, &sym, VAR_LOCAL, VAR_MUST_NOT_EXIST, v);
210		scan_expect(sc, "=");
	214	struct value v;
	215
	216	l = parse_var(sc, stab, &sym, VAR_LOCAL, VAR_MUST_NOT_EXIST,
	217	is_const ? &v : NULL);
	218	scan_expect(sc, L"=");
211	219	r = parse_expr(sc, stab, 0, sym, cc);
212	220	if (is_const) {
213	221	if (r == NULL \|\| r->type != AST_VALUE) {

219	227	}
220	228	return(NULL);
221	229	} else {
222		return(ast_new_assignment(sc, l, r));
	230	return(ast_new_assignment(sc, l, r, 1));
223	231	}
224	232	}
225	233

238	246	* A[I][J] = K -> Store A[I], J, K
239	247	* A[I][J][K] = L -> Store A[I][J], K, L
240	248	*/
241		while (tokeq(sc, "[") \|\| tokeq(sc, ".")) {
242		if (tokeq(sc, "[")) {
	249	while (tokeq(sc, L"[") \|\| tokeq(sc, L".")) {
	250	if (tokeq(sc, L"[")) {
243	251	scan(sc);
244	252	l = parse_expr(sc, stab, 0, NULL, cc);
245		scan_expect(sc, "]");
246		if (tokeq(sc, "=")) {
	253	scan_expect(sc, L"]");
	254	if (tokeq(sc, L"=")) {
247	255	/*
248	256	* It was the last one; this is an assigment.
249	257	*/
250	258	scan(sc);
251	259	r = parse_expr(sc, stab, 0, NULL, cc);
252		a = ast_new_call3("Store", sc, stab, a, l, r);
	260	a = ast_new_call3(L"Store", sc, stab, a, l, r);
253	261	return(a);
254		} else if (tokne(sc, "[") && tokne(sc, ".")) {
	262	} else if (tokne(sc, L"[") && tokne(sc, L".")) {
255	263	/*
256	264	* It was the last one; this is a command.
257	265	*/

260	268	/*
261	269	* Still more to go.
262	270	*/
263		a = ast_new_call2("Fetch", sc, stab, a, l);
	271	a = ast_new_call2(L"Fetch", sc, stab, a, l);
264	272	}
265		} else if (tokeq(sc, ".")) {
	273	} else if (tokeq(sc, L".")) {
266	274	scan(sc);
267	275	r = parse_literal(sc, stab);
268		a = ast_new_call2("Fetch", sc, stab, a, r);
	276	a = ast_new_call2(L"Fetch", sc, stab, a, r);
269	277	}
270	278	}
271	279

273	281	* If the variable-expression was followed by an equals sign,
274	282	* it's an assignment to an already-existing variable.
275	283	*/
276		if (tokeq(sc, "=")) {
277		if (sym->value != NULL) {
	284	if (tokeq(sc, L"=")) {
	285	if (sym->is_const) {
278	286	report(REPORT_ERROR, sc, "Value not modifiable");
279	287	} else {
280	288	scan(sc);
281	289	r = parse_expr(sc, stab, 0, NULL, cc);
282		a = ast_new_assignment(sc, a, r);
	290	a = ast_new_assignment(sc, a, r, 0);
283	291	}
284	292	return(a);
285		}
286
287		if (tokne(sc, "}") && tokne(sc, ";") && sc->type != TOKEN_EOF) {
288		l = parse_expr_list(sc, stab, NULL, cc);
289		} else {
290		l = NULL;
291	293	}
292	294
293	295	/*
294	296	* Otherwise, it's a command.
295	297	*/
	298	if (tokne(sc, L"}") && tokne(sc, L";") && sc->type != TOKEN_EOF) {
	299	l = parse_expr_list(sc, stab, NULL, cc);
	300	} else {
	301	l = NULL;
	302	}
	303
296	304	if (!type_is_possibly_routine(sym->type)) {
297	305	report(REPORT_ERROR, sc, "Command application of non-routine variable");
298	306	/return(NULL);/
299	307	}
300	308	type_ensure_routine(sym->type);
301		if (!type_is_void(type_representative(sym->type)->t.closure.range)) {
302		report(REPORT_ERROR, sc, "Command application of function variable");
	309	if (!type_is_possibly_void(type_representative(sym->type)->t.closure.range)) {
	310	report(REPORT_ERROR, sc, "Command application of function variable %t", sym->type);
303	311	/return(NULL);/
304	312	}
305	313

319	327	struct ast a, b;
320	328
321	329	a = parse_expr(sc, stab, 0, excl, cc);
322		if (tokeq(sc, ",")) {
	330	if (tokeq(sc, L",")) {
323	331	scan(sc);
324	332	b = parse_expr_list(sc, stab, excl, cc);
325	333	} else {

328	336	return(ast_new_arg(a, b));
329	337	}
330	338
	339	struct ast *
	340	parse_formal_arg_list(struct scan_st sc, struct symbol_table stab,
	341	int *arity)
	342	{
	343	struct ast a, b;
	344	struct symbol *sym;
	345
	346	a = parse_var(sc, stab, &sym,
	347	VAR_LOCAL, VAR_MUST_NOT_EXIST, NULL);
	348	(*arity)++;
	349
	350	if (tokeq(sc, L",")) {
	351	scan(sc);
	352	b = parse_formal_arg_list(sc, stab, arity);
	353	} else {
	354	b = NULL;
	355	}
	356
	357	return(ast_new_arg(a, b));
	358	}
	359
331	360	/* ------------------------- EXPRESSIONS ------------------------ */
332	361
333	362	int maxlevel = 3;
334	363
335		char *op[4][6] = {
336		{ "&", "\|", "", "", "", "" },
337		{ "=", "!=", ">", "<", ">=", "<=" },
338		{ "+", "-", "", "", "", "" },
339		{ "*", "/", "%", "", "", "" }
	364	wchar_t *op[4][9] = {
	365	{ L"&", L"\|", L"", L"", L"", L"", L"", L"", L"" },
	366	{ L"=", L"!=", L">", L"<", L">=", L"<=", L"\x2264", L"\x2265", L"\x2260" },
	367	{ L"+", L"-", L"", L"", L"", L"", L"", L"", L"" },
	368	{ L"*", L"/", L"%", L"", L"", L"", L"", L"", L"" }
340	369	};
341	370
342	371	struct ast *

345	374	{
346	375	struct ast l, r;
347	376	int done = 0, i = 0;
348		char the_op[256];
	377	wchar_t the_op[256];
349	378
350	379	if (level > maxlevel) {
351	380	l = parse_primitive(sc, stab, excl, cc);

354	383	l = parse_expr(sc, stab, level + 1, excl, cc);
355	384	while (!done) {
356	385	done = 1;
357		for (i = 0; i < 6 && op[level][i][0] != '\0'; i++) {
	386	for (i = 0; i < 9 && op[level][i][0] != '\0'; i++) {
358	387	if (tokeq(sc, op[level][i])) {
359		strlcpy(the_op, sc->token, 256);
	388	wcslcpy(the_op, sc->token, 256);
360	389	scan(sc);
361	390	done = 0;
362	391	r = parse_expr(sc, stab, level + 1, excl, cc);

374	403	struct symbol excl, int cc)
375	404	{
376	405	struct ast a, l, *r;
377		struct value *v;
	406	struct value v;
378	407	struct symbol *sym;
379	408	struct symbol_table *istab;
380	409
381		if (tokeq(sc, "(")) {
	410	if (tokeq(sc, L"(")) {
382	411	scan(sc);
383	412	a = parse_expr(sc, stab, 0, excl, cc);
384		scan_expect(sc, ")");
385		} else if (tokeq(sc, "^")) {
	413	scan_expect(sc, L")");
	414	} else if (tokeq(sc, L"^") \|\| tokeq(sc, L"\x03bb")) {
386	415	int my_cc = 0;
387	416	int my_arity = 0;
388	417	struct type *a_type = NULL;

393	422	(*cc)++;
394	423	scan(sc);
395	424	istab = symbol_table_new(stab, 1);
396		while (tokne(sc, "{") && sc->type != TOKEN_EOF) {
397		a = parse_var(sc, istab, &sym,
398		VAR_LOCAL, VAR_MUST_NOT_EXIST, NULL);
	425	if (tokne(sc, L"{") && sc->type != TOKEN_EOF) {
	426	a = parse_formal_arg_list(sc, istab, &my_arity);
	427	a_type = a->datatype;
399	428	ast_free(a);
400		if (a_type == NULL)
401		a_type = sym->type;
402		else
403		a_type = type_new_arg(sym->type, a_type);
404		my_arity++;
405		/*
406		printf("ARG TYPE:");
407		type_print(stdout, a_type);
408		printf("\n");
409		*/
410		if (tokeq(sc, ","))
411		scan(sc);
412		}
413		if (a_type == NULL)
	429	} else {
414	430	a_type = type_new(TYPE_VOID);
	431	}
415	432	a = parse_block(sc, stab, &istab, &my_cc);
416	433	a = ast_new_routine(a);
417	434	if (type_is_set(a->datatype) && type_set_contains_void(a->datatype)) {

421	438	value_deregister(v);
422	439	a = ast_new_value(v,
423	440	type_new_closure(a_type, a->datatype));
424		} else if (tokeq(sc, "!")) {
	441	} else if (tokeq(sc, L"!")) {
425	442	scan(sc);
426	443	a = parse_primitive(sc, stab, excl, cc);
427		sym = symbol_lookup(stab, "!", 1);
428		/* XXX builtin */
429		a = ast_new_apply(sc, ast_new_local(stab, sym), a, 1);
430		} else if (tokeq(sc, "[")) {
	444	sym = symbol_lookup(stab, L"!", VAR_GLOBAL);
	445	assert(sym != NULL && sym->builtin != NULL);
	446	a = ast_new_builtin(sc, sym->builtin, a);
	447	} else if (tokeq(sc, L"[")) {
431	448	scan(sc);
432	449	v = value_new_list();
433	450	value_deregister(v);
434	451	a = ast_new_value(v, NULL); /* XXX list */
435		if (tokne(sc, "]")) {
	452	if (tokne(sc, L"]")) {
436	453	l = parse_expr_list(sc, stab, excl, cc);
437		sym = symbol_lookup(stab, "List", VAR_GLOBAL);
	454	sym = symbol_lookup(stab, L"List", VAR_GLOBAL);
438	455	assert(sym->builtin != NULL);
439	456	a = ast_new_builtin(sc, sym->builtin, l);
440	457	}
441		scan_expect(sc, "]");
	458	scan_expect(sc, L"]");
442	459	} else if (sc->type == TOKEN_BAREWORD && isupper(sc->token[0])) {
443	460	a = parse_var(sc, stab, &sym, VAR_GLOBAL, VAR_MUST_EXIST, NULL);
444	461	if (sym == excl) {
445	462	report(REPORT_ERROR, sc, "Initializer cannot refer to variable being defined");
446	463	return(NULL);
447	464	}
448		while (tokeq(sc, "(") \|\| tokeq(sc, "[") \|\| tokeq(sc, ".")) {
449		if (tokeq(sc, "(")) {
	465	while (tokeq(sc, L"(") \|\| tokeq(sc, L"[") \|\| tokeq(sc, L".")) {
	466	if (tokeq(sc, L"(")) {
450	467	scan(sc);
451		if (tokne(sc, ")")) {
	468	if (tokne(sc, L")")) {
452	469	l = parse_expr_list(sc, stab, excl, cc);
453	470	} else {
454	471	l = NULL;
455	472	}
456		scan_expect(sc, ")");
	473	scan_expect(sc, L")");
457	474
458	475	if (!type_is_possibly_routine(sym->type)) {
459	476	report(REPORT_ERROR, sc, "Function application of non-routine variable");

470	487	} else {
471	488	a = ast_new_apply(sc, a, l, sym->is_pure);
472	489	}
473		} else if (tokeq(sc, "[")) {
	490	} else if (tokeq(sc, L"[")) {
474	491	scan(sc);
475	492	r = parse_expr(sc, stab, 0, excl, cc);
476		scan_expect(sc, "]");
477		a = ast_new_call2("Fetch", sc, stab, a, r);
478		} else if (tokeq(sc, ".")) {
	493	scan_expect(sc, L"]");
	494	a = ast_new_call2(L"Fetch", sc, stab, a, r);
	495	} else if (tokeq(sc, L".")) {
479	496	scan(sc);
480	497	r = parse_literal(sc, stab);
481		a = ast_new_call2("Fetch", sc, stab, a, r);
	498	a = ast_new_call2(L"Fetch", sc, stab, a, r);
482	499	}
483	500	}
484	501	} else {

492	509	parse_literal(struct scan_st sc, struct symbol_table stab)
493	510	{
494	511	struct ast *a;
495		struct value *v;
	512	struct value v;
496	513
497	514	if (sc->type == TOKEN_BAREWORD && islower(sc->token[0])) {
498	515	v = value_new_atom(atom_resolve(sc->token));

500	517	a = ast_new_value(v, type_new(TYPE_ATOM));
501	518	scan(sc);
502	519	} else if (sc->type == TOKEN_NUMBER) {
503		v = value_new_integer(atoi(sc->token));
	520	v = value_new_integer(wcstoi(sc->token));
504	521	value_deregister(v);
505	522	a = ast_new_value(v, type_new(TYPE_INTEGER));
506	523	scan(sc);

540	557	}
541	558	scan(sc);
542	559
543		if ((*sym)->value != NULL) {
	560	if ((*sym)->is_const) {
544	561	a = ast_new_value((sym)->value, (sym)->type);
545	562	} else {
546	563	a = ast_new_local(stab, (*sym));

+113

-3

src/lib/process.c less more

7	7	#include "ast.h"
8	8	#include "activation.h"
9	9
10		#define TIMESLICE 4096
	10	#define TIMESLICE 2048
	11	// 4096
11	12	extern int trace_scheduling;
12	13
13	14	struct process *current_process = NULL;

24	25	p = bhuna_malloc(sizeof(struct process));
25	26	p->vm = vm;
26	27	p->number = procno++;
	28	p->msg_head = NULL;
	29	p->asleep = 0;
27	30	p->next = run_head;
28	31	p->prev = NULL;
29	32	if (run_head != NULL)

64	67	struct process *p;
65	68
66	69	vm = vm_new(current_process->vm->program, current_process->vm->prog_size);
67		vm_set_pc(vm, k->ast->label);
	70	vm_set_pc(vm, k->label);
68	71
69	72	vm->current_ar = activation_new_on_heap(
70	73	k->arity + k->locals, NULL, k->ar);

79	82	}
80	83
81	84	void
	85	process_send(struct process *p, struct value v)
	86	{
	87	struct message *m;
	88
	89	m = bhuna_malloc(sizeof(struct message));
	90	m->next = p->msg_head;
	91	p->msg_head = m;
	92	m->payload = v;
	93
	94	#ifdef DEBUG
	95	if (trace_scheduling) {
	96	printf("send from process #%d to process #%d: ",
	97	current_process->number, p->number);
	98	value_print(v);
	99	printf("\n");
	100	}
	101	#endif
	102
	103	process_awaken(p);
	104	}
	105
	106	/*
	107	* Returns 1 if a message was obtained from the mailbox,
	108	* 0 if there were no messages waiting (indicating: go to sleep.)
	109	*/
	110	int
	111	process_recv(struct value *v)
	112	{
	113	struct message *m;
	114
	115	if (current_process->msg_head == NULL)
	116	return(0);
	117
	118	m = current_process->msg_head;
	119	*v = m->payload;
	120	current_process->msg_head = m->next;
	121	bhuna_free(m);
	122
	123	#ifdef DEBUG
	124	if (trace_scheduling) {
	125	printf("received in process #%d: ",
	126	current_process->number);
	127	value_print(*v);
	128	printf("\n");
	129	}
	130	#endif
	131
	132	return(1);
	133	}
	134
	135	void
	136	process_sleep(struct process *p)
	137	{
	138	if (p == NULL \|\| p->asleep)
	139	return;
	140
	141	/* remove from run list, add to wait list */
	142	if (p->prev != NULL)
	143	p->prev->next = p->next;
	144	else if (p == run_head)
	145	run_head = p->next;
	146
	147	if (p->next != NULL)
	148	p->next->prev = p->prev;
	149
	150	p->prev = NULL;
	151	p->next = wait_head;
	152	if (wait_head != NULL)
	153	wait_head->prev = p;
	154	wait_head = p;
	155
	156	p->asleep = 1;
	157	}
	158
	159	void
	160	process_awaken(struct process *p)
	161	{
	162	if (p == NULL \|\| !p->asleep)
	163	return;
	164
	165	/* remove from run list, add to run list */
	166	if (p->prev != NULL)
	167	p->prev->next = p->next;
	168	else if (p == wait_head)
	169	wait_head = p->next;
	170
	171	if (p->next != NULL)
	172	p->next->prev = p->prev;
	173
	174	p->prev = NULL;
	175	p->next = run_head;
	176	if (run_head != NULL)
	177	run_head->prev = p;
	178	run_head = p;
	179
	180	p->asleep = 0;
	181	}
	182
	183	/****** SCHEDULER ******/
	184
	185	void
82	186	process_scheduler(void)
83	187	{
84	188	struct process *next;

107	211	#endif
108	212	process_free(current_process);
109	213	break;
	214	case VM_WAITING:
	215	#ifdef DEBUG
	216	if (trace_scheduling)
	217	printf("process #%d falling asleep\n", current_process->number);
	218	#endif
	219	process_sleep(current_process);
	220	break;
110	221	case VM_TIME_EXPIRED:
111		case VM_WAITING:
112	222	default:
113	223	break;
114	224	}

+20

-0

src/lib/process.h less more

	0	#ifndef __PROCESS_H_
	1	#define __PROCESS_H_
	2
	3	#include "value.h"
	4
0	5	struct vm;
1	6	struct closure;
2	7
3	8	struct process {
	9	int asleep;
4	10	int number;
5	11	struct process *next;
6	12	struct process *prev;
7	13	struct vm *vm;
	14	struct message *msg_head;
	15	};
	16
	17	struct message {
	18	struct message *next;
	19	struct value payload;
8	20	};
9	21
10	22	extern struct process *current_process;

15	27	void process_free(struct process *);
16	28	void process_scheduler(void);
17	29	struct process process_spawn(struct closure );
	30
	31	void process_send(struct process *, struct value);
	32	int process_recv(struct value *);
	33
	34	void process_sleep(struct process *);
	35	void process_awaken(struct process *);
	36
	37	#endif

+11

-4

src/lib/report.c less more

5	5
6	6	#include <stdarg.h>
7	7	#include <stdio.h>
	8	#include <wchar.h>
8	9
9	10	#include "mem.h"
10	11	#include "scan.h"
11	12	#include "report.h"
	13	#include "utf8.h"
12	14
13	15	#include "type.h"
14	16	#include "symbol.h"

41	43	int i;
42	44
43	45	if (sc != NULL) {
44		fprintf(rfile, "%s (line %d, column %d, token '%s'): ",
	46	fprintf(rfile, "%s (line %d, column %d, token '",
45	47	rtype == REPORT_ERROR ? "Error" : "Warning",
46		sc->lino, sc->columno, sc->token);
	48	sc->lino, sc->columno);
	49	fputsu8(rfile, sc->token);
	50	fprintf(rfile, "'): ");
47	51	} else {
48	52	fprintf(rfile, "%s (line ?, column ?, token ?): ",
49	53	rtype == REPORT_ERROR ? "Error" : "Warning");

61	65	symbol_print(rfile, va_arg(args, struct symbol *));
62	66	break;
63	67	case 's':
64		fprintf(stderr, "%s", va_arg(args, char *));
	68	fprintf(rfile, "%s", va_arg(args, char *));
	69	break;
	70	case 'w':
	71	fputsu8(rfile, va_arg(args, wchar_t *));
65	72	break;
66	73	case 'd':
67		fprintf(stderr, "%d", va_arg(args, int));
	74	fprintf(rfile, "%d", va_arg(args, int));
68	75	break;
69	76	}
70	77	} else {

-0

src/lib/report.h less more

7	7	#define __REPORT_H_
8	8
9	9	#include <stdio.h>
	10	#include <wchar.h>
10	11
11	12	struct scan_st;
12	13

+74

-51

src/lib/scan.c less more

7	7	#include <stdarg.h>
8	8	#include <stdlib.h>
9	9	#include <string.h>
	10	#include <wchar.h>
10	11
11	12	#include "mem.h"
12	13	#include "scan.h"
13	14	#include "report.h"
	15	#include "utf8.h"
14	16
15	17	struct scan_st *
16	18	scan_open(char *filename)

18	20	struct scan_st *sc;
19	21
20	22	sc = bhuna_malloc(sizeof(struct scan_st));
21		sc->token = (char )bhuna_malloc(256 sizeof(char));
	23	sc->token = (wchar_t )bhuna_malloc(256 sizeof(wchar_t));
22	24
23	25	if ((sc->in = fopen(filename, "r")) == NULL) {
24	26	bhuna_free(sc->token);

28	30
29	31	sc->lino = 1;
30	32	sc->columno = 1;
	33	sc->lastcol = 0;
31	34	scan(sc); /* prime the pump */
32	35
33	36	return(sc);

42	45	struct scan_st *sc;
43	46
44	47	sc = bhuna_malloc(sizeof(struct scan_st));
45		sc->token = bhuna_strdup(orig->token);
	48	sc->token = bhuna_wcsdup(orig->token);
	49
46	50	sc->in = NULL;
47	51	sc->lino = orig->lino;
48	52	sc->columno = orig->columno;
	53	sc->lastcol = orig->lastcol;
49	54
50	55	return(sc);
51	56	}

59	64	bhuna_free(sc);
60	65	}
61	66
62		void
63		scan_char(struct scan_st sc, char x)
64		{
65		*x = (char)getc(sc->in);
66		if (*x == '\n') {
	67	/*
	68	* x is not a string, it is a pointer to a single character.
	69	*/
	70	static void
	71	scan_char(struct scan_st sc, wchar_t x)
	72	{
	73	sc->lastcol = sc->columno;
	74	*x = fgetu8(sc->in);
	75	if (*x == L'\n') {
67	76	sc->columno = 1;
68	77	sc->lino++;
	78	} else if (*x == L'\t') {
	79	sc->columno++;
	80	while (sc->columno % 8 != 0)
	81	sc->columno++;
69	82	} else {
70	83	sc->columno++;
71	84	}
72	85	}
73	86
74		void
75		scan_putback(struct scan_st *sc, char x)
76		{
77		if (feof(sc->in)) return;
78		ungetc(x, sc->in);
79		if (x == '\n') {
80		sc->columno = 80; /* XXX heh */
	87	static void
	88	scan_putback(struct scan_st *sc, wchar_t x)
	89	{
	90	if (feof(sc->in))
	91	return;
	92	ungetu8(x, sc->in);
	93	sc->columno = sc->lastcol;
	94	if (x == L'\n')
81	95	sc->lino--;
82		} else {
83		sc->columno--;
84		}
85		}
86
87		void
88		scan(struct scan_st *sc)
89		{
90		char x;
	96	}
	97
	98	static void
	99	real_scan(struct scan_st *sc)
	100	{
	101	wchar_t x;
91	102	int i = 0;
92	103
93		sc->token[0] = '\0';
	104	sc->token[0] = L'\0';
94	105	if (feof(sc->in)) {
95	106	sc->type = TOKEN_EOF;
96	107	return;

101	112	/* Skip whitespace. */
102	113
103	114	top:
104		while (isspace(x) && !feof(sc->in)) {
	115	while (iswspace(x) && !feof(sc->in)) {
105	116	scan_char(sc, &x);
106	117	}
107	118
108	119	/* Skip comments. */
109	120
110		if (x == '/') {
	121	if (x == L'/') {
111	122	scan_char(sc, &x);
112		if (x == '/') {
113		while (x != '\n' && !feof(sc->in)) {
	123	if (x == L'/') {
	124	while (x != L'\n' && !feof(sc->in)) {
114	125	scan_char(sc, &x);
115	126	}
116	127	goto top;
117	128	} else {
118	129	scan_putback(sc, x);
119		x = '/';
	130	x = L'/';
120	131	/* falls through to the bottom of scan() */
121	132	}
122	133	}
123	134
124	135	if (feof(sc->in)) {
125		sc->token[0] = '\0';
	136	sc->token[0] = L'\0';
126	137	sc->type = TOKEN_EOF;
127	138	return;
128	139	}

131	142	* Scan decimal numbers. Must start with a
132	143	* digit (not a sign or decimal point.)
133	144	*/
134		if (isdigit(x)) {
135		while ((isdigit(x) \|\| x == '.') && !feof(sc->in)) {
	145	if (iswdigit(x)) {
	146	while ((iswdigit(x) \|\| x == L'.') && !feof(sc->in)) {
136	147	sc->token[i++] = x;
137	148	scan_char(sc, &x);
138	149	}
139	150	scan_putback(sc, x);
140		sc->token[i] = 0;
	151	sc->token[i] = L'\0';
141	152	sc->type = TOKEN_NUMBER;
142	153	return;
143	154	}

145	156	/*
146	157	* Scan quoted strings.
147	158	*/
148		if (x == '"') {
	159	if (x == L'"') {
149	160	scan_char(sc, &x);
150		while (x != '"' && !feof(sc->in) && i < 255) {
151		sc->token[i++] = x;
152		scan_char(sc, &x);
153		}
154		sc->token[i] = 0;
	161	while (x != L'"' && !feof(sc->in) && i < 255) {
	162	sc->token[i++] = x;
	163	scan_char(sc, &x);
	164	}
	165	sc->token[i] = L'\0';
155	166	sc->type = TOKEN_QSTRING;
156	167	return;
157	168	}

159	170	/*
160	171	* Scan alphanumeric ("bareword") tokens.
161	172	*/
162		if (isalpha(x) \|\| x == '_') {
163		while ((isalpha(x) \|\| isdigit(x) \|\| x == '_') && !feof(sc->in)) {
	173	if (iswalpha(x) \|\| x == L'_') {
	174	while ((iswalpha(x) \|\| iswdigit(x) \|\| x == L'_') && !feof(sc->in)) {
164	175	sc->token[i++] = x;
165	176	scan_char(sc, &x);
166	177	}
167	178	scan_putback(sc, x);
168		sc->token[i] = 0;
	179	sc->token[i] = L'\0';
169	180	sc->type = TOKEN_BAREWORD;
170	181	return;
171	182	}

173	184	/*
174	185	* Scan multi-character symbols.
175	186	*/
176		if (x == '>' \|\| x == '<' \|\| x == '=' \|\| x == '!') {
177		while ((x == '>' \|\| x == '<' \|\| x == '=' \|\| x == '!') &&
	187	if (x == L'>' \|\| x == L'<' \|\| x == L'=' \|\| x == L'!') {
	188	while ((x == L'>' \|\| x == L'<' \|\| x == L'=' \|\| x == L'!') &&
178	189	!feof(sc->in) && i < 255) {
179	190	sc->token[i++] = x;
180	191	scan_char(sc, &x);
181	192	}
182		sc->token[i] = '\0';
	193	scan_putback(sc, x);
	194	sc->token[i] = L'\0';
183	195	sc->type = TOKEN_SYMBOL;
184	196	return;
185	197	}

193	205	}
194	206
195	207	void
196		scan_expect(struct scan_st sc, char x)
197		{
198		if (!strcmp(sc->token, x)) {
	208	scan(struct scan_st *sc)
	209	{
	210	real_scan(sc);
	211	/*
	212	printf("scanned -> ");
	213	fputsu8(stdout, sc->token);
	214	printf("\n");
	215	*/
	216	}
	217
	218	void
	219	scan_expect(struct scan_st sc, wchar_t x)
	220	{
	221	if (wcscmp(sc->token, x) == 0) {
199	222	scan(sc);
200	223	} else {
201		report(REPORT_ERROR, sc, "Expected '%s'", x);
202		}
203		}
	224	report(REPORT_ERROR, sc, "Expected '%w'", x);
	225	}
	226	}

-5

src/lib/scan.h less more

0	0	/*
1	1	* scan.h
2	2	* Lexical scanner structures and prototypes for Bhuna.
3		* $Id: scan.h 54 2004-04-23 22:51:09Z catseye $
	3	* $Id$
4	4	*/
5	5
6	6	#ifndef __SCAN_H_
7	7	#define __SCAN_H_
8	8
9	9	#include <stdio.h>
	10	#include <wchar.h>
10	11
11	12	#define TOKEN_EOF 0
12	13	#define TOKEN_NUMBER 1

16	17
17	18	struct scan_st {
18	19	FILE in; / file from which we are scanning */
19		char token; / text content of token we just scanned */
	20	wchar_t token; / text content of token we just scanned */
20	21	int type; /* type of token that was scanned */
21	22	int lino; /* current line number, 1-based */
22	23	int columno; /* current column number, 1-based */
	24	int lastcol; /* for putback */
23	25	};
24	26
25		#define tokeq(sc, x) (strcmp(sc->token, x) == 0)
26		#define tokne(sc, x) (strcmp(sc->token, x) != 0)
	27	#define tokeq(sc, x) (wcscmp(sc->token, x) == 0)
	28	#define tokne(sc, x) (wcscmp(sc->token, x) != 0)
27	29
28	30	extern struct scan_st scan_open(char );
29	31	extern struct scan_st scan_dup(struct scan_st );
30	32	extern void scan_close(struct scan_st *);
31	33	extern void scan(struct scan_st *);
32		extern void scan_expect(struct scan_st , char );
	34	extern void scan_expect(struct scan_st , wchar_t );
33	35
34	36	#endif /* !__SCAN_H_ */

+29

-16

src/lib/symbol.c less more

9	9	#include <stdio.h>
10	10	#include <stdlib.h>
11	11	#include <string.h>
	12	#include <wchar.h>
12	13
13	14	#include "mem.h"
14	15	#include "symbol.h"
15	16	#include "type.h"
16	17	#include "value.h"
	18	#include "utf8.h"
17	19
18	20	/* GLOBALS */
19	21

22	24	/* STATICS */
23	25
24	26	static struct symbol *
25		symbol_new(char *token, int kind)
	27	symbol_new(wchar_t *token, int kind)
26	28	{
27	29	struct symbol *sym;
28	30
29	31	sym = bhuna_malloc(sizeof(struct symbol));
30	32
31	33	if (token == NULL) {
32		asprintf(&sym->token, "%%%d", ++anon_counter);
	34	sym->token = bhuna_malloc(sizeof(wchar_t) * 4);
	35	sym->token[0] = L'%';
	36	sym->token[1] = (wchar_t)++anon_counter;
	37	sym->token[2] = L'\0';
33	38	} else {
34		sym->token = bhuna_strdup(token);
	39	sym->token = bhuna_wcsdup(token);
35	40	}
36	41
37	42	sym->kind = kind;
38	43	sym->in = NULL;
39	44	sym->index = -1;
40	45	sym->is_pure = 0;
	46	sym->is_const = 0;
41	47	sym->type = NULL;
42		sym->value = NULL;
	48	/sym->value = NULL;/
43	49	sym->builtin = NULL;
44	50
45	51	return(sym);

117	123	* If token == NULL, a new anonymous symbol is created.
118	124	*/
119	125