1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)type.c 1.2 08/31/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 * PC 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 #ifdef PC 29 if (opt('s')) { 30 if (parts & VPRT) { 31 standard(); 32 error("Type declarations must precede var declarations"); 33 } 34 if (parts & TPRT) { 35 standard(); 36 error("All types must be declared in one type part"); 37 } 38 } 39 #endif PC 40 #ifdef OBJ 41 if (parts & VPRT) 42 error("Type declarations must precede var declarations"); 43 if (parts & TPRT) 44 error("All types must be declared in one type part"); 45 #endif OBJ 46 parts |= TPRT; 47 #endif 48 /* 49 * Forechain is the head of a list of types that 50 * might be self referential. We chain them up and 51 * process them later. 52 */ 53 forechain = NIL; 54 #ifdef PI0 55 send(REVTBEG); 56 #endif 57 } 58 59 type(tline, tid, tdecl) 60 int tline; 61 char *tid; 62 register int *tdecl; 63 { 64 register struct nl *np; 65 66 np = gtype(tdecl); 67 line = tline; 68 #ifndef PI0 69 enter(defnl(tid, TYPE, np, 0))->nl_flags |= NMOD; 70 #else 71 enter(defnl(tid, TYPE, np, 0)); 72 send(REVTYPE, tline, tid, tdecl); 73 #endif 74 75 #ifdef PC 76 if (cbn == 1) { 77 stabtname( tid , line ); 78 } 79 #endif PC 80 81 # ifdef PTREE 82 { 83 pPointer Type = TypeDecl( tid , tdecl ); 84 pPointer *Types; 85 86 pSeize( PorFHeader[ nesting ] ); 87 Types = &( pDEF( PorFHeader[ nesting ] ).PorFTypes ); 88 *Types = ListAppend( *Types , Type ); 89 pRelease( PorFHeader[ nesting ] ); 90 } 91 # endif 92 } 93 94 typeend() 95 { 96 97 #ifdef PI0 98 send(REVTEND); 99 #endif 100 foredecl(); 101 } 102 103 /* 104 * Return a type pointer (into the namelist) 105 * from a parse tree for a type, building 106 * namelist entries as needed. 107 */ 108 struct nl * 109 gtype(r) 110 register int *r; 111 { 112 register struct nl *np; 113 register char *cp; 114 register int oline, w; 115 116 if (r == NIL) 117 return (NIL); 118 oline = line; 119 if (r[0] != T_ID) 120 oline = line = r[1]; 121 switch (r[0]) { 122 default: 123 panic("type"); 124 case T_TYID: 125 r++; 126 case T_ID: 127 np = lookup(r[1]); 128 if (np == NIL) 129 break; 130 if (np->class != TYPE) { 131 #ifndef PI1 132 error("%s is a %s, not a type as required", r[1], classes[np->class]); 133 #endif 134 np = NIL; 135 break; 136 } 137 np = np->type; 138 break; 139 case T_TYSCAL: 140 np = tyscal(r); 141 break; 142 case T_TYRANG: 143 np = tyrang(r); 144 break; 145 case T_TYPTR: 146 np = defnl(0, PTR, 0, 0 ); 147 np -> ptr[0] = r[2]; 148 np->nl_next = forechain; 149 forechain = np; 150 break; 151 case T_TYPACK: 152 np = gtype(r[2]); 153 break; 154 case T_TYARY: 155 np = tyary(r); 156 break; 157 case T_TYREC: 158 np = tyrec(r[2], 0); 159 # ifdef PTREE 160 /* 161 * mung T_TYREC[3] to point to the record 162 * for RecTCopy 163 */ 164 r[3] = np; 165 # endif 166 break; 167 case T_TYFILE: 168 np = gtype(r[2]); 169 if (np == NIL) 170 break; 171 #ifndef PI1 172 if (np->nl_flags & NFILES) 173 error("Files cannot be members of files"); 174 #endif 175 np = defnl(0, FILET, np, 0); 176 np->nl_flags |= NFILES; 177 break; 178 case T_TYSET: 179 np = gtype(r[2]); 180 if (np == NIL) 181 break; 182 if (np->type == nl+TDOUBLE) { 183 #ifndef PI1 184 error("Set of real is not allowed"); 185 #endif 186 np = NIL; 187 break; 188 } 189 if (np->class != RANGE && np->class != SCAL) { 190 #ifndef PI1 191 error("Set type must be range or scalar, not %s", nameof(np)); 192 #endif 193 np = NIL; 194 break; 195 } 196 #ifndef PI1 197 if (width(np) > 2) 198 error("Implementation restriction: sets must be indexed by 16 bit quantities"); 199 #endif 200 np = defnl(0, SET, np, 0); 201 break; 202 } 203 line = oline; 204 w = lwidth(np); 205 if (w >= TOOMUCH) { 206 error("Storage requirement of %s exceeds the implementation limit of %d by %d bytes", 207 nameof(np), TOOMUCH-1, w-TOOMUCH+1); 208 np = NIL; 209 } 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 if (tp->class == RANGE && bytes(tp->range[0], tp->range[1]) > 2) { 346 #ifndef PI1 347 error("Value of dimension specifier too large or small for this implementation"); 348 #endif 349 continue; 350 } 351 tp = nlcopy(tp); 352 i++; 353 ltp->chain = tp; 354 ltp = tp; 355 } 356 if (np != NIL) 357 np->value[0] = i; 358 return (np); 359 } 360 361 /* 362 * Delayed processing for pointers to 363 * allow self-referential and mutually 364 * recursive pointer constructs. 365 */ 366 foredecl() 367 { 368 register struct nl *p, *q; 369 370 for (p = forechain; p != NIL; p = p->nl_next) { 371 if (p->class == PTR && p -> ptr[0] != 0) 372 { 373 p->type = gtype(p -> ptr[0]); 374 #ifndef PI1 375 if (p->type != NIL && ( ( p->type )->nl_flags & NFILES)) 376 error("Files cannot be members of dynamic structures"); 377 #endif 378 # ifdef PTREE 379 { 380 if ( pUSE( p -> inTree ).PtrTType == pNIL ) { 381 pPointer PtrTo = tCopy( p -> ptr[0] ); 382 383 pDEF( p -> inTree ).PtrTType = PtrTo; 384 } 385 } 386 # endif 387 p -> ptr[0] = 0; 388 } 389 } 390 } 391