1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 #ifndef lint 4 static char sccsid[] = "@(#)type.c 1.13 02/08/84"; 5 #endif 6 7 #include "whoami.h" 8 #include "0.h" 9 #include "tree.h" 10 #include "objfmt.h" 11 #include "tree_ty.h" 12 13 /* 14 * Type declaration part 15 */ 16 /*ARGSUSED*/ 17 typebeg( lineofytype , r ) 18 int lineofytype; 19 { 20 static bool type_order = FALSE; 21 static bool type_seen = FALSE; 22 23 /* 24 * this allows for multiple 25 * declaration parts unless 26 * standard option has been 27 * specified. 28 * If routine segment is being 29 * compiled, do level one processing. 30 */ 31 32 #ifndef PI1 33 if (!progseen) 34 level1(); 35 line = lineofytype; 36 if ( parts[ cbn ] & ( VPRT | RPRT ) ) { 37 if ( opt( 's' ) ) { 38 standard(); 39 error("Type declarations should precede var and routine declarations"); 40 } else { 41 if ( !type_order ) { 42 type_order = TRUE; 43 warning(); 44 error("Type declarations should precede var and routine declarations"); 45 } 46 } 47 } 48 if (parts[ cbn ] & TPRT) { 49 if ( opt( 's' ) ) { 50 standard(); 51 error("All types should be declared in one type part"); 52 } else { 53 if ( !type_seen ) { 54 type_seen = TRUE; 55 warning(); 56 error("All types should be declared in one type part"); 57 } 58 } 59 } 60 parts[ cbn ] |= TPRT; 61 #endif 62 /* 63 * Forechain is the head of a list of types that 64 * might be self referential. We chain them up and 65 * process them later. 66 */ 67 forechain = NIL; 68 #ifdef PI0 69 send(REVTBEG); 70 #endif 71 } 72 73 type(tline, tid, tdecl) 74 int tline; 75 char *tid; 76 register struct tnode *tdecl; 77 { 78 register struct nl *np; 79 80 np = gtype(tdecl); 81 line = tline; 82 #ifndef PI0 83 enter(defnl(tid, TYPE, np, 0))->nl_flags |= (char) NMOD; 84 #else 85 (void) enter(defnl(tid, TYPE, np, 0)); 86 send(REVTYPE, tline, tid, tdecl); 87 #endif 88 89 #ifdef PC 90 if (cbn == 1) { 91 stabgtype( tid , line ); 92 } 93 #endif PC 94 95 # ifdef PTREE 96 { 97 pPointer Type = TypeDecl( tid , tdecl ); 98 pPointer *Types; 99 100 pSeize( PorFHeader[ nesting ] ); 101 Types = &( pDEF( PorFHeader[ nesting ] ).PorFTypes ); 102 *Types = ListAppend( *Types , Type ); 103 pRelease( PorFHeader[ nesting ] ); 104 } 105 # endif 106 } 107 108 typeend() 109 { 110 111 #ifdef PI0 112 send(REVTEND); 113 #endif 114 foredecl(); 115 } 116 117 /* 118 * Return a type pointer (into the namelist) 119 * from a parse tree for a type, building 120 * namelist entries as needed. 121 */ 122 struct nl * 123 gtype(r) 124 register struct tnode *r; 125 { 126 register struct nl *np; 127 register int oline; 128 #ifdef OBJ 129 long w; 130 #endif 131 132 if (r == TR_NIL) 133 return (NLNIL); 134 oline = line; 135 if (r->tag != T_ID) 136 oline = line = r->lined.line_no; 137 switch (r->tag) { 138 default: 139 panic("type"); 140 case T_TYID: 141 r = (struct tnode *) (&(r->tyid_node.line_no)); 142 case T_ID: 143 np = lookup(r->char_const.cptr); 144 if (np == NLNIL) 145 break; 146 if (np->class != TYPE) { 147 #ifndef PI1 148 error("%s is a %s, not a type as required", r->char_const.cptr, classes[np->class]); 149 #endif 150 np = NLNIL; 151 break; 152 } 153 np = np->type; 154 break; 155 case T_TYSCAL: 156 np = tyscal(r); 157 break; 158 case T_TYCRANG: 159 np = tycrang(r); 160 break; 161 case T_TYRANG: 162 np = tyrang(r); 163 break; 164 case T_TYPTR: 165 np = defnl((char *) 0, PTR, NLNIL, 0 ); 166 np -> ptr[0] = ((struct nl *) r->ptr_ty.id_node); 167 np->nl_next = forechain; 168 forechain = np; 169 break; 170 case T_TYPACK: 171 np = gtype(r->comp_ty.type); 172 break; 173 case T_TYCARY: 174 case T_TYARY: 175 np = tyary(r); 176 break; 177 case T_TYREC: 178 np = tyrec(r->comp_ty.type, 0); 179 # ifdef PTREE 180 /* 181 * mung T_TYREC[3] to point to the record 182 * for RecTCopy 183 */ 184 r->comp_ty.nl_entry = np; 185 # endif 186 break; 187 case T_TYFILE: 188 np = gtype(r->comp_ty.type); 189 if (np == NLNIL) 190 break; 191 #ifndef PI1 192 if (np->nl_flags & NFILES) 193 error("Files cannot be members of files"); 194 #endif 195 np = defnl((char *) 0, FILET, np, 0); 196 np->nl_flags |= NFILES; 197 break; 198 case T_TYSET: 199 np = gtype(r->comp_ty.type); 200 if (np == NLNIL) 201 break; 202 if (np->type == nl+TDOUBLE) { 203 #ifndef PI1 204 error("Set of real is not allowed"); 205 #endif 206 np = NLNIL; 207 break; 208 } 209 if (np->class != RANGE && np->class != SCAL) { 210 #ifndef PI1 211 error("Set type must be range or scalar, not %s", nameof(np)); 212 #endif 213 np = NLNIL; 214 break; 215 } 216 #ifndef PI1 217 if (width(np) > 2) 218 error("Implementation restriction: sets must be indexed by 16 bit quantities"); 219 #endif 220 np = defnl((char *) 0, SET, np, 0); 221 break; 222 } 223 line = oline; 224 #ifndef PC 225 w = lwidth(np); 226 if (w >= TOOMUCH) { 227 error("Storage requirement of %s exceeds the implementation limit of %D by %D bytes", 228 nameof(np), (char *) (long)(TOOMUCH-1), (char *) (long)(w-TOOMUCH+1)); 229 np = NLNIL; 230 } 231 #endif 232 return (np); 233 } 234 235 /* 236 * Scalar (enumerated) types 237 */ 238 struct nl * 239 tyscal(r) 240 struct tnode *r; /* T_TYSCAL */ 241 { 242 register struct nl *np, *op, *zp; 243 register struct tnode *v; 244 int i; 245 246 np = defnl((char *) 0, SCAL, NLNIL, 0); 247 np->type = np; 248 v = r->comp_ty.type; 249 if (v == TR_NIL) 250 return (NLNIL); 251 i = -1; 252 zp = np; 253 for (; v != TR_NIL; v = v->list_node.next) { 254 op = enter(defnl((char *) v->list_node.list, CONST, np, ++i)); 255 #ifndef PI0 256 op->nl_flags |= NMOD; 257 #endif 258 op->value[1] = i; 259 zp->chain = op; 260 zp = op; 261 } 262 np->range[1] = i; 263 return (np); 264 } 265 266 /* 267 * Declare a subrange for conformant arrays. 268 */ 269 struct nl * 270 tycrang(r) 271 register struct tnode *r; 272 { 273 register struct nl *p, *op, *tp; 274 275 tp = gtype(r->crang_ty.type); 276 if ( tp == NLNIL ) 277 return (NLNIL); 278 /* 279 * Just make a new type -- the lower and upper bounds must be 280 * set by params(). 281 */ 282 p = defnl ( 0, CRANGE, tp, 0 ); 283 return(p); 284 } 285 286 /* 287 * Declare a subrange. 288 */ 289 struct nl * 290 tyrang(r) 291 register struct tnode *r; /* T_TYRANG */ 292 { 293 register struct nl *lp, *hp; 294 double high; 295 int c, c1; 296 297 gconst(r->rang_ty.const2); 298 hp = con.ctype; 299 high = con.crval; 300 gconst(r->rang_ty.const1); 301 lp = con.ctype; 302 if (lp == NLNIL || hp == NLNIL) 303 return (NLNIL); 304 if (norange(lp) || norange(hp)) 305 return (NLNIL); 306 c = classify(lp); 307 c1 = classify(hp); 308 if (c != c1) { 309 #ifndef PI1 310 error("Can't mix %ss and %ss in subranges", nameof(lp), nameof(hp)); 311 #endif 312 return (NLNIL); 313 } 314 if (c == TSCAL && scalar(lp) != scalar(hp)) { 315 #ifndef PI1 316 error("Scalar types must be identical in subranges"); 317 #endif 318 return (NLNIL); 319 } 320 if (con.crval > high) { 321 #ifndef PI1 322 error("Range lower bound exceeds upper bound"); 323 #endif 324 return (NLNIL); 325 } 326 lp = defnl((char *) 0, RANGE, hp->type, 0); 327 lp->range[0] = con.crval; 328 lp->range[1] = high; 329 return (lp); 330 } 331 332 norange(p) 333 register struct nl *p; 334 { 335 if (isa(p, "d")) { 336 #ifndef PI1 337 error("Subrange of real is not allowed"); 338 #endif 339 return (1); 340 } 341 if (isnta(p, "bcsi")) { 342 #ifndef PI1 343 error("Subrange bounds must be Boolean, character, integer or scalar, not %s", nameof(p)); 344 #endif 345 return (1); 346 } 347 return (0); 348 } 349 350 /* 351 * Declare arrays and chain together the dimension specification 352 */ 353 struct nl * 354 tyary(r) 355 struct tnode *r; 356 { 357 struct nl *np; 358 register struct tnode *tl, *s; 359 register struct nl *tp, *ltp; 360 int i, n; 361 362 s = r; 363 /* Count the dimensions */ 364 for (n = 0; s->tag == T_TYARY || s->tag == T_TYCARY; 365 s = s->ary_ty.type, n++) 366 /* NULL STATEMENT */; 367 tp = gtype(s); 368 if (tp == NLNIL) 369 return (NLNIL); 370 np = defnl((char *) 0, ARRAY, tp, 0); 371 np->nl_flags |= (tp->nl_flags) & NFILES; 372 ltp = np; 373 i = 0; 374 for (s = r; s->tag == T_TYARY || s->tag == T_TYCARY; 375 s = s->ary_ty.type) { 376 for (tl = s->ary_ty.type_list; tl != TR_NIL; tl=tl->list_node.next){ 377 tp = gtype(tl->list_node.list); 378 if (tp == NLNIL) { 379 np = NLNIL; 380 continue; 381 } 382 if ((tp->class == RANGE || tp->class == CRANGE) && 383 tp->type == nl+TDOUBLE) { 384 #ifndef PI1 385 error("Index type for arrays cannot be real"); 386 #endif 387 np = NLNIL; 388 continue; 389 } 390 if (tp->class != RANGE && tp->class != SCAL && tp->class !=CRANGE){ 391 #ifndef PI1 392 error("Array index type is a %s, not a range or scalar as required", classes[tp->class]); 393 #endif 394 np = NLNIL; 395 continue; 396 } 397 #ifndef PC 398 if (tp->class == RANGE && bytes(tp->range[0], tp->range[1]) > 2) { 399 #ifndef PI1 400 error("Value of dimension specifier too large or small for this implementation"); 401 #endif 402 continue; 403 } 404 #endif 405 if (tp->class != CRANGE) 406 tp = nlcopy(tp); 407 i++; 408 ltp->chain = tp; 409 ltp = tp; 410 } 411 } 412 if (np != NLNIL) 413 np->value[0] = i; 414 return (np); 415 } 416 417 /* 418 * Delayed processing for pointers to 419 * allow self-referential and mutually 420 * recursive pointer constructs. 421 */ 422 foredecl() 423 { 424 register struct nl *p; 425 426 for (p = forechain; p != NLNIL; p = p->nl_next) { 427 if (p->class == PTR && p -> ptr[0] != 0) 428 { 429 p->type = gtype((struct tnode *) p -> ptr[0]); 430 # ifdef PTREE 431 { 432 if ( pUSE( p -> inTree ).PtrTType == pNIL ) { 433 pPointer PtrTo = tCopy( p -> ptr[0] ); 434 435 pDEF( p -> inTree ).PtrTType = PtrTo; 436 } 437 } 438 # endif 439 p -> ptr[0] = 0; 440 } 441 } 442 } 443