1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 #ifndef lint 4 static char sccsid[] = "@(#)type.c 1.9 08/19/83"; 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 |= 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++; 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_TYRANG: 159 np = tyrang(r); 160 break; 161 case T_TYPTR: 162 np = defnl((char *) 0, PTR, NLNIL, 0 ); 163 np -> ptr[0] = ((struct nl *) r->ptr_ty.id_node); 164 np->nl_next = forechain; 165 forechain = np; 166 break; 167 case T_TYPACK: 168 np = gtype(r->comp_ty.type); 169 break; 170 case T_TYARY: 171 np = tyary(r); 172 break; 173 case T_TYREC: 174 np = tyrec(r->comp_ty.type, 0); 175 # ifdef PTREE 176 /* 177 * mung T_TYREC[3] to point to the record 178 * for RecTCopy 179 */ 180 r->comp_ty.nl_entry = np; 181 # endif 182 break; 183 case T_TYFILE: 184 np = gtype(r->comp_ty.type); 185 if (np == NLNIL) 186 break; 187 #ifndef PI1 188 if (np->nl_flags & NFILES) 189 error("Files cannot be members of files"); 190 #endif 191 np = defnl((char *) 0, FILET, np, 0); 192 np->nl_flags |= NFILES; 193 break; 194 case T_TYSET: 195 np = gtype(r->comp_ty.type); 196 if (np == NLNIL) 197 break; 198 if (np->type == nl+TDOUBLE) { 199 #ifndef PI1 200 error("Set of real is not allowed"); 201 #endif 202 np = NLNIL; 203 break; 204 } 205 if (np->class != RANGE && np->class != SCAL) { 206 #ifndef PI1 207 error("Set type must be range or scalar, not %s", nameof(np)); 208 #endif 209 np = NLNIL; 210 break; 211 } 212 #ifndef PI1 213 if (width(np) > 2) 214 error("Implementation restriction: sets must be indexed by 16 bit quantities"); 215 #endif 216 np = defnl((char *) 0, SET, np, 0); 217 break; 218 } 219 line = oline; 220 #ifndef PC 221 w = lwidth(np); 222 if (w >= TOOMUCH) { 223 error("Storage requirement of %s exceeds the implementation limit of %D by %D bytes", 224 nameof(np), (char *) (long)(TOOMUCH-1), (char *) (long)(w-TOOMUCH+1)); 225 np = NLNIL; 226 } 227 #endif 228 return (np); 229 } 230 231 /* 232 * Scalar (enumerated) types 233 */ 234 struct nl * 235 tyscal(r) 236 struct tnode *r; /* T_TYSCAL */ 237 { 238 register struct nl *np, *op, *zp; 239 register struct tnode *v; 240 int i; 241 242 np = defnl((char *) 0, SCAL, NLNIL, 0); 243 np->type = np; 244 v = r->comp_ty.type; 245 if (v == TR_NIL) 246 return (NLNIL); 247 i = -1; 248 zp = np; 249 for (; v != TR_NIL; v = v->list_node.next) { 250 op = enter(defnl((char *) v->list_node.list, CONST, np, ++i)); 251 #ifndef PI0 252 op->nl_flags |= NMOD; 253 #endif 254 op->value[1] = i; 255 zp->chain = op; 256 zp = op; 257 } 258 np->range[1] = i; 259 return (np); 260 } 261 262 /* 263 * Declare a subrange. 264 */ 265 struct nl * 266 tyrang(r) 267 register struct tnode *r; /* T_TYRANG */ 268 { 269 register struct nl *lp, *hp; 270 double high; 271 int c, c1; 272 273 gconst(r->rang_ty.const2); 274 hp = con.ctype; 275 high = con.crval; 276 gconst(r->rang_ty.const1); 277 lp = con.ctype; 278 if (lp == NLNIL || hp == NLNIL) 279 return (NLNIL); 280 if (norange(lp) || norange(hp)) 281 return (NLNIL); 282 c = classify(lp); 283 c1 = classify(hp); 284 if (c != c1) { 285 #ifndef PI1 286 error("Can't mix %ss and %ss in subranges", nameof(lp), nameof(hp)); 287 #endif 288 return (NLNIL); 289 } 290 if (c == TSCAL && scalar(lp) != scalar(hp)) { 291 #ifndef PI1 292 error("Scalar types must be identical in subranges"); 293 #endif 294 return (NLNIL); 295 } 296 if (con.crval > high) { 297 #ifndef PI1 298 error("Range lower bound exceeds upper bound"); 299 #endif 300 return (NLNIL); 301 } 302 lp = defnl((char *) 0, RANGE, hp->type, 0); 303 lp->range[0] = con.crval; 304 lp->range[1] = high; 305 return (lp); 306 } 307 308 norange(p) 309 register struct nl *p; 310 { 311 if (isa(p, "d")) { 312 #ifndef PI1 313 error("Subrange of real is not allowed"); 314 #endif 315 return (1); 316 } 317 if (isnta(p, "bcsi")) { 318 #ifndef PI1 319 error("Subrange bounds must be Boolean, character, integer or scalar, not %s", nameof(p)); 320 #endif 321 return (1); 322 } 323 return (0); 324 } 325 326 /* 327 * Declare arrays and chain together the dimension specification 328 */ 329 struct nl * 330 tyary(r) 331 struct tnode *r; 332 { 333 struct nl *np; 334 register struct tnode *tl; 335 register struct nl *tp, *ltp; 336 int i; 337 338 tp = gtype(r->ary_ty.type); 339 if (tp == NLNIL) 340 return (NLNIL); 341 np = defnl((char *) 0, ARRAY, tp, 0); 342 np->nl_flags |= (tp->nl_flags) & NFILES; 343 ltp = np; 344 i = 0; 345 for (tl = r->ary_ty.type_list; tl != TR_NIL; tl = tl->list_node.next) { 346 tp = gtype(tl->list_node.list); 347 if (tp == NLNIL) { 348 np = NLNIL; 349 continue; 350 } 351 if (tp->class == RANGE && tp->type == nl+TDOUBLE) { 352 #ifndef PI1 353 error("Index type for arrays cannot be real"); 354 #endif 355 np = NLNIL; 356 continue; 357 } 358 if (tp->class != RANGE && tp->class != SCAL) { 359 #ifndef PI1 360 error("Array index type is a %s, not a range or scalar as required", classes[tp->class]); 361 #endif 362 np = NLNIL; 363 continue; 364 } 365 #ifndef PC 366 if (tp->class == RANGE && bytes(tp->range[0], tp->range[1]) > 2) { 367 #ifndef PI1 368 error("Value of dimension specifier too large or small for this implementation"); 369 #endif 370 continue; 371 } 372 #endif 373 tp = nlcopy(tp); 374 i++; 375 ltp->chain = tp; 376 ltp = tp; 377 } 378 if (np != NLNIL) 379 np->value[0] = i; 380 return (np); 381 } 382 383 /* 384 * Delayed processing for pointers to 385 * allow self-referential and mutually 386 * recursive pointer constructs. 387 */ 388 foredecl() 389 { 390 register struct nl *p; 391 392 for (p = forechain; p != NLNIL; p = p->nl_next) { 393 if (p->class == PTR && p -> ptr[0] != 0) 394 { 395 p->type = gtype((struct tnode *) p -> ptr[0]); 396 # ifdef PTREE 397 { 398 if ( pUSE( p -> inTree ).PtrTType == pNIL ) { 399 pPointer PtrTo = tCopy( p -> ptr[0] ); 400 401 pDEF( p -> inTree ).PtrTType = PtrTo; 402 } 403 } 404 # endif 405 p -> ptr[0] = 0; 406 } 407 } 408 } 409