2.11BSD#431 - /usr/src/ucb/PORT/pascal/src/conv.c

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

Defined functions

Defined variables