4.3BSD/usr/contrib/B/src/bint/b1obj.c

/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */

/*
  $Header: b1obj.c,v 1.4 85/08/22 16:52:13 timo Exp $
*/

/* Generic routines for all values */

#include "b.h"
#include "b1obj.h"
#ifndef INTEGRATION
#include "b1btr.h"
#include "b1val.h"
#endif
#include "b1tlt.h"
#include "b3err.h"
#include "b3typ.h"

#ifndef INTEGRATION

Visible bool comp_ok = Yes; 		/* Temporary, to catch type errors */

relation comp_tlt(), comp_text();	/* From b1lta.c */

Hidden Procedure incompatible(v, w) value v, w; {
	value message, m1, m2, m3, m4, m5, m6;
	message= concat(m1= convert(m2= (value) valtype(v), No, No),
		 m3= concat(m4= mk_text(" and "),
		 m5= convert(m6= (value) valtype(w), No, No)));
	error2(MESS(1400, "incompatible types "), message);
	release(message);
	release(m1); release(m2); release(m3);
	release(m4); release(m5); release(m6);
}

Visible relation compare(v, w) value v, w; {
	literal vt, wt;
	int i;
	relation rel;
	
	comp_ok = Yes;

	if (v EQ w) return(0);
	if (IsSmallInt(v) && IsSmallInt(w))
		return SmallIntVal(v) - SmallIntVal(w);
	vt = Type(v);
	wt = Type(w);
	switch (vt) {
	case Num:
		if (wt != Num) {
 incomp:
			/*Temporary until static checks are implemented*/
 			incompatible(v, w);
			comp_ok= No;
			return -1;
 		}
		return(numcomp(v, w));
	case Com:
		if (wt != Com || Nfields(v) != Nfields(w)) goto incomp;
		for (i = 0; i < Nfields(v); i++) {
			rel = compare(*Field(v, i), *Field(w, i));
			if (rel NE 0) return(rel);
		}
		return(0);
	case Tex:
		if (wt != Tex) goto incomp;
		return(comp_text(v, w));
	case Lis:
		if (wt != Lis && wt != ELT) goto incomp;
		return(comp_tlt(v, w));
	case Tab:
		if (wt != Tab && wt != ELT) goto incomp;
		return(comp_tlt(v, w));
	case ELT:
		if (wt != Tab && wt != Lis && wt != ELT) goto incomp;
		return(Root(w) EQ Bnil ? 0 : -1);
	default: 
		syserr(MESS(1401, "comparison of unknown types"));
		/*NOTREACHED*/
	}
}

/* Used for set'random. Needs to be rewritten so that for small changes in v */
/* you get large changes in hash(v) */

Visible double hash(v) value v; {
	if (Is_number(v)) return numhash(v);
	else if (Is_compound(v)) {
		int len= Nfields(v), k; double d= .404*len;
		k_Overfields {
			d= .874*d+.310*hash(*Field(v, k));
		}
		return d;
	} else {
		int len= length(v), k; double d= .404*len;
		if (len == 0) return .909;
		else if (Is_text(v)) {
			value ch;
			k_Over_len {
				ch= thof(k+1, v);
				d= .987*d+.277*charval(ch);
				release(ch);
			}
			return d;
		} else if (Is_list(v)) {
			value el;
			k_Over_len {
				d= .874*d+.310*hash(el= thof(k+1, v));
				release(el);
			}
			return d;
		} else if (Is_table(v)) {
			k_Over_len {
				d= .874*d+.310*hash(*key(v, k))
					 +.123*hash(*assoc(v, k));
			}
			return d;
		} else {
			syserr(MESS(1402, "hash called with unknown type"));
			return (double) Dummy;
		}
	}
}

Hidden Procedure concato(v, t) value* v; value t; {
	value v1= *v;
	*v= concat(*v, t);
	release(v1);
}

