1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 #ifndef lint 4 static char sccsid[] = "@(#)type.c 1.12 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 tycrang(r) 270 register int *r; 271 { 272 register struct nl *p, *op, *tp; 273 274 tp = gtype(r->crang_ty.type); 275 if ( tp == NIL ) 276 return (NIL); 277 /* 278 * Just make a new type -- the lower and upper bounds must be 279 * set by params(). 280 */ 281 p = defnl ( 0, CRANGE, tp, 0 ); 282 return(p); 283 } 284 285 /* 286 * Declare a subrange. 287 */ 288 struct nl * 289 tyrang(r) 290 register struct tnode *r; /* T_TYRANG */ 291 { 292 register struct nl *lp, *hp; 293 double high; 294 int c, c1; 295 296 gconst(r->rang_ty.const2); 297 hp = con.ctype; 298 high = con.crval; 299 gconst(r->rang_ty.const1); 300 lp = con.ctype; 301 if (lp == NLNIL || hp == NLNIL) 302 return (NLNIL); 303 if (norange(lp) || norange(hp)) 304 return (NLNIL); 305 c = classify(lp); 306 c1 = classify(hp); 307 if (c != c1) { 308 #ifndef PI1 309 error("Can't mix %ss and %ss in subranges", nameof(lp), nameof(hp)); 310 #endif 311 return (NLNIL); 312 } 313 if (c == TSCAL && scalar(lp) != scalar(hp)) { 314 #ifndef PI1 315 error("Scalar types must be identical in subranges"); 316 #endif 317 return (NLNIL); 318 } 319 if (con.crval > high) { 320 #ifndef PI1 321 error("Range lower bound exceeds upper bound"); 322 #endif 323 return (NLNIL); 324 } 325 lp = defnl((char *) 0, RANGE, hp->type, 0); 326 lp->range[0] = con.crval; 327 lp->range[1] = high; 328 return (lp); 329 } 330 331 norange(p) 332 register struct nl *p; 333 { 334 if (isa(p, "d")) { 335 #ifndef PI1 336 error("Subrange of real is not allowed"); 337 #endif 338 return (1); 339 } 340 if (isnta(p, "bcsi")) { 341 #ifndef PI1 342 error("Subrange bounds must be Boolean, character, integer or scalar, not %s", nameof(p)); 343 #endif 344 return (1); 345 } 346 return (0); 347 } 348 349 /* 350 * Declare arrays and chain together the dimension specification 351 */ 352 struct nl * 353 tyary(r) 354 struct tnode *r; 355 { 356 struct nl *np; 357 register struct tnode *tl, *s; 358 register struct nl *tp, *ltp; 359 int i, n; 360 361 s = r; 362 /* Count the dimensions */ 363 for (n = 0; s->tag == T_TYARY || s->tag == T_TYCARY; 364 s = s->ary_ty.type, n++) 365 /* NULL STATEMENT */; 366 tp = gtype(s); 367 if (tp == NLNIL) 368 return (NLNIL); 369 np = defnl((char *) 0, ARRAY, tp, 0); 370 np->nl_flags |= (tp->nl_flags) & NFILES; 371 ltp = np; 372 i = 0; 373 for (s = r; s->tag == T_TYARY || s->tag == T_TYCARY; 374 s = s->ary_ty.type) { 375 for (tl = s->ary_ty.type_list; tl != TR_NIL; tl=tl->list_node.next){ 376 tp = gtype(tl->list_node.list); 377 if (tp == NLNIL) { 378 np = NLNIL; 379 continue; 380 } 381 if ((tp->class == RANGE || tp->class == CRANGE) && 382 tp->type == nl+TDOUBLE) { 383 #ifndef PI1 384 error("Index type for arrays cannot be real"); 385 #endif 386 np = NLNIL; 387 continue; 388 } 389 if (tp->class != RANGE && tp->class != SCAL && tp->class !=CRANGE){ 390 #ifndef PI1 391 error("Array index type is a %s, not a range or scalar as required", classes[tp->class]); 392 #endif 393 np = NLNIL; 394 continue; 395 } 396 #ifndef PC 397 if (tp->class == RANGE && bytes(tp->range[0], tp->range[1]) > 2) { 398 #ifndef PI1 399 error("Value of dimension specifier too large or small for this implementation"); 400 #endif 401 continue; 402 } 403 #endif 404 if (tp->class != CRANGE) 405 tp = nlcopy(tp); 406 i++; 407 ltp->chain = tp; 408 ltp = tp; 409 } 410 } 411 if (np != NLNIL) 412 np->value[0] = i; 413 return (np); 414 } 415 416 /* 417 * Delayed processing for pointers to 418 * allow self-referential and mutually 419 * recursive pointer constructs. 420 */ 421 foredecl() 422 { 423 register struct nl *p; 424 425 for (p = forechain; p != NLNIL; p = p->nl_next) { 426 if (p->class == PTR && p -> ptr[0] != 0) 427 { 428 p->type = gtype((struct tnode *) p -> ptr[0]); 429 # ifdef PTREE 430 { 431 if ( pUSE( p -> inTree ).PtrTType == pNIL ) { 432 pPointer PtrTo = tCopy( p -> ptr[0] ); 433 434 pDEF( p -> inTree ).PtrTType = PtrTo; 435 } 436 } 437 # endif 438 p -> ptr[0] = 0; 439 } 440 } 441 } 442