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