Import of Bhuna 0.7 sources.
catseye
9 years ago
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 |
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 |
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 |
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 | } |
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 |
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 |
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 |
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 |
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> |
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 |
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 |
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); |
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 |
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)); |
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); |
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"); |
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_ */ |
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 |
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_ */ |
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 |
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 *); |
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); |
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 *); |
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 | } |
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; |
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 | } |
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 *); |
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)) |
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 |
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 | { |
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 *); |
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)); |
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 | } |
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 |
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 { |
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 |
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 | } |
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_ */ |
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 |