![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to sem.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / contrib / courier / compiler|
Return to sem.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / courier / compiler |
1.1 root 1: #ifndef lint
2: static char sccsid[] = "@(#)sem.c 4.1 (Berkeley) 7/3/83";
3: #endif
4:
5: #include "Courier.h"
6:
7: /*
8: * String allocation.
9: */
10: char *
11: copy(s)
12: char *s;
13: {
14: char *p;
15: extern char *malloc();
16:
17: if ((p = malloc(strlen(s) + 1)) == NULL) {
18: fprintf(stderr, "Out of string space.\n");
19: exit(1);
20: }
21: strcpy(p, s);
22: return (p);
23: }
24:
25: /*
26: * Object allocation.
27: */
28: struct object *
29: make(class, value)
30: enum class class;
31: int value;
32: {
33: struct object *o;
34:
35: o = New(struct object);
36: o->o_class = class;
37: switch (class) {
38: case O_TYPE:
39: o->o_type = New(struct type);
40: o->t_constr = (enum constr) value;
41: break;
42: case O_SYMBOL:
43: o->o_name = copy(value);
44: break;
45: case O_CONSTANT:
46: o->o_value = value;
47: break;
48: default:
49: yyerror("Internal error: bad object class %d", class);
50: exit(1);
51: }
52: return (o);
53: }
54:
55: /*
56: * Lisp operations.
57: */
58: list
59: cons(a, b)
60: list a, b;
61: {
62: list p;
63:
64: if ((p = New(struct cons)) == NIL) {
65: yyerror("Out of cons space.");
66: exit(1);
67: }
68: car(p) = a;
69: cdr(p) = b;
70: return (p);
71: }
72:
73: length(p)
74: list p;
75: {
76: int n;
77:
78: for (n = 0; p != NIL; p = cdr(p), n++)
79: ;
80: return (n);
81: }
82:
83: list
84: nconc(p, q)
85: list p, q;
86: {
87: list pp;
88:
89: pp = p;
90: if (p == NIL)
91: return (q);
92: while (cdr(p) != NIL)
93: p = cdr(p);
94: cdr(p) = q;
95: return (pp);
96: }
97:
98: struct object *
99: construct_type1(constructor, items)
100: enum constr constructor;
101: list items;
102: {
103: struct object *t;
104:
105: t = make(O_TYPE, constructor);
106: t->t_list = items;
107: return (t);
108: }
109:
110: struct object *
111: construct_type2(constructor, size, base)
112: enum constr constructor;
113: struct object *size, *base;
114: {
115: struct object *t;
116:
117: t = make(O_TYPE, constructor);
118: t->t_basetype = base;
119: t->t_size = size;
120: return (t);
121: }
122:
123: struct object *
124: construct_procedure(args, results, errors)
125: list args, results, errors;
126: {
127: struct object *t;
128:
129: t = make(O_TYPE, C_PROCEDURE);
130: t->t_args = args;
131: t->t_results = results;
132: t->t_errors = errors;
133: return (t);
134: }
135:
136: /*
137: * Look up the value corresponding to a member of an enumeration type.
138: * Print an error message if it's not found.
139: */
140: struct object *
141: designator_value(symbol, enumtype)
142: struct object *symbol, *enumtype;
143: {
144: list p;
145: char *name;
146:
147: name = symbol->o_name;
148: for (p = enumtype->t_list; p != NIL; p = cdr(p))
149: if (streq(name, name_of(car(car(p)))))
150: return ((struct object *) cdr(car(p)));
151: yyerror("%s not a member of specified enumeration type", name);
152: return (0);
153: }
154:
155: /*
156: * Construct a choice type.
157: * There are two ways a choice can be specified:
158: * with an explicit designator enumeration type,
159: * or implicitly by specifying values for each designator.
160: * Convert the second form into the first by creating
161: * an enumeration type on the fly.
162: */
163: struct object *
164: construct_choice(designator, candidates)
165: struct object *designator;
166: list candidates;
167: {
168: struct object *t;
169: list p, q, dlist;
170: int bad = 0;
171:
172: if (designator != 0) {
173: t = basetype(designator);
174: if (t->t_constr != C_ENUMERATION) {
175: yyerror("Designator type %s is not an enumeration type",
176: designator->o_name);
177: return (Unspecified_type);
178: }
179: /* check that designators don't specify values */
180: for (p = candidates; p != NIL; p = cdr(p))
181: for (q = car(car(p)); q != NIL; q = cdr(q)) {
182: if (cdr(car(q)) != NIL) {
183: yyerror("Value cannot be specified for designator %s",
184: name_of(car(car(q))));
185: bad = 1;
186: continue;
187: }
188: if (designator_value(car(car(q)), t) == 0) {
189: bad = 1;
190: continue;
191: }
192: }
193: } else {
194: /* check that designators do specify values */
195: dlist = NIL;
196: for (p = candidates; p != NIL; p = cdr(p))
197: for (q = car(car(p)); q != NIL; q = cdr(q)) {
198: if (cdr(car(q)) == NIL) {
199: yyerror("Value must be specified for designator %s",
200: name_of(car(car(q))));
201: bad = 1;
202: continue;
203: }
204: dlist = cons(car(q), dlist);
205: }
206: if (! bad)
207: designator = construct_type1(C_ENUMERATION, dlist);
208: }
209: if (bad)
210: return (Unspecified_type);
211: t = make(O_TYPE, C_CHOICE);
212: t->t_designator = designator;
213: t->t_candidates = candidates;
214: return (t);
215: }
216:
217: /*
218: * Symbol table management.
219: */
220: struct object *
221: lookup(symlist, symbol)
222: list symlist;
223: struct object *symbol;
224: {
225: char *name;
226: list p, q;
227:
228: name = symbol->o_name;
229: for (p = symlist; p != NIL; p = cdr(p)) {
230: q = car(p);
231: if (streq(name_of(car(q)), name))
232: return ((struct object *) cdr(q));
233: }
234: return (0);
235: }
236:
237: check_def(symbol)
238: struct object *symbol;
239: {
240: if (lookup(Values, symbol) == 0) {
241: yyerror("%s undefined", symbol->o_name);
242: return (0);
243: }
244: return (1);
245: }
246:
247: declare(symlist, name, value)
248: list *symlist;
249: struct object *name, *value;
250: {
251: if (lookup(*symlist, name) != 0) {
252: yyerror("%s redeclared", name->o_name);
253: return;
254: }
255: *symlist = cons(cons(name, value), *symlist);
256: }
257:
258: /*
259: * Find the underlying type of a type.
260: */
261: struct object *
262: basetype(type)
263: struct object *type;
264: {
265: while (type != 0 && class_of(type) == O_SYMBOL)
266: type = lookup(Values, type);
267: if (type == 0 || class_of(type) != O_TYPE) {
268: yyerror("Internal error: bad class in basetype\n");
269: exit(1);
270: }
271: return (type);
272: }
273:
274: /*
275: * Make sure a number is a valid constant for this type.
276: */
277: type_check(type, value)
278: struct object *type, *value;
279: {
280: struct object *t, *v;
281:
282: if (class_of(type) != O_SYMBOL)
283: return (type->t_constr == C_PROCEDURE ||
284: type->t_constr == C_ERROR);
285: /*
286: * Type is a symbol.
287: * Track down the actual type, and its closest name.
288: */
289: while (type != 0 && class_of(type) == O_SYMBOL) {
290: t = type;
291: type = lookup(Values, type);
292: }
293: if (type == 0 || class_of(type) != O_TYPE) {
294: yyerror("Internal error: bad class in type_check\n");
295: exit(1);
296: }
297: if (type->t_constr != C_PREDEF)
298: return (type->t_constr == C_PROCEDURE ||
299: type->t_constr == C_ERROR);
300: /*
301: * Here we know that t is either a type
302: * or a symbol defined as a predefined type.
303: * Now find the type of the constant, if possible.
304: * If it is just a number, we don't check any further.
305: */
306: if (class_of(value) == O_SYMBOL)
307: v = basetype(lookup(Types, value));
308: else
309: v = 0;
310: return ((t == Cardinal_type || t == LongCardinal_type ||
311: t == Integer_type || t == LongInteger_type ||
312: t == Unspecified_type) && (v == 0 || v == type));
313: }
314:
315: /*
316: * Debugging routines.
317: */
318: symtabs()
319: {
320: printf("Values:\n"); prsymtab(Values);
321: printf("Types:\n"); prsymtab(Types);
322: }
323:
324: prsymtab(symlist)
325: list symlist;
326: {
327: list p;
328: char *s;
329:
330: for (p = symlist; p != NIL; p = cdr(p)) {
331: switch (class_of(cdr(car(p)))) {
332: case O_TYPE:
333: s = "type"; break;
334: case O_CONSTANT:
335: s = "constant"; break;
336: case O_SYMBOL:
337: s = "symbol"; break;
338: default:
339: s = "unknown class"; break;
340: }
341: printf("%s = [%s]\n", name_of(car(car(p))), s);
342: }
343: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.