4.3BSD - /usr/src/new/courier/compiler/sem.c

   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: }

Defined functions

Defined variables