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