2.11BSD#431 - /usr/src/new/PORT/B/src/bint/b1obj.c

   1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
   2: 
   3: /*
   4:   $Header: b1obj.c,v 1.4 85/08/22 16:52:13 timo Exp $
   5: */
   6: 
   7: /* Generic routines for all values */
   8: 
   9: #include "b.h"
  10: #include "b1obj.h"
  11: #ifndef INTEGRATION
  12: #include "b1btr.h"
  13: #include "b1val.h"
  14: #endif
  15: #include "b1tlt.h"
  16: #include "b3err.h"
  17: #include "b3typ.h"
  18: 
  19: #ifndef INTEGRATION
  20: 
  21: Visible bool comp_ok = Yes;         /* Temporary, to catch type errors */
  22: 
  23: relation comp_tlt(), comp_text();   /* From b1lta.c */
  24: 
  25: Hidden Procedure incompatible(v, w) value v, w; {
  26:     value message, m1, m2, m3, m4, m5, m6;
  27:     message= concat(m1= convert(m2= (value) valtype(v), No, No),
  28:          m3= concat(m4= mk_text(" and "),
  29:          m5= convert(m6= (value) valtype(w), No, No)));
  30:     error2(MESS(1400, "incompatible types "), message);
  31:     release(message);
  32:     release(m1); release(m2); release(m3);
  33:     release(m4); release(m5); release(m6);
  34: }
  35: 
  36: Visible relation compare(v, w) value v, w; {
  37:     literal vt, wt;
  38:     int i;
  39:     relation rel;
  40: 
  41:     comp_ok = Yes;
  42: 
  43:     if (v EQ w) return(0);
  44:     if (IsSmallInt(v) && IsSmallInt(w))
  45:         return SmallIntVal(v) - SmallIntVal(w);
  46:     vt = Type(v);
  47:     wt = Type(w);
  48:     switch (vt) {
  49:     case Num:
  50:         if (wt != Num) {
  51:  incomp:
  52:             /*Temporary until static checks are implemented*/
  53:             incompatible(v, w);
  54:             comp_ok= No;
  55:             return -1;
  56:         }
  57:         return(numcomp(v, w));
  58:     case Com:
  59:         if (wt != Com || Nfields(v) != Nfields(w)) goto incomp;
  60:         for (i = 0; i < Nfields(v); i++) {
  61:             rel = compare(*Field(v, i), *Field(w, i));
  62:             if (rel NE 0) return(rel);
  63:         }
  64:         return(0);
  65:     case Tex:
  66:         if (wt != Tex) goto incomp;
  67:         return(comp_text(v, w));
  68:     case Lis:
  69:         if (wt != Lis && wt != ELT) goto incomp;
  70:         return(comp_tlt(v, w));
  71:     case Tab:
  72:         if (wt != Tab && wt != ELT) goto incomp;
  73:         return(comp_tlt(v, w));
  74:     case ELT:
  75:         if (wt != Tab && wt != Lis && wt != ELT) goto incomp;
  76:         return(Root(w) EQ Bnil ? 0 : -1);
  77:     default:
  78:         syserr(MESS(1401, "comparison of unknown types"));
  79:         /*NOTREACHED*/
  80:     }
  81: }
  82: 
  83: /* Used for set'random. Needs to be rewritten so that for small changes in v */
  84: /* you get large changes in hash(v) */
  85: 
  86: Visible double hash(v) value v; {
  87:     if (Is_number(v)) return numhash(v);
  88:     else if (Is_compound(v)) {
  89:         int len= Nfields(v), k; double d= .404*len;
  90:         k_Overfields {
  91:             d= .874*d+.310*hash(*Field(v, k));
  92:         }
  93:         return d;
  94:     } else {
  95:         int len= length(v), k; double d= .404*len;
  96:         if (len == 0) return .909;
  97:         else if (Is_text(v)) {
  98:             value ch;
  99:             k_Over_len {
 100:                 ch= thof(k+1, v);
 101:                 d= .987*d+.277*charval(ch);
 102:                 release(ch);
 103:             }
 104:             return d;
 105:         } else if (Is_list(v)) {
 106:             value el;
 107:             k_Over_len {
 108:                 d= .874*d+.310*hash(el= thof(k+1, v));
 109:                 release(el);
 110:             }
 111:             return d;
 112:         } else if (Is_table(v)) {
 113:             k_Over_len {
 114:                 d= .874*d+.310*hash(*key(v, k))
 115:                      +.123*hash(*assoc(v, k));
 116:             }
 117:             return d;
 118:         } else {
 119:             syserr(MESS(1402, "hash called with unknown type"));
 120:             return (double) Dummy;
 121:         }
 122:     }
 123: }
 124: 
 125: Hidden Procedure concato(v, t) value* v; value t; {
 126:     value v1= *v;
 127:     *v= concat(*v, t);
 128:     release(v1);
 129: }
 130: 
 131: Visible value convert(v, coll, outer) value v; bool coll, outer; {
 132:     value t, quote, c, cv, sep, th, open, close; int k, len; char ch;
 133:     switch (Type(v)) {
 134:     case Num:
 135:         return mk_text(convnum(v));
 136:     case Tex:
 137:         if (outer) return copy(v);
 138:         quote= mk_text("\"");
 139:         len= length(v);
 140:         t= copy(quote);
 141:         for (k=1; k<=len; k++) {
 142:             c= thof(k, v);
 143:             ch= charval(c);
 144:             concato(&t, c);
 145:             if (ch == '"' || ch == '`') concato(&t, c);
 146:             release(c);
 147:         }
 148:         concato(&t, quote);
 149:         release(quote);
 150:         break;
 151:     case Com:
 152:         len= Nfields(v);
 153:         outer&= coll;
 154:         sep= mk_text(outer ? " " : ", ");
 155:         t= mk_text(coll ? "" : "(");
 156:         k_Over_len {
 157:             concato(&t, cv= convert(*Field(v, k), No, outer));
 158:             release(cv);
 159:             if (!Last(k)) concato(&t, sep);
 160:         }
 161:         release(sep);
 162:         if (!coll) {
 163:             concato(&t, cv= mk_text(")"));
 164:             release(cv);
 165:         }
 166:         break;
 167:     case Lis:
 168:     case ELT:
 169:         len= length(v);
 170:         t= mk_text("{");
 171:         sep= mk_text("; ");
 172:         for (k=1; k<=len; k++) {
 173:             concato(&t, cv= convert(th= thof(k, v), No, No));
 174:             release(cv); release(th);
 175:             if (k != len) concato(&t, sep);
 176:         }
 177:         release(sep);
 178:         concato(&t, cv= mk_text("}"));
 179:         release(cv);
 180:         break;
 181:     case Tab:
 182:         len= length(v);
 183:         open= mk_text("[");
 184:         close= mk_text("]: ");
 185:         sep= mk_text("; ");
 186:         t= mk_text("{");
 187:         k_Over_len {
 188:             concato(&t, open);
 189:             concato(&t, cv= convert(*key(v, k), Yes, No));
 190:             release(cv);
 191:             concato(&t, close);
 192:             concato(&t, cv= convert(*assoc(v, k), No, No));
 193:             release(cv);
 194:             if (!Last(k)) concato(&t, sep);
 195:         }
 196:         concato(&t, cv= mk_text("}")); release(cv);
 197:         release(open); release(close); release(sep);
 198:         break;
 199:     default:
 200:         if (bugs || testing) {
 201:             t= mk_text("?");
 202:             concato(&t, cv= mkchar(Type(v))); release(cv);
 203:             concato(&t, cv= mkchar('$')); release(cv);
 204:             break;
 205:         }
 206:         syserr(MESS(1403, "unknown type in convert"));
 207:     }
 208:     return t;
 209: }
 210: 
 211: Hidden value adj(v, w, side) value v, w; char side; {
 212:     value t, c, sp, r, i;
 213:     int len, wid, diff, left, right;
 214:     c= convert(v, Yes, Yes);
 215:     len= length(c);
 216:     wid= intval(w);
 217:     if (wid<=len) return c;
 218:     else {
 219:         diff= wid-len;
 220:         if (side == 'L') { left= 0; right= diff; }
 221:         else if (side == 'R') { left= diff; right= 0; }
 222:         else {left= diff/2; right= (diff+1)/2; }
 223:         sp= mk_text(" ");
 224:         if (left == 0) t= c;
 225:         else {
 226:             t= repeat(sp, i= mk_integer(left)); release(i);
 227:             concato(&t, c);
 228:             release(c);
 229:         }
 230:         if (right != 0) {
 231:             r= repeat(sp, i= mk_integer(right)); release(i);
 232:             concato(&t, r);
 233:             release(r);
 234:         }
 235:         release(sp);
 236:         return t;
 237:     }
 238: }
 239: 
 240: Visible value adjleft(v, w) value v, w; {
 241:     return adj(v, w, 'L');
 242: }
 243: 
 244: Visible value adjright(v, w) value v, w; {
 245:     return adj(v, w, 'R');
 246: }
 247: 
 248: Visible value centre(v, w) value v, w; {
 249:     return adj(v, w, 'C');
 250: }
 251: 
 252: #else INTEGRATION
 253: 
 254: #define Sgn(d) (d)
 255: 
 256: Visible relation compare(v, w) value v, w; {
 257:     literal vt= Type(v), wt= Type(w);
 258:     register intlet vlen, wlen, len, k;
 259:     value message;
 260:     vlen= IsSmallInt(v) ? 0 : Length(v);
 261:     wlen= IsSmallInt(w) ? 0 : Length(w);
 262:     if (v == w) return 0;
 263:     if (!(vt == wt && !(vt == Com && vlen != wlen) ||
 264:                 vt == ELT && (wt == Lis || wt == Tab) ||
 265:                 wt == ELT && (vt == Lis || vt == Tab))) {
 266:         message= concat(convert((value) valtype(v), No, No),
 267:              concat(mk_text(" and "),
 268:              convert((value) valtype(w), No, No)));
 269:         error2(MESS(1404, "incompatible types "), message);
 270:                /*doesn't return: so can't release message*/
 271:     }
 272:     if (vt != Num && (vlen == 0 || wlen == 0))
 273:         return Sgn(vlen-wlen);
 274:     switch (vt) {
 275:     case Num: return numcomp(v, w);
 276:     case Tex: return strcmp(Str(v), Str(w));
 277: 
 278:     case Com:
 279:     case Lis:
 280:     case Tab:
 281:     case ELT:
 282:         {value *vp= Ats(v), *wp= Ats(w);
 283:          relation c;
 284:             len= vlen < wlen ? vlen : wlen;
 285:             Overall if ((c= compare(*vp++, *wp++)) != 0) return c;
 286:             return Sgn(vlen-wlen);
 287:         }
 288:     default:
 289:         syserr(MESS(1405, "comparison of unknown types"));
 290:         /* NOTREACHED */
 291:     }
 292: }
 293: 
 294: Visible double hash(v) value v; {
 295:     literal t= Type(v); intlet len= Length(v), k; double d= t+.404*len;
 296:     switch (t) {
 297:     case Num: return numhash(v);
 298:     case Tex:
 299:         {string vp= Str(v);
 300:             Overall d= .987*d+.277*(*vp++);
 301:             return d;
 302:         }
 303:     case Com:
 304:     case Lis:
 305:     case Tab:
 306:     case ELT:
 307:         {value *vp= Ats(v);
 308:             if (len == 0) return .909;
 309:             Overall d= .874*d+.310*hash(*vp++);
 310:             return d;
 311:         }
 312:     default:
 313:         syserr(MESS(1406, "hash called with unknown type"));
 314:         /* NOTREACHED */
 315:     }
 316: }
 317: 
 318: #endif INTEGRATION

Defined functions

Defined variables

Defined macros