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