1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)type.c 1.4 09/04/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 if (w >= TOOMUCH) { 204 error("Storage requirement of %s exceeds the implementation limit of %d by %d bytes", 205 nameof(np), TOOMUCH-1, w-TOOMUCH+1); 206 np = NIL; 207 } 208 return (np); 209 } 210 211 /* 212 * Scalar (enumerated) types 213 */ 214 tyscal(r) 215 int *r; 216 { 217 register struct nl *np, *op, *zp; 218 register *v; 219 int i; 220 221 np = defnl(0, SCAL, 0, 0); 222 np->type = np; 223 v = r[2]; 224 if (v == NIL) 225 return (NIL); 226 i = -1; 227 zp = np; 228 for (; v != NIL; v = v[2]) { 229 op = enter(defnl(v[1], CONST, np, ++i)); 230 #ifndef PI0 231 op->nl_flags |= NMOD; 232 #endif 233 op->value[1] = i; 234 zp->chain = op; 235 zp = op; 236 } 237 np->range[1] = i; 238 return (np); 239 } 240 241 /* 242 * Declare a subrange. 243 */ 244 tyrang(r) 245 register int *r; 246 { 247 register struct nl *lp, *hp; 248 double high; 249 int c, c1; 250 251 gconst(r[3]); 252 hp = con.ctype; 253 high = con.crval; 254 gconst(r[2]); 255 lp = con.ctype; 256 if (lp == NIL || hp == NIL) 257 return (NIL); 258 if (norange(lp) || norange(hp)) 259 return (NIL); 260 c = classify(lp); 261 c1 = classify(hp); 262 if (c != c1) { 263 #ifndef PI1 264 error("Can't mix %ss and %ss in subranges", nameof(lp), nameof(hp)); 265 #endif 266 return (NIL); 267 } 268 if (c == TSCAL && scalar(lp) != scalar(hp)) { 269 #ifndef PI1 270 error("Scalar types must be identical in subranges"); 271 #endif 272 return (NIL); 273 } 274 if (con.crval > high) { 275 #ifndef PI1 276 error("Range lower bound exceeds upper bound"); 277 #endif 278 return (NIL); 279 } 280 lp = defnl(0, RANGE, hp->type, 0); 281 lp->range[0] = con.crval; 282 lp->range[1] = high; 283 return (lp); 284 } 285 286 norange(p) 287 register struct nl *p; 288 { 289 if (isa(p, "d")) { 290 #ifndef PI1 291 error("Subrange of real is not allowed"); 292 #endif 293 return (1); 294 } 295 if (isnta(p, "bcsi")) { 296 #ifndef PI1 297 error("Subrange bounds must be Boolean, character, integer or scalar, not %s", nameof(p)); 298 #endif 299 return (1); 300 } 301 return (0); 302 } 303 304 /* 305 * Declare arrays and chain together the dimension specification 306 */ 307 struct nl * 308 tyary(r) 309 int *r; 310 { 311 struct nl *np; 312 register *tl; 313 register struct nl *tp, *ltp; 314 int i; 315 316 tp = gtype(r[3]); 317 if (tp == NIL) 318 return (NIL); 319 np = defnl(0, ARRAY, tp, 0); 320 np->nl_flags |= (tp->nl_flags) & NFILES; 321 ltp = np; 322 i = 0; 323 for (tl = r[2]; tl != NIL; tl = tl[2]) { 324 tp = gtype(tl[1]); 325 if (tp == NIL) { 326 np = NIL; 327 continue; 328 } 329 if (tp->class == RANGE && tp->type == nl+TDOUBLE) { 330 #ifndef PI1 331 error("Index type for arrays cannot be real"); 332 #endif 333 np = NIL; 334 continue; 335 } 336 if (tp->class != RANGE && tp->class != SCAL) { 337 #ifndef PI1 338 error("Array index type is a %s, not a range or scalar as required", classes[tp->class]); 339 #endif 340 np = NIL; 341 continue; 342 } 343 if (tp->class == RANGE && bytes(tp->range[0], tp->range[1]) > 2) { 344 #ifndef PI1 345 error("Value of dimension specifier too large or small for this implementation"); 346 #endif 347 continue; 348 } 349 tp = nlcopy(tp); 350 i++; 351 ltp->chain = tp; 352 ltp = tp; 353 } 354 if (np != NIL) 355 np->value[0] = i; 356 return (np); 357 } 358 359 /* 360 * Delayed processing for pointers to 361 * allow self-referential and mutually 362 * recursive pointer constructs. 363 */ 364 foredecl() 365 { 366 register struct nl *p, *q; 367 368 for (p = forechain; p != NIL; p = p->nl_next) { 369 if (p->class == PTR && p -> ptr[0] != 0) 370 { 371 p->type = gtype(p -> ptr[0]); 372 #ifndef PI1 373 if (p->type != NIL && ( ( p->type )->nl_flags & NFILES)) 374 error("Files cannot be members of dynamic structures"); 375 #endif 376 # ifdef PTREE 377 { 378 if ( pUSE( p -> inTree ).PtrTType == pNIL ) { 379 pPointer PtrTo = tCopy( p -> ptr[0] ); 380 381 pDEF( p -> inTree ).PtrTType = PtrTo; 382 } 383 } 384 # endif 385 p -> ptr[0] = 0; 386 } 387 } 388 } 389