```   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; {
242: }
243:
244: Visible value adjright(v, w) value v, w; {
246: }
247:
248: Visible value centre(v, w) value v, w; {
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

adj defined in line 211; used 3 times
adjleft defined in line 240; used 1 times
adjright defined in line 244; used 1 times
centre defined in line 248; used 1 times
concato defined in line 125; used 19 times
hash defined in line 294; used 7 times
incompatible defined in line 25; used 1 times
• in line 53

#### Defined variables

comp_ok defined in line 21; used 2 times

#### Defined macros

Sgn defined in line 254; used 2 times
 Last modified: 1985-08-27 Generated: 2016-12-26 Generated by src2html V0.67 page hit count: 2914