1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)conv.c 1.4 01/17/83"; 4 5 #include "whoami.h" 6 #ifdef PI 7 #include "0.h" 8 #include "opcode.h" 9 #ifdef PC 10 # include "pcops.h" 11 #endif PC 12 13 #ifndef PI0 14 /* 15 * Convert a p1 into a p2. 16 * Mostly used for different 17 * length integers and "to real" conversions. 18 */ 19 convert(p1, p2) 20 struct nl *p1, *p2; 21 { 22 if (p1 == NIL || p2 == NIL) 23 return; 24 switch (width(p1) - width(p2)) { 25 case -7: 26 case -6: 27 put(1, O_STOD); 28 return; 29 case -4: 30 put(1, O_ITOD); 31 return; 32 case -3: 33 case -2: 34 put(1, O_STOI); 35 return; 36 case -1: 37 case 0: 38 case 1: 39 return; 40 case 2: 41 case 3: 42 put(1, O_ITOS); 43 return; 44 default: 45 panic("convert"); 46 } 47 } 48 #endif 49 50 /* 51 * Compat tells whether 52 * p1 and p2 are compatible 53 * types for an assignment like 54 * context, i.e. value parameters, 55 * indicies for 'in', etc. 56 */ 57 compat(p1, p2, t) 58 struct nl *p1, *p2; 59 { 60 register c1, c2; 61 62 c1 = classify(p1); 63 if (c1 == NIL) 64 return (NIL); 65 c2 = classify(p2); 66 if (c2 == NIL) 67 return (NIL); 68 switch (c1) { 69 case TBOOL: 70 case TCHAR: 71 if (c1 == c2) 72 return (1); 73 break; 74 case TINT: 75 if (c2 == TINT) 76 return (1); 77 case TDOUBLE: 78 if (c2 == TDOUBLE) 79 return (1); 80 #ifndef PI0 81 if (c2 == TINT && divflg == 0 && t != NIL ) { 82 divchk= 1; 83 c1 = classify(rvalue(t, NLNIL , RREQ )); 84 divchk = NIL; 85 if (c1 == TINT) { 86 error("Type clash: real is incompatible with integer"); 87 cerror("This resulted because you used '/' which always returns real rather"); 88 cerror("than 'div' which divides integers and returns integers"); 89 divflg = 1; 90 return (NIL); 91 } 92 } 93 #endif 94 break; 95 case TSCAL: 96 if (c2 != TSCAL) 97 break; 98 if (scalar(p1) != scalar(p2)) { 99 derror("Type clash: non-identical scalar types"); 100 return (NIL); 101 } 102 return (1); 103 case TSTR: 104 if (c2 != TSTR) 105 break; 106 if (width(p1) != width(p2)) { 107 derror("Type clash: unequal length strings"); 108 return (NIL); 109 } 110 return (1); 111 case TNIL: 112 if (c2 != TPTR) 113 break; 114 return (1); 115 case TFILE: 116 if (c1 != c2) 117 break; 118 derror("Type clash: files not allowed in this context"); 119 return (NIL); 120 default: 121 if (c1 != c2) 122 break; 123 if (p1 != p2) { 124 derror("Type clash: non-identical %s types", clnames[c1]); 125 return (NIL); 126 } 127 if (p1->nl_flags & NFILES) { 128 derror("Type clash: %ss with file components not allowed in this context", clnames[c1]); 129 return (NIL); 130 } 131 return (1); 132 } 133 derror("Type clash: %s is incompatible with %s", clnames[c1], clnames[c2]); 134 return (NIL); 135 } 136 137 #ifndef PI0 138 /* 139 * Rangechk generates code to 140 * check if the type p on top 141 * of the stack is in range for 142 * assignment to a variable 143 * of type q. 144 */ 145 rangechk(p, q) 146 struct nl *p, *q; 147 { 148 register struct nl *rp; 149 register op; 150 int wq, wrp; 151 152 if (opt('t') == 0) 153 return; 154 rp = p; 155 if (rp == NIL) 156 return; 157 if (q == NIL) 158 return; 159 # ifdef OBJ 160 /* 161 * When op is 1 we are checking length 162 * 4 numbers against length 2 bounds, 163 * and adding it to the opcode forces 164 * generation of appropriate tests. 165 */ 166 op = 0; 167 wq = width(q); 168 wrp = width(rp); 169 op = wq != wrp && (wq == 4 || wrp == 4); 170 if (rp->class == TYPE) 171 rp = rp->type; 172 switch (rp->class) { 173 case RANGE: 174 if (rp->range[0] != 0) { 175 # ifndef DEBUG 176 if (wrp <= 2) 177 put(3, O_RANG2+op, ( short ) rp->range[0], 178 ( short ) rp->range[1]); 179 else if (rp != nl+T4INT) 180 put(3, O_RANG4+op, rp->range[0], rp->range[1] ); 181 # else 182 if (!hp21mx) { 183 if (wrp <= 2) 184 put(3, O_RANG2+op,( short ) rp->range[0], 185 ( short ) rp->range[1]); 186 else if (rp != nl+T4INT) 187 put(3, O_RANG4+op,rp->range[0], 188 rp->range[1]); 189 } else 190 if (rp != nl+T2INT && rp != nl+T4INT) 191 put(3, O_RANG2+op,( short ) rp->range[0], 192 ( short ) rp->range[1]); 193 # endif 194 break; 195 } 196 /* 197 * Range whose lower bounds are 198 * zero can be treated as scalars. 199 */ 200 case SCAL: 201 if (wrp <= 2) 202 put(2, O_RSNG2+op, ( short ) rp->range[1]); 203 else 204 put( 2 , O_RSNG4+op, rp->range[1]); 205 break; 206 default: 207 panic("rangechk"); 208 } 209 # endif OBJ 210 # ifdef PC 211 /* 212 * pc uses precheck() and postcheck(). 213 */ 214 panic("rangechk()"); 215 # endif PC 216 } 217 #endif 218 #endif 219 220 #ifdef PC 221 /* 222 * if type p requires a range check, 223 * then put out the name of the checking function 224 * for the beginning of a function call which is completed by postcheck. 225 * (name1 is for a full check; name2 assumes a lower bound of zero) 226 */ 227 precheck( p , name1 , name2 ) 228 struct nl *p; 229 char *name1 , *name2; 230 { 231 232 if ( opt( 't' ) == 0 ) { 233 return; 234 } 235 if ( p == NIL ) { 236 return; 237 } 238 if ( p -> class == TYPE ) { 239 p = p -> type; 240 } 241 switch ( p -> class ) { 242 case RANGE: 243 if ( p != nl + T4INT ) { 244 putleaf( P2ICON , 0 , 0 , 245 ADDTYPE( P2FTN | P2INT , P2PTR ), 246 p -> range[0] != 0 ? name1 : name2 ); 247 } 248 break; 249 case SCAL: 250 /* 251 * how could a scalar ever be out of range? 252 */ 253 break; 254 default: 255 panic( "precheck" ); 256 break; 257 } 258 } 259 260 /* 261 * if type p requires a range check, 262 * then put out the rest of the arguments of to the checking function 263 * a call to which was started by precheck. 264 * the first argument is what is being rangechecked (put out by rvalue), 265 * the second argument is the lower bound of the range, 266 * the third argument is the upper bound of the range. 267 */ 268 postcheck(need, have) 269 struct nl *need; 270 struct nl *have; 271 { 272 273 if ( opt( 't' ) == 0 ) { 274 return; 275 } 276 if ( need == NIL ) { 277 return; 278 } 279 if ( need -> class == TYPE ) { 280 need = need -> type; 281 } 282 switch ( need -> class ) { 283 case RANGE: 284 if ( need != nl + T4INT ) { 285 sconv(p2type(have), P2INT); 286 if (need -> range[0] != 0 ) { 287 putleaf( P2ICON , need -> range[0] , 0 , P2INT , 0 ); 288 putop( P2LISTOP , P2INT ); 289 } 290 putleaf( P2ICON , need -> range[1] , 0 , P2INT , 0 ); 291 putop( P2LISTOP , P2INT ); 292 putop( P2CALL , P2INT ); 293 sconv(P2INT, p2type(have)); 294 } 295 break; 296 case SCAL: 297 break; 298 default: 299 panic( "postcheck" ); 300 break; 301 } 302 } 303 #endif PC 304 305 #ifdef DEBUG 306 conv(dub) 307 int *dub; 308 { 309 int newfp[2]; 310 double *dp = dub; 311 long *lp = dub; 312 register int exp; 313 long mant; 314 315 newfp[0] = dub[0] & 0100000; 316 newfp[1] = 0; 317 if (*dp == 0.0) 318 goto ret; 319 exp = ((dub[0] >> 7) & 0377) - 0200; 320 if (exp < 0) { 321 newfp[1] = 1; 322 exp = -exp; 323 } 324 if (exp > 63) 325 exp = 63; 326 dub[0] &= ~0177600; 327 dub[0] |= 0200; 328 mant = *lp; 329 mant <<= 8; 330 if (newfp[0]) 331 mant = -mant; 332 newfp[0] |= (mant >> 17) & 077777; 333 newfp[1] |= (((int) (mant >> 1)) & 0177400) | (exp << 1); 334 ret: 335 dub[0] = newfp[0]; 336 dub[1] = newfp[1]; 337 } 338 #endif 339