2.9BSD - /usr/src/ucb/pascal/pi/conv.c

   1: /*	@(#)conv.c	2.2	SCCS id keyword	*/
   2: /* Copyright (c) 1979 Regents of the University of California */
   3: #
   4: /*
   5:  * pi - Pascal interpreter code translator
   6:  *
   7:  * Charles Haley, Bill Joy UCB
   8:  * Version 1.2 November 1978
   9:  */
  10: 
  11: #include "whoami"
  12: #ifdef PI
  13: #include "0.h"
  14: #include "opcode.h"
  15: 
  16: #ifndef PI0
  17: /*
  18:  * Convert a p1 into a p2.
  19:  * Mostly used for different
  20:  * length integers and "to real" conversions.
  21:  */
  22: convert(p1, p2)
  23:     struct nl *p1, *p2;
  24: {
  25:     if (p1 == NIL || p2 == NIL)
  26:         return;
  27:     switch (width(p1) - width(p2)) {
  28:         case -7:
  29:         case -6:
  30:             put1(O_STOD);
  31:             return;
  32:         case -4:
  33:             put1(O_ITOD);
  34:             return;
  35:         case -3:
  36:         case -2:
  37:             put1(O_STOI);
  38:             return;
  39:         case -1:
  40:         case 0:
  41:         case 1:
  42:             return;
  43:         case 2:
  44:         case 3:
  45:             put1(O_ITOS);
  46:             return;
  47:         default:
  48:             panic("convert");
  49:     }
  50: }
  51: #endif
  52: 
  53: /*
  54:  * Compat tells whether
  55:  * p1 and p2 are compatible
  56:  * types for an assignment like
  57:  * context, i.e. value parameters,
  58:  * indicies for 'in', etc.
  59:  */
  60: compat(p1, p2, t)
  61:     struct nl *p1, *p2;
  62: {
  63:     register c1, c2;
  64: 
  65:     c1 = classify(p1);
  66:     if (c1 == NIL)
  67:         return (NIL);
  68:     c2 = classify(p2);
  69:     if (c2 == NIL)
  70:         return (NIL);
  71:     switch (c1) {
  72:         case TBOOL:
  73:         case TCHAR:
  74:             if (c1 == c2)
  75:                 return (1);
  76:             break;
  77:         case TINT:
  78:             if (c2 == TINT)
  79:                 return (1);
  80:         case TDOUBLE:
  81:             if (c2 == TDOUBLE)
  82:                 return (1);
  83: #ifndef PI0
  84:             if (c2 == TINT && divflg == 0) {
  85:                 divchk= 1;
  86:                 c1 = classify(rvalue(t, NLNIL));
  87:                 divchk = NIL;
  88:                 if (c1 == TINT) {
  89:                     error("Type clash: real is incompatible with integer");
  90:                     cerror("This resulted because you used '/' which always returns real rather");
  91:                     cerror("than 'div' which divides integers and returns integers");
  92:                     divflg = 1;
  93:                     return (NIL);
  94:                 }
  95:             }
  96: #endif
  97:             break;
  98:         case TSCAL:
  99:             if (c2 != TSCAL)
 100:                 break;
 101:             if (scalar(p1) != scalar(p2)) {
 102:                 derror("Type clash: non-identical scalar types");
 103:                 return (NIL);
 104:             }
 105:             return (1);
 106:         case TSTR:
 107:             if (c2 != TSTR)
 108:                 break;
 109:             if (width(p1) != width(p2)) {
 110:                 derror("Type clash: unequal length strings");
 111:                 return (NIL);
 112:             }
 113:             return (1);
 114:         case TNIL:
 115:             if (c2 != TPTR)
 116:                 break;
 117:             return (1);
 118:         case TFILE:
 119:             if (c1 != c2)
 120:                 break;
 121:             derror("Type clash: files not allowed in this context");
 122:             return (NIL);
 123:         default:
 124:             if (c1 != c2)
 125:                 break;
 126:             if (p1 != p2) {
 127:                 derror("Type clash: non-identical %s types", clnames[c1]);
 128:                 return (NIL);
 129:             }
 130:             if (p1->nl_flags & NFILES) {
 131:                 derror("Type clash: %ss with file components not allowed in this context", clnames[c1]);
 132:                 return (NIL);
 133:             }
 134:             return (1);
 135:     }
 136:     derror("Type clash: %s is incompatible with %s", clnames[c1], clnames[c2]);
 137:     return (NIL);
 138: }
 139: 
 140: #ifndef PI0
 141: /*
 142:  * Rangechk generates code to
 143:  * check if the type p on top
 144:  * of the stack is in range for
 145:  * assignment to a variable
 146:  * of type q.
 147:  */
 148: rangechk(p, q)
 149:     struct nl *p, *q;
 150: {
 151:     register struct nl *rp;
 152:     register op;
 153:     int wq, wrp;
 154: 
 155:     if (opt('t') == 0)
 156:         return;
 157:     rp = p;
 158:     if (rp == NIL)
 159:         return;
 160:     if (q == NIL)
 161:         return;
 162:     /*
 163: 	 * When op is 1 we are checking length
 164: 	 * 4 numbers against length 2 bounds,
 165: 	 * and adding it to the opcode forces
 166: 	 * generation of appropriate tests.
 167: 	 */
 168:     op = 0;
 169:     wq = width(q);
 170:     wrp = width(rp);
 171:     op = wq != wrp && (wq == 4 || wrp == 4);
 172:     if (rp->class == TYPE)
 173:         rp = rp->type;
 174:     switch (rp->class) {
 175:     case RANGE:
 176:         if (rp->range[0] != 0) {
 177: #ifndef DEBUG
 178:             if (wrp <= 2)
 179:                 put3(O_RANG2+op, ( short ) rp->range[0],
 180:                          ( short ) rp->range[1]);
 181:             else if (rp != nl+T4INT)
 182:                 put(5, O_RANG4+op, rp->range[0], rp->range[1] );
 183: #else
 184:             if (!hp21mx) {
 185:                 if (wrp <= 2)
 186:                     put3(O_RANG2+op,( short ) rp->range[0],
 187:                             ( short ) rp->range[1]);
 188:                 else if (rp != nl+T4INT)
 189:                     put(5,O_RANG4+op,rp->range[0],
 190:                              rp->range[1]);
 191:             } else
 192:                 if (rp != nl+T2INT && rp != nl+T4INT)
 193:                     put3(O_RANG2+op,( short ) rp->range[0],
 194:                             ( short ) rp->range[1]);
 195: #endif
 196:             break;
 197:         }
 198:         /*
 199: 		 * Range whose lower bounds are
 200: 		 * zero can be treated as scalars.
 201: 		 */
 202:     case SCAL:
 203:         if (wrp <= 2)
 204:             put2(O_RSNG2+op, ( short ) rp->range[1]);
 205:         else
 206:             put( 3 , O_RSNG4+op, rp->range[1]);
 207:         break;
 208:     default:
 209:         panic("rangechk");
 210:     }
 211: }
 212: #endif
 213: #endif
 214: 
 215: #ifdef DEBUG
 216: conv(dub)
 217:     int *dub;
 218: {
 219:     int newfp[2];
 220:     double *dp = dub;
 221:     long *lp = dub;
 222:     register int exp;
 223:     long mant;
 224: 
 225:     newfp[0] = dub[0] & 0100000;
 226:     newfp[1] = 0;
 227:     if (*dp == 0.0)
 228:         goto ret;
 229:     exp = ((dub[0] >> 7) & 0377) - 0200;
 230:     if (exp < 0) {
 231:         newfp[1] = 1;
 232:         exp = -exp;
 233:     }
 234:     if (exp > 63)
 235:         exp = 63;
 236:     dub[0] &= ~0177600;
 237:     dub[0] |= 0200;
 238:     mant = *lp;
 239:     mant <<= 8;
 240:     if (newfp[0])
 241:         mant = -mant;
 242:     newfp[0] |= (mant >> 17) & 077777;
 243:     newfp[1] |= (((int) (mant >> 1)) & 0177400) | (exp << 1);
 244: ret:
 245:     dub[0] = newfp[0];
 246:     dub[1] = newfp[1];
 247: }
 248: #endif

Defined functions