1 /* Copyright (c) 1979 Regents of the University of California */ 2 3 static char sccsid[] = "@(#)conv.c 1.2 03/08/81"; 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 * what i want to do is make this and some other stuff 213 * arguments to a function call, which will do the rangecheck, 214 * and return the value of the current expression, or abort 215 * if the rangecheck fails. 216 * probably i need one rangecheck routine to return each c-type 217 * of value. 218 * also, i haven't figured out what the `other stuff' is. 219 */ 220 putprintf( "# call rangecheck" , 0 ); 221 # endif PC 222 } 223 #endif 224 #endif 225 226 #ifdef PC 227 /* 228 * if type p requires a range check, 229 * then put out the name of the checking function 230 * for the beginning of a function call which is completed by postcheck. 231 * (name1 is for a full check; name2 assumes a lower bound of zero) 232 */ 233 precheck( p , name1 , name2 ) 234 struct nl *p; 235 char *name1 , *name2; 236 { 237 238 if ( opt( 't' ) == 0 ) { 239 return; 240 } 241 if ( p == NIL ) { 242 return; 243 } 244 if ( p -> class == TYPE ) { 245 p = p -> type; 246 } 247 switch ( p -> class ) { 248 case RANGE: 249 if ( p != nl + T4INT ) { 250 putleaf( P2ICON , 0 , 0 , ADDTYPE( P2FTN | P2INT , P2PTR ) 251 , p -> range[0] != 0 ? name1 : name2 ); 252 } 253 break; 254 case SCAL: 255 /* 256 * how could a scalar ever be out of range? 257 */ 258 break; 259 default: 260 panic( "precheck" ); 261 break; 262 } 263 } 264 265 /* 266 * if type p requires a range check, 267 * then put out the rest of the arguments of to the checking function 268 * a call to which was started by precheck. 269 * the first argument is what is being rangechecked (put out by rvalue), 270 * the second argument is the lower bound of the range, 271 * the third argument is the upper bound of the range. 272 */ 273 postcheck( p ) 274 struct nl *p; 275 { 276 277 if ( opt( 't' ) == 0 ) { 278 return; 279 } 280 if ( p == NIL ) { 281 return; 282 } 283 if ( p -> class == TYPE ) { 284 p = p -> type; 285 } 286 switch ( p -> class ) { 287 case RANGE: 288 if ( p != nl + T4INT ) { 289 if (p -> range[0] != 0 ) { 290 putleaf( P2ICON , p -> range[0] , 0 , P2INT , 0 ); 291 putop( P2LISTOP , P2INT ); 292 } 293 putleaf( P2ICON , p -> range[1] , 0 , P2INT , 0 ); 294 putop( P2LISTOP , P2INT ); 295 putop( P2CALL , P2INT ); 296 } 297 break; 298 case SCAL: 299 break; 300 default: 301 panic( "postcheck" ); 302 break; 303 } 304 } 305 #endif PC 306 307 #ifdef DEBUG 308 conv(dub) 309 int *dub; 310 { 311 int newfp[2]; 312 double *dp = dub; 313 long *lp = dub; 314 register int exp; 315 long mant; 316 317 newfp[0] = dub[0] & 0100000; 318 newfp[1] = 0; 319 if (*dp == 0.0) 320 goto ret; 321 exp = ((dub[0] >> 7) & 0377) - 0200; 322 if (exp < 0) { 323 newfp[1] = 1; 324 exp = -exp; 325 } 326 if (exp > 63) 327 exp = 63; 328 dub[0] &= ~0177600; 329 dub[0] |= 0200; 330 mant = *lp; 331 mant <<= 8; 332 if (newfp[0]) 333 mant = -mant; 334 newfp[0] |= (mant >> 17) & 077777; 335 newfp[1] |= (((int) (mant >> 1)) & 0177400) | (exp << 1); 336 ret: 337 dub[0] = newfp[0]; 338 dub[1] = newfp[1]; 339 } 340 #endif 341