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