git @ Cat's Eye Technologies Bhuna / rel_0_7
Import of Bhuna 0.7 sources. catseye 9 years ago
56 changed file(s) with 2072 addition(s) and 1364 deletion(s). Raw diff Collapse all Expand all
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
2323 T_Push = T[1]
2424 T_Pop = T[2]
2525
26 T_Push 23
26 // T_Push 23
2727
28 Q_Push 15
29 Print Q_Pop(), EoL
28 // Q_Push 15
29 // Print Q_Pop(), EoL
3030
31 T_Push 71
32 Print T_Pop(), " ", T_Pop(), EoL
31 // T_Push 71
32 // Print T_Pop(), " ", T_Pop(), EoL
3333
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
0 I = 0
1 while I < 100000 {
2 L= [I, atom]
3 Print L, EoL
4 I = I + 1
5 }
0 D = 7
1 F = 0
2
3 if D > 0 F = 8 else G = 9
4
5 Print F, EoL
44 ( cd modules && make strip )
55 ( cd driver && make strip )
66
7 static:
8 ( cd driver && make static )
9
710 .include <bsd.subdir.mk>
1717
1818 .ifdef PROFILED
1919 CFLAGS+=-pg
20 .else
21 NOPROFILE=yes
2022 .endif
23
24 .ifdef STATIC
25 STATIC=-static
26 .else
27 STATIC=
28 .endif
44 all: bhuna
55
66 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
827
928 main.o: main.c
1029 gcc $(CFLAGS) -c main.c -o main.o
1818 #include "process.h"
1919 #include "icode.h"
2020
21 #ifdef POOL_VALUES
22 #include "pool.h"
23 #endif
24
2521 #ifdef DEBUG
2622 #define OPTS "cdgG:ilmnopsvy"
2723 #define RUN_PROGRAM run_program
4642 fprintf(stderr, " -g: trace garbage collection\n");
4743 #endif
4844 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");
5147 fprintf(stderr, " -l: trace bytecode generation (implies -x)\n");
5248 fprintf(stderr, " -m: trace virtual machine\n");
5349 fprintf(stderr, " -n: don't actually run program\n");
7470 int run_program = 1;
7571 int dump_symbols = 0;
7672 int dump_program = 0;
77 #endif
78 int make_icode = 0;
73 int dump_icode = 0;
74 #endif
7975
8076 #ifdef DEBUG
8177 setvbuf(stdout, NULL, _IOLBF, 0);
10298 case 'G':
10399 gc_trigger = atoi(optarg);
104100 break;
101 #ifdef DEBUG
105102 case 'i':
106 make_icode++;
107 break;
108 #ifdef DEBUG
103 dump_icode++;
104 break;
109105 case 'l':
110106 trace_gen++;
111107 break;
176172
177173 program = bhuna_malloc(16384);
178174
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
191186
192187 vm = vm_new(program, 16384);
193188 vm_set_pc(vm, program);
209204 symbol_table_free(stab);
210205 types_free();
211206 if (trace_valloc > 0) {
207 /*
212208 value_dump_global_table();
209 */
213210 printf("Created: %8d\n", num_vars_created);
214211 printf("Cached: %8d\n", num_vars_cached);
215212 printf("Freed: %8d\n", num_vars_freed);
00 LIB= bhuna
11
22 SRCS= report.c \
3 scan.c parse.c \
3 utf8.c scan.c parse.c \
44 symbol.c ast.c \
55 type.c \
66 mem.c pool.c gc.c \
1515 NOMAN= y
1616
1717 # DESTDIR=/usr/local/sbin
18 strip: libbhuna.so.0
18 strip: libbhuna.so.0 libbhuna.a
1919 strip libbhuna.so.0
2020 ls -lah libbhuna.so.0
2121
2222 SHLIB_MAJOR=0
23 NOPROFILE=yes
2423 USELIBDIR=/usr/local/lib
2524 USESHLIBDIR=/usr/local/lib
2625
2323 struct activation *a;
2424
2525 a = bhuna_malloc(sizeof(struct activation) +
26 sizeof(struct value *) * size);
26 sizeof(struct value) * size);
2727 #ifdef BZERO
2828 bzero(a, sizeof(struct activation) +
29 sizeof(struct value *) * size);
29 sizeof(struct value) * size);
3030 #endif
3131 a->size = size;
3232 a->admin = 0;
6262 a = activation_new_on_heap(size, caller, enclosing);
6363 #else
6464 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;
6666 if (vm->astack_ptr > vm->astack_hi)
6767 vm->astack_hi = vm->astack_ptr;
6868
113113 #endif
114114
115115 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
121121 activation_get_value(struct activation *a, int index, int upcount)
122122 {
123123 assert(a != NULL);
128128 #ifdef DEBUG
129129 assert(index < a->size);
130130 #endif
131 return(((struct value **)((char *)a + sizeof(struct activation)))[index]);
131 return(VALARY(a, index));
132132 }
133133
134134 void
135135 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 {
140138 assert(a != NULL);
141139 for (; upcount > 0; upcount--) {
142140 a = a->enclosing;
151149 */
152150 assert(index < a->size);
153151 #endif
152 /*
154153 v->refcount++;
155 d = VALARY(a, index);
156 if (d != NULL)
157 d->refcount--;
154 VALARY(a, index)->refcount--;
155 */
158156 VALARY(a, index) = v;
159157 }
160158
161159 void
162160 activation_initialize_value(struct activation *a, int index,
163 struct value *v)
161 struct value v)
164162 {
165163 assert(a != NULL);
166164 assert(index < a->size);
183181 if (detail > 0) {
184182 for (i = 0; i < a->size; i++) {
185183 printf(" ");
186 if (VALARY(a, i) != NULL && VALARY(a, i)->type == VALUE_CLOSURE) {
184 if (VALARY(a, i).type == VALUE_CLOSURE) {
187185 printf("(closure) ");
188186 } else {
189187 value_print(VALARY(a, i));
0 struct value;
0 #include "value.h"
1
12 struct vm;
23
34 #define AR_ADMIN_MARKED 1
1617 struct activation *caller; /* recursively shallower activation record */
1718 struct activation *enclosing; /* lexically enclosing activation record */
1819 /*
19 struct value *value[];
20 struct value value[];
2021 */
2122 };
2223
2324 #define VALARY(a,i) \
24 ((struct value **)((char *)a + sizeof(struct activation)))[i]
25 ((struct value *)((unsigned char *)a + sizeof(struct activation)))[i]
2526
2627 struct activation *activation_new_on_heap(int, struct activation *, struct activation *);
2728 struct activation *activation_new_on_stack(int, struct activation *, struct activation *, struct vm *);
2829 void activation_free_from_heap(struct activation *);
2930 void activation_free_from_stack(struct activation *, struct vm *);
3031
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);
3435
3536 void activation_dump(struct activation *, int);
00 #include <stdio.h>
11 #include <stdlib.h>
22 #include <string.h>
3
3
44 #include "ast.h"
55 #include "list.h"
66 #include "value.h"
99 #include "vm.h"
1010 #include "type.h"
1111 #include "scan.h"
12 #include "utf8.h"
1213
1314 #include "symbol.h"
1415 #include "report.h"
5556 }
5657
5758 struct ast *
58 ast_new_value(struct value *v, struct type *t)
59 ast_new_value(struct value v, struct type *t)
5960 {
6061 struct ast *a;
6162
7980 ast_new_builtin(struct scan_st *sc, struct builtin *bi, struct ast *right)
8081 {
8182 struct ast *a;
82 struct type *t;
83 struct type *t, *tr;
8384 int unify = 0;
8485
8586 t = bi->ty();
8788
8889 #ifdef DEBUG
8990 if (trace_type_inference) {
90 printf("(builtin `%s`)*****\n", bi->name);
91 printf("(builtin `");
92 fputsu8(stdout, bi->name);
93 printf("`)*****\n");
9194 printf("type of args is: ");
92 type_print(stdout, right->datatype);
95 if (right != NULL)
96 type_print(stdout, right->datatype);
9397 printf("\ntype of builtin is: ");
9498 type_print(stdout, t);
9599 }
96100 #endif
97101
102 if (right == NULL)
103 tr = type_new(TYPE_VOID);
104 else
105 tr = right->datatype;
106
98107 unify = type_unify_crit(sc,
99 type_representative(t)->t.closure.domain,
100 right->datatype);
108 type_representative(t)->t.closure.domain, tr);
101109
102110 #ifdef DEBUG
103111 if (trace_type_inference) {
110118 * Fold constants.
111119 */
112120 if (bi->is_pure && ast_is_constant(right)) {
113 struct value *v = NULL;
121 struct value v;
114122 struct activation *ar;
115123 struct ast *g;
116124 int i = 0;
131139 activation_initialize_value(ar, i,
132140 g->u.arg.left->u.value.value);
133141 }
134 bi->fn(ar, &v);
142 v = bi->fn(ar);
135143 } else {
136144 a = NULL;
137145 }
199207 ast_new_arg(struct ast *left, struct ast *right)
200208 {
201209 struct ast *a;
210
211 if (left == NULL)
212 return(NULL);
202213
203214 a = ast_new(AST_ARG);
204215 a->u.arg.left = left;
221232 a = ast_new(AST_ROUTINE);
222233 a->u.routine.body = body;
223234
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);
225239
226240 #ifdef DEBUG
227241 if (trace_type_inference) {
271285 }
272286
273287 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)
275290 {
276291 struct ast *a;
277292 int unify;
286301 a = ast_new(AST_ASSIGNMENT);
287302 a->u.assignment.left = left;
288303 a->u.assignment.right = right;
304 a->u.assignment.defining = defining;
289305
290306 unify = type_unify_crit(sc, left->datatype, right->datatype);
291307
312328 {
313329 struct ast *a;
314330 int unify;
331 struct type *t;
315332
316333 a = ast_new(AST_CONDITIONAL);
317334 a->u.conditional.test = test;
327344 printf("(if)*****\n");
328345 printf("type of YES is: ");
329346 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 }
332351 }
333352 #endif
334353
338357 /* actually, either of these can be VOID, in which case, pick the other */
339358 /* unify = type_unify_crit(sc, yes->datatype, no->datatype); */
340359 /* 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);
343366
344367 #ifdef DEBUG
345368 if (trace_type_inference) {
562585 printf(")\n");
563586 break;
564587 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");
566591 ast_dump(a->u.builtin.right, indent + 1);
567592 for (i = 0; i < indent; i++) printf(" "); printf("}\n");
568593 break;
590615 for (i = 0; i < indent; i++) printf(" "); printf("}\n");
591616 break;
592617 case AST_ASSIGNMENT:
593 printf("{\n");
618 printf("(%s){\n", a->u.assignment.defining ?
619 "definition" : "application");
594620 ast_dump(a->u.assignment.left, indent + 1);
595621 ast_dump(a->u.assignment.right, indent + 1);
596622 for (i = 0; i < indent; i++) printf(" "); printf("}\n");
11 #define __AST_H_
22
33 #include "vm.h"
4 #include "value.h"
45
5 struct value;
66 struct builtin;
77 struct type;
88 struct symbol;
1616 };
1717
1818 struct ast_value {
19 struct value *value;
19 struct value value;
2020 };
2121
2222 struct ast_builtin {
4747 struct ast_assignment {
4848 struct ast *left; /* ISA var */
4949 struct ast *right; /* ISA apply/var */
50 int defining;
5051 };
5152
5253 struct ast_conditional {
100101 };
101102
102103 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 *);
104105 struct ast *ast_new_builtin(struct scan_st *, struct builtin *, struct ast *);
105106 struct ast *ast_new_apply(struct scan_st *, struct ast *, struct ast *, int);
106107 struct ast *ast_new_arg(struct ast *, struct ast *);
107108 struct ast *ast_new_routine(struct ast *);
108109 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);
110111 struct ast *ast_new_conditional(struct scan_st *, struct ast *, struct ast *, struct ast *);
111112 struct ast *ast_new_while_loop(struct scan_st *, struct ast *, struct ast *);
112113 struct ast *ast_new_retr(struct ast *);
119120 void ast_dump(struct ast *, int);
120121 char *ast_name(struct ast *);
121122
122 void ast_eval_init(void);
123 void ast_eval(struct ast *, struct value **);
124
125123 #endif /* !__AST_H_ */
00 #include <string.h>
11 #include <stdlib.h>
2 #include <wchar.h>
23
34 #include "mem.h"
45 #include "atom.h"
78 static int next_atom = 0;
89
910 int
10 atom_resolve(char *lexeme)
11 atom_resolve(wchar_t *lexeme)
1112 {
1213 struct atom_entry *ae;
1314
1415 /* find lexeme in atom table */
1516 for (ae = atom_entry_head; ae != NULL; ae = ae->next) {
16 if (strcmp(ae->lexeme, lexeme) == 0)
17 if (wcscmp(ae->lexeme, lexeme) == 0)
1718 return(ae->atom);
1819 }
1920 /* create new atom */
2021 ae = bhuna_malloc(sizeof(struct atom_entry));
2122 ae->next = atom_entry_head;
22 ae->lexeme = strdup(lexeme);
23 ae->lexeme = bhuna_wcsdup(lexeme);
2324 ae->atom = next_atom++;
2425 atom_entry_head = ae;
2526
55 #ifndef __ATOM_H_
66 #define __ATOM_H_
77
8 #include <wchar.h>
9
810 struct atom_entry {
911 struct atom_entry *next;
10 char *lexeme;
12 wchar_t *lexeme;
1113 int atom;
1214 };
1315
14 int atom_resolve(char *);
16 int atom_resolve(wchar_t *);
1517
1618 #endif /* !__ATOM_H_ */
00 #include <stdio.h>
11 #include <stdlib.h>
2 #include <wchar.h>
23
34 #include <dlfcn.h>
45
1011 #include "activation.h"
1112 #include "type.h"
1213 #include "symbol.h"
14 #include "utf8.h"
1315
1416 #include "ast.h"
1517 #include "vm.h"
2022 */
2123
2224 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}
4449 };
4550
46 void
47 builtin_print(struct activation *ar, struct value **q)
51 struct value
52 builtin_print(struct activation *ar)
4853 {
4954 int i;
50 /*struct list *l;*/
51 struct value *v = NULL;
55 struct value v;
5256
5357 for (i = 0; i < ar->size; i++) {
5458 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) {
6161 case VALUE_INTEGER:
62 printf("%d", v->v.i);
62 printf("%d", v.v.i);
6363 break;
6464 case VALUE_BOOLEAN:
65 printf("%s", v->v.b ? "true" : "false");
65 printf("%s", v.v.b ? "true" : "false");
6666 break;
6767 case VALUE_STRING:
68 printf("%s", v->v.s);
68 fputsu8(stdout, v.v.s->v.s);
6969 break;
7070 case VALUE_LIST:
7171 /*
7373 for (l = v->v.l; l != NULL; l = l->next) {
7474 */
7575
76 list_dump(v->v.l);
76 list_dump(v.v.s->v.l);
7777 break;
7878 case VALUE_ERROR:
79 printf("#ERR<%s>", v->v.e);
79 printf("#ERR<%s>", v.v.s->v.e);
8080 break;
8181 case VALUE_BUILTIN:
82 printf("#BIF<%08lx>", (unsigned long)v->v.bi);
82 printf("#BIF<%08lx>", (unsigned long)v.v.bi);
8383 break;
8484 case VALUE_CLOSURE:
85 closure_dump(v->v.k);
85 closure_dump(v.v.s->v.k);
8686 break;
8787 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);
8992 break;
9093 default:
91 printf("???unknown(%d)???", v->type);
94 printf("???unknown(%d)???", v.type);
9295 break;
9396 }
9497 }
95
96 *q = v;
98 return(value_null());
9799 }
98100
99101 /*** logical ***/
100102
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"));
136138 }
137139 }
138140
139141 /*** comparison ***/
140142
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");
216220 }
217221 }
218222
219223 /*** arithmetic ***/
220224
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);
239243
240244 #if 0
241245 printf("IN MUL, L = ");
245249 printf("\n");
246250 #endif
247251
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");
277281 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");
293297 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");
297301 }
298302 }
299303
300304 /*** list ***/
301305
302 void
303 builtin_list(struct activation *ar, struct value **v)
306 struct value
307 builtin_list(struct activation *ar)
304308 {
305309 int i;
306 struct value *x = NULL;
307
308 *v = value_new_list();
310 struct value v, x;
311
312 v = value_new_list();
309313
310314 for (i = ar->size - 1; i >= 0; i--) {
311315 x = activation_get_value(ar, i, 0);
312316 value_list_append(v, x);
313317 }
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);
322327 int count;
323328 struct list *li;
324329
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;
327332 /*
328333 * This is _EVIL_!
329334 */
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));
333337 } else {
334 *v = value_new_error("out of bounds");
338 return(value_new_error("out of bounds"));
335339 }
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++)
342345 li = li->next;
343346 if (li == NULL)
344 *v = value_new_error("out of bounds");
347 return value_new_error("out of bounds");
345348 else {
346 *v = li->value;
349 return li->value;
347350 }
348351 } 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);
359362 int count;
360363 struct list *li;
361364
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++)
368371 li = li->next;
369372 if (li == NULL)
370 *v = value_new_error("no such element");
373 return(value_new_error("no such element"));
371374 else {
372375 li->value = p;
373 *v = d;
376 return(d);
374377 }
375378 } 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)
382385 {
383386 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();
387390
388391 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"));
390393 } else {
391394 for (i = 0; i < ar->size; i += 2) {
392395 key = activation_get_value(ar, i, 0);
394397 value_dict_store(v, key, val);
395398 }
396399 }
400
401 return(v);
397402 }
398403
399404 /*** multiprocessing ***/
400405
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));
412460 }
413461
414462 /*** TYPES ***/
441489 return(
442490 type_new_closure(
443491 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)),
444503 type_new(TYPE_BOOLEAN)
445504 )
446505 );
519578 type_new(TYPE_VOID),
520579 type_new(TYPE_VOID)
521580 ),
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")
523618 )
524619 );
525620 }
529624 struct symbol *
530625 register_builtin(struct symbol_table *stab, struct builtin *b)
531626 {
532 struct value *v;
627 struct value v;
533628 struct symbol *sym;
534629
535630 v = value_new_builtin(b);
536631 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);
538633 sym->is_pure = b->is_pure;
539634 sym->builtin = b;
540635 sym->type = b->ty();
546641 register_std_builtins(struct symbol_table *stab)
547642 {
548643 int i;
549 struct value *v;
644 struct value v;
550645 struct symbol *sym;
551646
552647 for (i = 0; builtins[i].name != NULL; i++)
557652 /* And/or we should have "constant builtins" that have a va()
558653 function that returns the constant value, hmm.... */
559654
560 v = value_new_string("\n");
655 v = value_new_string(L"\n");
561656 value_deregister(v);
562 sym = symbol_define(stab, "EoL", SYM_KIND_VARIABLE, v);
657 sym = symbol_define(stab, L"EoL", SYM_KIND_VARIABLE, &v);
563658 sym->type = type_new(TYPE_STRING);
564659
565660 v = value_new_boolean(1);
566661 value_deregister(v);
567 sym = symbol_define(stab, "True", SYM_KIND_VARIABLE, v);
662 sym = symbol_define(stab, L"True", SYM_KIND_VARIABLE, &v);
568663 sym->type = type_new(TYPE_BOOLEAN);
569664
570665 v = value_new_boolean(0);
571666 value_deregister(v);
572 sym = symbol_define(stab, "False", SYM_KIND_VARIABLE, v);
667 sym = symbol_define(stab, L"False", SYM_KIND_VARIABLE, &v);
573668 sym->type = type_new(TYPE_BOOLEAN);
574669 }
575670
596691 }
597692
598693 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); */
600695 register_builtin(stab, &ext_builtins[i]);
601696 }
602697
00 #ifndef __BUILTIN_H_
11 #define __BUILTIN_H_
2
3 #include <wchar.h>
24
35 struct value;
46 struct activation;
79 struct symbol_table;
810
911 struct builtin {
10 char *name;
11 void (*fn)(struct activation *, struct value **);
12 wchar_t *name;
13 struct value (*fn)(struct activation *);
1214 struct type *(*ty)(void);
1315 int arity;
16 int retval;
1417 int is_pure;
1518 int is_const;
1619 int index;
3639 #define INDEX_BUILTIN_STORE 17
3740 #define INDEX_BUILTIN_DICT 18
3841 #define INDEX_BUILTIN_SPAWN 19
42 #define INDEX_BUILTIN_SEND 20
43 #define INDEX_BUILTIN_RECV 21
44 #define INDEX_BUILTIN_SELF 22
3945
4046 #define INDEX_BUILTIN_LAST 127
4147
4248 extern struct builtin builtins[];
4349
44 void builtin_print(struct activation *, struct value **);
50 struct value builtin_print(struct activation *);
4551
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 *);
4955
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 *);
5662
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 *);
6268
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 *);
6672
67 void builtin_dict(struct activation *, struct value **);
73 struct value builtin_dict(struct activation *);
6874
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 *);
7079
7180 struct type *btype_print(void);
7281 struct type *btype_unary_logic(void);
7382 struct type *btype_binary_logic(void);
83 struct type *btype_equality(void);
7484 struct type *btype_compare(void);
7585 struct type *btype_arith(void);
7686 struct type *btype_list(void);
7787 struct type *btype_fetch(void);
7888 struct type *btype_store(void);
7989 struct type *btype_dict(void);
90
8091 struct type *btype_spawn(void);
92 struct type *btype_send(void);
93 struct type *btype_recv(void);
94 struct type *btype_self(void);
8195
8296 struct symbol *register_builtin(struct symbol_table *, struct builtin *);
8397 void register_std_builtins(struct symbol_table *);
111111 * by Aho, Sethi, & Ullman (a.k.a. "The Dragon Book", 2nd edition.)
112112 */
113113 static size_t
114 hashpjw(struct value *key, size_t table_size) {
114 hashpjw(struct value key, size_t table_size) {
115115 char *p;
116116 unsigned long int h = 0, g;
117117
120120 * This is naff... for certain values this will work.
121121 * For others, it won't...
122122 */
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++) {
127127 h = (h << 4) + (*p);
128128 if ((g = h & 0xf0000000))
129129 h = (h ^ (g >> 24)) ^ g;
139139 * Create a new bucket (not called directly by client code.)
140140 */
141141 static struct chain *
142 chain_new(struct value *key, struct value *value)
142 chain_new(struct value key, struct value value)
143143 {
144144 struct chain *c;
145145
157157 * chain link itself if such a key exists (or NULL if it could not be found.)
158158 */
159159 static void
160 dict_locate(struct dict *d, struct value *key,
160 dict_locate(struct dict *d, struct value key,
161161 size_t *b_index, struct chain **c)
162162 {
163163 *b_index = hashpjw(key, d->num_buckets);
172172 /*
173173 * Retrieve a value from a dictionary, given its key.
174174 */
175 struct value *
176 dict_fetch(struct dict *d, struct value *k)
175 struct value
176 dict_fetch(struct dict *d, struct value k)
177177 {
178178 struct chain *c;
179179 size_t i;
182182 if (c != NULL) {
183183 return(c->value);
184184 } else {
185 return(NULL);
185 return(value_null());
186186 }
187187 }
188188
190190 * Insert a value into a dictionary.
191191 */
192192 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)
194194 {
195195 struct chain *c;
196196 size_t i;
208208 }
209209
210210 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;
214214
215215 v = dict_fetch(d, key);
216 return(v != NULL);
216 return(v.type != VALUE_NULL);
217217 }
218218
219219 /*
248248 return(d->cursor == NULL);
249249 }
250250
251 struct value *
251 struct value
252252 dict_getkey(struct dict *d)
253253 {
254254 if (d->cursor == NULL) {
255 return(NULL);
255 return(value_null());
256256 } else {
257257 /* XXX grab? */
258258 return(d->cursor->key);
66 #ifndef __DICT_H_
77 #define __DICT_H_
88
9 struct value;
9 #include "value.h"
1010
1111 struct dict {
1212 struct chain **bucket;
1717
1818 struct chain {
1919 struct chain *next;
20 struct value *key;
21 struct value *value;
20 struct value key;
21 struct value value;
2222 };
2323
2424 struct dict *dict_new(void);
2525 struct dict *dict_dup(struct dict *);
2626 void dict_free(struct dict *);
2727
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);
3131
3232 void dict_rewind(struct dict *);
3333 int dict_eof(struct dict *);
34 struct value *dict_getkey(struct dict *);
34 struct value dict_getkey(struct dict *);
3535 void dict_next(struct dict *);
3636
3737 size_t dict_size(struct dict *);
1212 #include "vm.h"
1313 #include "process.h"
1414
15 #ifdef POOL_VALUES
16 #include "pool.h"
17 #endif
18
1915 #ifdef DEBUG
2016 extern int trace_gc;
2117 #endif
2521
2622 extern struct activation *a_head;
2723
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;
3425
3526 /*
3627 * Garbage collector. Not a cheesy little reference counter, but
4435 static void activation_mark(struct activation *a);
4536
4637 static void
47 value_mark(struct value *v)
38 value_mark(struct value v)
4839 {
4940 struct list *l;
5041
51 if (v == NULL || v->admin & ADMIN_MARKED) /* || v->admin & ADMIN_PERMANENT) */
42 if (!(v.type & VALUE_STRUCTURED) || v.v.s->admin & ADMIN_MARKED)
5243 return;
5344
5445 #ifdef DEBUG
5950 }
6051 #endif
6152
62 v->admin |= ADMIN_MARKED;
63 switch (v->type) {
53 v.v.s->admin |= ADMIN_MARKED;
54 switch (v.type) {
6455 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) {
6657 value_mark(l->value);
6758 }
6859 break;
6960 case VALUE_CLOSURE:
70 activation_mark(v->v.k->ar);
61 activation_mark(v.v.s->v.k->ar);
7162 break;
7263 case VALUE_DICT:
7364 /* XXX for each key in v->v.d, value_mark(d[k]) */
121112 struct process *p;
122113 struct activation *a, *a_next;
123114 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;
132118
133119 /*
134120 * Mark...
162148
163149 a_head = ta_head;
164150
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;
199157 } else {
200158 #ifdef DEBUG
201159 if (trace_gc > 1) {
202160 printf("[GC] FOUND UNREACHABLE VALUE ");
203 value_print(v);
161 /*value_print(v);*/
204162 printf("\n");
205163 }
206164 #endif
207 value_free(v);
165 s_value_free(sv);
208166 }
209167 }
210168
211 v_head = tv_head;
212 #endif
213 #ifdef POOL_VALUES
214 clean_pools();
215 #endif
169 sv_head = tsv_head;
216170 }
1515
1616 static vm_label_t gptr, program;
1717
18 /*
1819 vm_label_t patch_stack[4096];
1920 int psp = 0;
2021
2122 unsigned char *last_ins_at = NULL;
2223 unsigned char last_ins = 255;
24 */
25
26 #if 0
2327
2428 /*** backpatcher ***/
2529
276280 assert(a->u.assignment.left != NULL);
277281 assert(a->u.assignment.left->type == AST_LOCAL);
278282 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 }
282293 break;
283294 case AST_CONDITIONAL:
284295 ast_gen_r(a->u.conditional.test);
316327 *gptr++ = INSTR_HALT;
317328 }
318329
330 #else
331 #define gen(x) *gptr++ = x
332 #endif
333
319334 /*** gen VM from iprogram ***/
320335
321336 void
338353 gen(ic->opcode);
339354 switch (ic->opcode) {
340355 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;
343358 }
344 *(((struct value **)gptr)++) = ic->operand.value;
359 *(((struct value *)gptr)++) = ic->operand.value;
345360 break;
346361 case INSTR_PUSH_LOCAL:
347362 case INSTR_POP_LOCAL:
348363 case INSTR_COW_LOCAL:
364 case INSTR_INIT_LOCAL:
349365 *gptr++ = (unsigned char)ic->operand.local.index;
350366 *gptr++ = (unsigned char)ic->operand.local.upcount;
351367 break;
88 #include "builtin.h"
99 #include "value.h"
1010 #include "closure.h"
11 #include "utf8.h"
1112
1213 /*** iprograms ***/
1314
101102 }
102103
103104 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)
105106 {
106107 struct icode *ic;
107108
194195
195196 /*************** intermediate code generator ****************/
196197
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
212198 static void
213199 ast_gen_r(struct iprogram *ip, struct ast *a)
214200 {
215201 struct icode *ic1, *ic2, *ic3, *ic4;
216 struct value *v;
202 struct value v;
217203
218204 if (a == NULL)
219205 return;
226212 break;
227213 case AST_VALUE:
228214 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) {
230216 icode_new(ip, INSTR_SET_ACTIVATION);
231217 ic1 = icode_new(ip, INSTR_JMP);
232218 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);
235221 icode_new(ip, INSTR_RET);
236222 ic3 = icode_new(ip, INSTR_NOP);
237223 icode_set_branch(ic1, ic3);
273259 assert(a->u.assignment.left != NULL);
274260 assert(a->u.assignment.left->type == AST_LOCAL);
275261 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 }
279271 break;
280272 case AST_CONDITIONAL:
281273 ast_gen_r(ip, a->u.conditional.test);
382374 printf("POP_LOCAL (%d,%d)",
383375 ic->operand.local.index, ic->operand.local.upcount);
384376 break;
377 case INSTR_INIT_LOCAL:
378 printf("INIT_LOCAL (%d,%d)",
379 ic->operand.local.index, ic->operand.local.upcount);
380 break;
385381 case INSTR_JZ:
386382 printf("JZ %s", icode_addr(ic->operand.branch, program));
387383 break;
404400 printf("COW_LOCAL (%d,%d)",
405401 ic->operand.local.index, ic->operand.local.upcount);
406402 case INSTR_EXTERNAL:
407 printf("EXTERNAL `%s'", ic->operand.builtin->name);
403 printf("EXTERNAL `"),
404 fputsu8(stdout, ic->operand.builtin->name);
405 printf("'");
408406 break;
409407 case INSTR_NOP:
410408 printf("NOP");
411409 break;
412410
413411 default:
414 printf("BUILTIN `%s'", builtins[ic->opcode].name);
412 printf("BUILTIN `");
413 fputsu8(stdout, builtins[ic->opcode].name);
414 printf("'");
415415 }
416416 printf("\n");
417417 }
527527 for (ic = ip->head; ic != NULL; ic = ic_next) {
528528 ic_next = ic->next;
529529 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) {
532532 case 0:
533533 ic->opcode = INSTR_PUSH_ZERO;
534534 break;
542542 }
543543 }
544544 }
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 }
66
77 #include "vm.h"
88
9 struct value;
9 #include "value.h"
10
1011 struct ast;
1112 struct builtin;
1213
2021 int index;
2122 int upcount;
2223 } local;
23 struct value *value;
24 struct value value;
2425 struct icode *branch;
2526 struct builtin *builtin;
2627 };
5354
5455 struct icode *icode_new(struct iprogram *, int);
5556 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);
5758 struct icode *icode_new_builtin(struct iprogram *, struct builtin *);
5859
5960 void icode_free(struct iprogram *, struct icode *);
6667 void iprogram_eliminate_dead_code(struct iprogram *);
6768 void iprogram_optimize_tail_calls(struct iprogram *);
6869 void iprogram_optimize_push_small_ints(struct iprogram *);
70 void iprogram_eliminate_useless_jumps(struct iprogram *);
6971
7072 void referrer_unwire(struct icode *, struct icode *);
7173 void referrers_rewire(struct icode *, struct icode *);
66 #include "value.h"
77
88 void
9 list_cons(struct list **l, struct value *v)
9 list_cons(struct list **l, struct value v)
1010 {
1111 struct list *n;
1212
1919 struct list *
2020 list_dup(struct list *l)
2121 {
22 struct list *n;
22 struct list *n = l;
2323
2424 /* ... XXX ... */
2525
5555 * Full comparison used here.
5656 */
5757 int
58 list_contains(struct list *l, struct value *v)
58 list_contains(struct list *l, struct value v)
5959 {
6060 while (l != NULL) {
6161 if (value_equal(l->value, v))
77
88 #include <sys/types.h>
99
10 struct value;
10 #include "value.h"
1111
1212 struct list {
1313 struct list *next;
14 struct value *value;
14 struct value value;
1515 };
1616
17 void list_cons(struct list **, struct value *);
17 void list_cons(struct list **, struct value);
1818 struct list *list_dup(struct list *);
1919 void list_free(struct list **);
2020 size_t list_length(struct list *);
21 int list_contains(struct list *, struct value *);
21 int list_contains(struct list *, struct value);
2222
2323 void list_dump(struct list *);
2424
66 #include <assert.h>
77 #include <stdlib.h>
88 #include <string.h>
9 #include <wchar.h>
910
1011 void *
1112 bhuna_malloc(size_t size, char *what)
3233 return(ptr);
3334 }
3435
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
3547 void
3648 bhuna_free(void *ptr)
3749 {
77 #define __MEM_H_
88
99 #include <sys/types.h>
10 #include <wchar.h>
1011
12 wchar_t *bhuna_wcsdup(wchar_t *);
1113 #ifdef DEBUG
1214 void *bhuna_malloc(size_t);
1315 char *bhuna_strdup(char *);
88 #include <stdio.h>
99 #include <stdlib.h>
1010 #include <string.h>
11 #include <wchar.h>
1112
1213 #include "scan.h"
1314 #include "parse.h"
1819 #include "type.h"
1920 #include "report.h"
2021 #include "builtin.h"
22 #include "utf8.h"
2123
2224 #define VAR_LOCAL 0
2325 #define VAR_GLOBAL 1
3234 * Convenience function to create AST for a named arity-2 function call.
3335 */
3436 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,
3638 struct ast *left, struct ast *right)
3739 {
3840 struct symbol *sym;
3941 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 }
4053
4154 right = ast_new_arg(right, NULL);
4255 left = ast_new_arg(left, right);
4356
44 sym = symbol_lookup(stab, name, VAR_GLOBAL);
57 sym = symbol_lookup(stab, tname, VAR_GLOBAL);
4558 assert(sym != NULL && sym->builtin != NULL);
4659 a = ast_new_builtin(sc, sym->builtin, left);
4760
4962 }
5063
5164 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,
5366 struct ast *left, struct ast *index, struct ast *right)
5467 {
5568 struct symbol *sym;
95108
96109 assert(*istab != NULL);
97110
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) {
101114 a = ast_new_statement(a,
102115 parse_statement(sc, *istab, &retr, cc));
103116 }
104 scan_expect(sc, "}");
117 scan_expect(sc, L"}");
105118 } else {
106119 a = parse_statement(sc, *istab, &retr, cc);
107120 }
122135 struct symbol_table *istab;
123136 struct ast *a, *l, *r;
124137
125 if (tokeq(sc, "{")) {
138 if (tokeq(sc, L"{")) {
126139 istab = symbol_table_new(stab, 0);
127140 a = parse_block(sc, stab, &istab, cc);
128 } else if (tokeq(sc, "if")) {
141 } else if (tokeq(sc, L"if")) {
129142 scan(sc);
130143 a = parse_expr(sc, stab, 0, NULL, cc);
131144 istab = symbol_table_new(stab, 0);
132145 l = parse_block(sc, stab, &istab, cc);
133 if (tokeq(sc, "else")) {
146 if (tokeq(sc, L"else")) {
134147 scan(sc);
135148 istab = symbol_table_new(stab, 0);
136149 r = parse_block(sc, stab, &istab, cc);
138151 r = NULL;
139152 }
140153 a = ast_new_conditional(sc, a, l, r);
141 } else if (tokeq(sc, "while")) {
154 } else if (tokeq(sc, L"while")) {
142155 scan(sc);
143156 l = parse_expr(sc, stab, 0, NULL, cc);
144157 istab = symbol_table_new(stab, 0);
145158 r = parse_block(sc, stab, &istab, cc);
146159 a = ast_new_while_loop(sc, l, r);
147 } else if (tokeq(sc, "return")) {
160 } else if (tokeq(sc, L"return")) {
148161 scan(sc);
149162 a = parse_expr(sc, stab, 0, NULL, cc);
150163 a = ast_new_retr(a);
151164 *retr = 1;
152 } else if (tokeq(sc, "import")) {
165 } else if (tokeq(sc, L"import")) {
153166 scan(sc);
154167 if (sc->type == TOKEN_QSTRING) {
155 load_builtins(stab, sc->token);
168 /* XXX convert wchar_t -> char */
169 load_builtins(stab, (char *)sc->token);
156170 scan(sc);
157171 } else {
158172 report(REPORT_ERROR, sc, "Expected quoted string");
162176 int is_const = 0;
163177 int is_def = 0;
164178
165 while (tokeq(sc, "local") || tokeq(sc, "const")) {
179 while (tokeq(sc, L"local") || tokeq(sc, L"const")) {
166180 is_def = 1;
167 if (tokeq(sc, "local")) {
181 if (tokeq(sc, L"local")) {
168182 scan(sc);
169183 /* Not much, mere presence works. */
170 } else if (tokeq(sc, "const")) {
184 } else if (tokeq(sc, L"const")) {
171185 scan(sc);
172186 is_const = 1;
173187 }
186200 a = parse_command_or_assignment(sc, stab, cc);
187201 }
188202 }
189 if (tokeq(sc, ";"))
203 if (tokeq(sc, L";"))
190204 scan(sc);
191205 return(a);
192206 }
197211 {
198212 struct symbol *sym;
199213 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"=");
211219 r = parse_expr(sc, stab, 0, sym, cc);
212220 if (is_const) {
213221 if (r == NULL || r->type != AST_VALUE) {
219227 }
220228 return(NULL);
221229 } else {
222 return(ast_new_assignment(sc, l, r));
230 return(ast_new_assignment(sc, l, r, 1));
223231 }
224232 }
225233
238246 * A[I][J] = K -> Store A[I], J, K
239247 * A[I][J][K] = L -> Store A[I][J], K, L
240248 */
241 while (tokeq(sc, "[") || tokeq(sc, ".")) {
242 if (tokeq(sc, "[")) {
249 while (tokeq(sc, L"[") || tokeq(sc, L".")) {
250 if (tokeq(sc, L"[")) {
243251 scan(sc);
244252 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"=")) {
247255 /*
248256 * It was the last one; this is an assigment.
249257 */
250258 scan(sc);
251259 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);
253261 return(a);
254 } else if (tokne(sc, "[") && tokne(sc, ".")) {
262 } else if (tokne(sc, L"[") && tokne(sc, L".")) {
255263 /*
256264 * It was the last one; this is a command.
257265 */
260268 /*
261269 * Still more to go.
262270 */
263 a = ast_new_call2("Fetch", sc, stab, a, l);
271 a = ast_new_call2(L"Fetch", sc, stab, a, l);
264272 }
265 } else if (tokeq(sc, ".")) {
273 } else if (tokeq(sc, L".")) {
266274 scan(sc);
267275 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);
269277 }
270278 }
271279
273281 * If the variable-expression was followed by an equals sign,
274282 * it's an assignment to an already-existing variable.
275283 */
276 if (tokeq(sc, "=")) {
277 if (sym->value != NULL) {
284 if (tokeq(sc, L"=")) {
285 if (sym->is_const) {
278286 report(REPORT_ERROR, sc, "Value not modifiable");
279287 } else {
280288 scan(sc);
281289 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);
283291 }
284292 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;
291293 }
292294
293295 /*
294296 * Otherwise, it's a command.
295297 */
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
296304 if (!type_is_possibly_routine(sym->type)) {
297305 report(REPORT_ERROR, sc, "Command application of non-routine variable");
298306 /*return(NULL);*/
299307 }
300308 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);
303311 /*return(NULL);*/
304312 }
305313
319327 struct ast *a, *b;
320328
321329 a = parse_expr(sc, stab, 0, excl, cc);
322 if (tokeq(sc, ",")) {
330 if (tokeq(sc, L",")) {
323331 scan(sc);
324332 b = parse_expr_list(sc, stab, excl, cc);
325333 } else {
328336 return(ast_new_arg(a, b));
329337 }
330338
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
331360 /* ------------------------- EXPRESSIONS ------------------------ */
332361
333362 int maxlevel = 3;
334363
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"" }
340369 };
341370
342371 struct ast *
345374 {
346375 struct ast *l, *r;
347376 int done = 0, i = 0;
348 char the_op[256];
377 wchar_t the_op[256];
349378
350379 if (level > maxlevel) {
351380 l = parse_primitive(sc, stab, excl, cc);
354383 l = parse_expr(sc, stab, level + 1, excl, cc);
355384 while (!done) {
356385 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++) {
358387 if (tokeq(sc, op[level][i])) {
359 strlcpy(the_op, sc->token, 256);
388 wcslcpy(the_op, sc->token, 256);
360389 scan(sc);
361390 done = 0;
362391 r = parse_expr(sc, stab, level + 1, excl, cc);
374403 struct symbol *excl, int *cc)
375404 {
376405 struct ast *a, *l, *r;
377 struct value *v;
406 struct value v;
378407 struct symbol *sym;
379408 struct symbol_table *istab;
380409
381 if (tokeq(sc, "(")) {
410 if (tokeq(sc, L"(")) {
382411 scan(sc);
383412 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")) {
386415 int my_cc = 0;
387416 int my_arity = 0;
388417 struct type *a_type = NULL;
393422 (*cc)++;
394423 scan(sc);
395424 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;
399428 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 {
414430 a_type = type_new(TYPE_VOID);
431 }
415432 a = parse_block(sc, stab, &istab, &my_cc);
416433 a = ast_new_routine(a);
417434 if (type_is_set(a->datatype) && type_set_contains_void(a->datatype)) {
421438 value_deregister(v);
422439 a = ast_new_value(v,
423440 type_new_closure(a_type, a->datatype));
424 } else if (tokeq(sc, "!")) {
441 } else if (tokeq(sc, L"!")) {
425442 scan(sc);
426443 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"[")) {
431448 scan(sc);
432449 v = value_new_list();
433450 value_deregister(v);
434451 a = ast_new_value(v, NULL); /* XXX list */
435 if (tokne(sc, "]")) {
452 if (tokne(sc, L"]")) {
436453 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);
438455 assert(sym->builtin != NULL);
439456 a = ast_new_builtin(sc, sym->builtin, l);
440457 }
441 scan_expect(sc, "]");
458 scan_expect(sc, L"]");
442459 } else if (sc->type == TOKEN_BAREWORD && isupper(sc->token[0])) {
443460 a = parse_var(sc, stab, &sym, VAR_GLOBAL, VAR_MUST_EXIST, NULL);
444461 if (sym == excl) {
445462 report(REPORT_ERROR, sc, "Initializer cannot refer to variable being defined");
446463 return(NULL);
447464 }
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"(")) {
450467 scan(sc);
451 if (tokne(sc, ")")) {
468 if (tokne(sc, L")")) {
452469 l = parse_expr_list(sc, stab, excl, cc);
453470 } else {
454471 l = NULL;
455472 }
456 scan_expect(sc, ")");
473 scan_expect(sc, L")");
457474
458475 if (!type_is_possibly_routine(sym->type)) {
459476 report(REPORT_ERROR, sc, "Function application of non-routine variable");
470487 } else {
471488 a = ast_new_apply(sc, a, l, sym->is_pure);
472489 }
473 } else if (tokeq(sc, "[")) {
490 } else if (tokeq(sc, L"[")) {
474491 scan(sc);
475492 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".")) {
479496 scan(sc);
480497 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);
482499 }
483500 }
484501 } else {
492509 parse_literal(struct scan_st *sc, struct symbol_table *stab)
493510 {
494511 struct ast *a;
495 struct value *v;
512 struct value v;
496513
497514 if (sc->type == TOKEN_BAREWORD && islower(sc->token[0])) {
498515 v = value_new_atom(atom_resolve(sc->token));
500517 a = ast_new_value(v, type_new(TYPE_ATOM));
501518 scan(sc);
502519 } else if (sc->type == TOKEN_NUMBER) {
503 v = value_new_integer(atoi(sc->token));
520 v = value_new_integer(wcstoi(sc->token));
504521 value_deregister(v);
505522 a = ast_new_value(v, type_new(TYPE_INTEGER));
506523 scan(sc);
540557 }
541558 scan(sc);
542559
543 if ((*sym)->value != NULL) {
560 if ((*sym)->is_const) {
544561 a = ast_new_value((*sym)->value, (*sym)->type);
545562 } else {
546563 a = ast_new_local(stab, (*sym));
77 #include "ast.h"
88 #include "activation.h"
99
10 #define TIMESLICE 4096
10 #define TIMESLICE 2048
11 // 4096
1112 extern int trace_scheduling;
1213
1314 struct process *current_process = NULL;
2425 p = bhuna_malloc(sizeof(struct process));
2526 p->vm = vm;
2627 p->number = procno++;
28 p->msg_head = NULL;
29 p->asleep = 0;
2730 p->next = run_head;
2831 p->prev = NULL;
2932 if (run_head != NULL)
6467 struct process *p;
6568
6669 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);
6871
6972 vm->current_ar = activation_new_on_heap(
7073 k->arity + k->locals, NULL, k->ar);
7982 }
8083
8184 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
82186 process_scheduler(void)
83187 {
84188 struct process *next;
107211 #endif
108212 process_free(current_process);
109213 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;
110221 case VM_TIME_EXPIRED:
111 case VM_WAITING:
112222 default:
113223 break;
114224 }
0 #ifndef __PROCESS_H_
1 #define __PROCESS_H_
2
3 #include "value.h"
4
05 struct vm;
16 struct closure;
27
38 struct process {
9 int asleep;
410 int number;
511 struct process *next;
612 struct process *prev;
713 struct vm *vm;
14 struct message *msg_head;
15 };
16
17 struct message {
18 struct message *next;
19 struct value payload;
820 };
921
1022 extern struct process *current_process;
1527 void process_free(struct process *);
1628 void process_scheduler(void);
1729 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
55
66 #include <stdarg.h>
77 #include <stdio.h>
8 #include <wchar.h>
89
910 #include "mem.h"
1011 #include "scan.h"
1112 #include "report.h"
13 #include "utf8.h"
1214
1315 #include "type.h"
1416 #include "symbol.h"
4143 int i;
4244
4345 if (sc != NULL) {
44 fprintf(rfile, "%s (line %d, column %d, token '%s'): ",
46 fprintf(rfile, "%s (line %d, column %d, token '",
4547 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, "'): ");
4751 } else {
4852 fprintf(rfile, "%s (line ?, column ?, token ?): ",
4953 rtype == REPORT_ERROR ? "Error" : "Warning");
6165 symbol_print(rfile, va_arg(args, struct symbol *));
6266 break;
6367 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 *));
6572 break;
6673 case 'd':
67 fprintf(stderr, "%d", va_arg(args, int));
74 fprintf(rfile, "%d", va_arg(args, int));
6875 break;
6976 }
7077 } else {
77 #define __REPORT_H_
88
99 #include <stdio.h>
10 #include <wchar.h>
1011
1112 struct scan_st;
1213
77 #include <stdarg.h>
88 #include <stdlib.h>
99 #include <string.h>
10 #include <wchar.h>
1011
1112 #include "mem.h"
1213 #include "scan.h"
1314 #include "report.h"
15 #include "utf8.h"
1416
1517 struct scan_st *
1618 scan_open(char *filename)
1820 struct scan_st *sc;
1921
2022 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));
2224
2325 if ((sc->in = fopen(filename, "r")) == NULL) {
2426 bhuna_free(sc->token);
2830
2931 sc->lino = 1;
3032 sc->columno = 1;
33 sc->lastcol = 0;
3134 scan(sc); /* prime the pump */
3235
3336 return(sc);
4245 struct scan_st *sc;
4346
4447 sc = bhuna_malloc(sizeof(struct scan_st));
45 sc->token = bhuna_strdup(orig->token);
48 sc->token = bhuna_wcsdup(orig->token);
49
4650 sc->in = NULL;
4751 sc->lino = orig->lino;
4852 sc->columno = orig->columno;
53 sc->lastcol = orig->lastcol;
4954
5055 return(sc);
5156 }
5964 bhuna_free(sc);
6065 }
6166
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') {
6776 sc->columno = 1;
6877 sc->lino++;
78 } else if (*x == L'\t') {
79 sc->columno++;
80 while (sc->columno % 8 != 0)
81 sc->columno++;
6982 } else {
7083 sc->columno++;
7184 }
7285 }
7386
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')
8195 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;
91102 int i = 0;
92103
93 sc->token[0] = '\0';
104 sc->token[0] = L'\0';
94105 if (feof(sc->in)) {
95106 sc->type = TOKEN_EOF;
96107 return;
101112 /* Skip whitespace. */
102113
103114 top:
104 while (isspace(x) && !feof(sc->in)) {
115 while (iswspace(x) && !feof(sc->in)) {
105116 scan_char(sc, &x);
106117 }
107118
108119 /* Skip comments. */
109120
110 if (x == '/') {
121 if (x == L'/') {
111122 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)) {
114125 scan_char(sc, &x);
115126 }
116127 goto top;
117128 } else {
118129 scan_putback(sc, x);
119 x = '/';
130 x = L'/';
120131 /* falls through to the bottom of scan() */
121132 }
122133 }
123134
124135 if (feof(sc->in)) {
125 sc->token[0] = '\0';
136 sc->token[0] = L'\0';
126137 sc->type = TOKEN_EOF;
127138 return;
128139 }
131142 * Scan decimal numbers. Must start with a
132143 * digit (not a sign or decimal point.)
133144 */
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)) {
136147 sc->token[i++] = x;
137148 scan_char(sc, &x);
138149 }
139150 scan_putback(sc, x);
140 sc->token[i] = 0;
151 sc->token[i] = L'\0';
141152 sc->type = TOKEN_NUMBER;
142153 return;
143154 }
145156 /*
146157 * Scan quoted strings.
147158 */
148 if (x == '"') {
159 if (x == L'"') {
149160 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';
155166 sc->type = TOKEN_QSTRING;
156167 return;
157168 }
159170 /*
160171 * Scan alphanumeric ("bareword") tokens.
161172 */
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)) {
164175 sc->token[i++] = x;
165176 scan_char(sc, &x);
166177 }
167178 scan_putback(sc, x);
168 sc->token[i] = 0;
179 sc->token[i] = L'\0';
169180 sc->type = TOKEN_BAREWORD;
170181 return;
171182 }
173184 /*
174185 * Scan multi-character symbols.
175186 */
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'!') &&
178189 !feof(sc->in) && i < 255) {
179190 sc->token[i++] = x;
180191 scan_char(sc, &x);
181192 }
182 sc->token[i] = '\0';
193 scan_putback(sc, x);
194 sc->token[i] = L'\0';
183195 sc->type = TOKEN_SYMBOL;
184196 return;
185197 }
193205 }
194206
195207 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) {
199222 scan(sc);
200223 } else {
201 report(REPORT_ERROR, sc, "Expected '%s'", x);
202 }
203 }
224 report(REPORT_ERROR, sc, "Expected '%w'", x);
225 }
226 }
00 /*
11 * scan.h
22 * Lexical scanner structures and prototypes for Bhuna.
3 * $Id: scan.h 54 2004-04-23 22:51:09Z catseye $
3 * $Id$
44 */
55
66 #ifndef __SCAN_H_
77 #define __SCAN_H_
88
99 #include <stdio.h>
10 #include <wchar.h>
1011
1112 #define TOKEN_EOF 0
1213 #define TOKEN_NUMBER 1
1617
1718 struct scan_st {
1819 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 */
2021 int type; /* type of token that was scanned */
2122 int lino; /* current line number, 1-based */
2223 int columno; /* current column number, 1-based */
24 int lastcol; /* for putback */
2325 };
2426
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)
2729
2830 extern struct scan_st *scan_open(char *);
2931 extern struct scan_st *scan_dup(struct scan_st *);
3032 extern void scan_close(struct scan_st *);
3133 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 *);
3335
3436 #endif /* !__SCAN_H_ */
99 #include <stdio.h>
1010 #include <stdlib.h>
1111 #include <string.h>
12 #include <wchar.h>
1213
1314 #include "mem.h"
1415 #include "symbol.h"
1516 #include "type.h"
1617 #include "value.h"
18 #include "utf8.h"
1719
1820 /*** GLOBALS ***/
1921
2224 /*** STATICS ***/
2325
2426 static struct symbol *
25 symbol_new(char *token, int kind)
27 symbol_new(wchar_t *token, int kind)
2628 {
2729 struct symbol *sym;
2830
2931 sym = bhuna_malloc(sizeof(struct symbol));
3032
3133 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';
3338 } else {
34 sym->token = bhuna_strdup(token);
39 sym->token = bhuna_wcsdup(token);
3540 }
3641
3742 sym->kind = kind;
3843 sym->in = NULL;
3944 sym->index = -1;
4045 sym->is_pure = 0;
46 sym->is_const = 0;
4147 sym->type = NULL;
42 sym->value = NULL;
48 /*sym->value = NULL;*/
4349 sym->builtin = NULL;
4450
4551 return(sym);
117123 * If token == NULL, a new anonymous symbol is created.
118124 */
119125 struct symbol *
120 symbol_define(struct symbol_table *stab, char *token, int kind, struct value *v)
126 symbol_define(struct symbol_table *stab, wchar_t *token, int kind, struct value *v)
121127 {
122128 struct symbol *new_sym; <