Visible value convert(v, coll, outer) value v; bool coll, outer; {
	value t, quote, c, cv, sep, th, open, close; int k, len; char ch;
	switch (Type(v)) {
	case Num:
		return mk_text(convnum(v));
	case Tex:
		if (outer) return copy(v);
		quote= mk_text("\"");
		len= length(v);
		t= copy(quote);
		for (k=1; k<=len; k++) {
			c= thof(k, v);
			ch= charval(c);
			concato(&t, c);
			if (ch == '"' || ch == '`') concato(&t, c);
			release(c);
		}
		concato(&t, quote);
		release(quote);
		break;
	case Com:
		len= Nfields(v);
		outer&= coll;
		sep= mk_text(outer ? " " : ", ");
		t= mk_text(coll ? "" : "(");
		k_Over_len {
			concato(&t, cv= convert(*Field(v, k), No, outer));
			release(cv);
			if (!Last(k)) concato(&t, sep);
		}
		release(sep);
		if (!coll) {
			concato(&t, cv= mk_text(")"));
			release(cv);
		}
		break;
	case Lis:
	case ELT:
		len= length(v);
		t= mk_text("{");
		sep= mk_text("; ");
		for (k=1; k<=len; k++) {
			concato(&t, cv= convert(th= thof(k, v), No, No));
			release(cv); release(th);
			if (k != len) concato(&t, sep);
		}
		release(sep);
		concato(&t, cv= mk_text("}"));
		release(cv);
		break;
	case Tab:
		len= length(v);
		open= mk_text("[");
		close= mk_text("]: ");
		sep= mk_text("; ");
		t= mk_text("{");
		k_Over_len {
			concato(&t, open);
			concato(&t, cv= convert(*key(v, k), Yes, No));
			release(cv);
			concato(&t, close);
			concato(&t, cv= convert(*assoc(v, k), No, No));
			release(cv);
			if (!Last(k)) concato(&t, sep);
		}
		concato(&t, cv= mk_text("}")); release(cv);
		release(open); release(close); release(sep);
		break;
	default:
		if (bugs || testing) {
			t= mk_text("?");
			concato(&t, cv= mkchar(Type(v))); release(cv);
			concato(&t, cv= mkchar('$')); release(cv);
			break;
		}
		syserr(MESS(1403, "unknown type in convert"));
	}
	return t;
}

Hidden value adj(v, w, side) value v, w; char side; {
	value t, c, sp, r, i;
	int len, wid, diff, left, right;
	c= convert(v, Yes, Yes);
	len= length(c);
	wid= intval(w);
	if (wid<=len) return c;
	else {
		diff= wid-len;
		if (side == 'L') { left= 0; right= diff; }
		else if (side == 'R') { left= diff; right= 0; }
		else {left= diff/2; right= (diff+1)/2; }
		sp= mk_text(" ");
		if (left == 0) t= c;
		else {
			t= repeat(sp, i= mk_integer(left)); release(i);
			concato(&t, c);
			release(c);
		}
		if (right != 0) {
			r= repeat(sp, i= mk_integer(right)); release(i);
			concato(&t, r);
			release(r);
		}
		release(sp);
		return t;
	}
}

Visible value adjleft(v, w) value v, w; {
	return adj(v, w, 'L');
}

Visible value adjright(v, w) value v, w; {
	return adj(v, w, 'R');
}

Visible value centre(v, w) value v, w; {
	return adj(v, w, 'C');
}

#else INTEGRATION

#define Sgn(d) (d)

Visible relation compare(v, w) value v, w; {
	literal vt= Type(v), wt= Type(w);
	register intlet vlen, wlen, len, k;
	value message;
	vlen= IsSmallInt(v) ? 0 : Length(v);
	wlen= IsSmallInt(w) ? 0 : Length(w);
	if (v == w) return 0;
	if (!(vt == wt && !(vt == Com && vlen != wlen) ||
			    vt == ELT && (wt == Lis || wt == Tab) ||
			    wt == ELT && (vt == Lis || vt == Tab))) {
		message= concat(convert((value) valtype(v), No, No),
			 concat(mk_text(" and "),
			 convert((value) valtype(w), No, No)));
		error2(MESS(1404, "incompatible types "), message);
		       /*doesn't return: so can't release message*/
	}
	if (vt != Num && (vlen == 0 || wlen == 0))
		return Sgn(vlen-wlen);
	switch (vt) {
	case Num: return numcomp(v, w);
	case Tex: return strcmp(Str(v), Str(w));

	case Com:
	case Lis:
	case Tab:
	case ELT:
		{value *vp= Ats(v), *wp= Ats(w);
		 relation c;
			len= vlen < wlen ? vlen : wlen;
			Overall if ((c= compare(*vp++, *wp++)) != 0) return c;
			return Sgn(vlen-wlen);
		}
	default:
		syserr(MESS(1405, "comparison of unknown types"));
		/* NOTREACHED */
	}
}

Visible double hash(v) value v; {
	literal t= Type(v); intlet len= Length(v), k; double d= t+.404*len;
	switch (t) {
	case Num: return numhash(v);
	case Tex:
		{string vp= Str(v);
			Overall d= .987*d+.277*(*vp++);
			return d;
		}
	case Com:
	case Lis:
	case Tab:
	case ELT:
		{value *vp= Ats(v);
			if (len == 0) return .909;
			Overall d= .874*d+.310*hash(*vp++);
			return d;
		}
	default:
		syserr(MESS(1406, "hash called with unknown type"));
		/* NOTREACHED */
	}
}

#endif INTEGRATION