4.3BSD/usr/contrib/B/src/bsmall/b2loc.c

/* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1984. */
/* $Header: b2loc.c,v 1.1 84/06/28 00:49:16 timo Exp $ */

/* B locations and environments */
#include "b.h"
#include "b0con.h"
#include "b1obj.h"
#include "b2env.h" /* for bndtgs */
#include "b2sem.h"

Hidden value* location(l) loc l; {
	value *ll;
	if (Is_simploc(l)) {
		simploc *sl= Simploc(l);
		if (!in_env(sl->e->tab, sl->i, &ll)) error("target still empty");
		return ll;
	} else if (Is_tbseloc(l)) {
		tbseloc *tl= Tbseloc(l);
		ll= adrassoc(*location(tl->R), tl->K);
		if (ll == Pnil) error("key not in table");
		return ll;
	} else {
		syserr("call of location with improper type");
		return (value *) Dummy;
	}
}

Hidden Procedure uniquify(l) loc l; {
	if (Is_simploc(l)) {
		simploc *sl= Simploc(l);
		value *ta= &(sl->e->tab), ke= sl->i;
		uniql(ta);
		check_location(l);
		uniq_assoc(*ta, ke);
	} else if (Is_tbseloc(l)) {
		tbseloc *tl= Tbseloc(l);
		value t, ke;
		uniquify(tl->R);
		t= *location(tl->R); ke= tl->K;
		if (!Is_table(t)) error("selection on non-table");
		if (empty(t)) error("selection on empty table");
		check_location(l);
		uniq_assoc(t, ke);
	} else if (Is_trimloc(l)) { syserr("uniquifying trimloc");
	} else if (Is_compound(l)) { syserr("uniquifying comploc");
	} else syserr("uniquifying non-location");
}

Visible Procedure check_location(l) loc l; {
	VOID location(l);
	/* location may produce an error message */
}

Visible value content(l) loc l; {
	return copy(*location(l));
}

Visible loc trim_loc(R, B, C) loc R; intlet B, C; {
	if (Is_trimloc(R)) {
		trimloc *rr= Trimloc(R);
		return mk_trimloc(rr->R, B, C);
	} else if (Is_simploc(R) || Is_tbseloc(R)) {
		return mk_trimloc(R, B, C);
	} else {
		error("trim (@ or |) on target of improper type");
		/* NOTREACHED */
	}
}

Visible loc tbsel_loc(R, K) loc R; value K; {
	if (Is_simploc(R) || Is_tbseloc(R)) return mk_tbseloc(R, K);
	else error("selection on target of improper type");
	/* NOTREACHED */
}

Visible loc local_loc(i) basidf i; { return mk_simploc(i, curnv); }

Visible loc global_loc(i) basidf i; { return mk_simploc(i, prmnv); }

Visible Procedure put(v, l) value v; loc l; {
	if (Is_simploc(l)) {
		simploc *sl= Simploc(l);
		e_replace(v, &(sl->e->tab), sl->i);
	} else if (Is_trimloc(l)) {
		trimloc *tl= Trimloc(l);
		value rr, nn, head, tail, part;
		intlet B= tl->B, C= tl->C, len;
		rr= *location(tl->R);
		if (!Is_text(rr)) error("trim target contains no text");
		if (!Is_text(v))
		    error("putting non-text in trim(@ or|) on text location");
		len= length(rr);
		if (B < 0 || C < 0 || B+C > len)
		    error("trim (@ or |) on text location out of bounds");
		head= trim(rr, 0, len-B); /* rr|B */
		tail= trim(rr, len-C, 0); /* rr@(#rr-C+1) */
		part= concat(head, v);
		nn= concat(part, tail);
		put(nn, tl->R);
		release(nn); release(head); release(tail); release(part);
	} else if (Is_compound(l)) {
		intlet k, len= Nfields(l);
		if (!Is_compound(v))
		    error("putting non-compound in compound location");
		if (Nfields(v) != Nfields(l))
		    error("putting compound in compound location of different length");
		k_Overfields { put(*field(v, k), *field(l, k)); }
	} else if (Is_tbseloc(l)) {
		tbseloc *tl= Tbseloc(l);
		uniquify(tl->R);
		replace(v, location(tl->R), tl->K);
	} else error("putting in non-target");
}

Hidden bool l_exists(l) loc l; {
	if (Is_simploc(l)) {
		simploc *sl= Simploc(l);
		return in_keys(sl->i, sl->e->tab);
	} else if (Is_trimloc(l)) {
		error("deleting trimmed (@ or |) target");
		return No;
	} else if (Is_compound(l)) {
		intlet k, len= Nfields(l);
		k_Overfields { if (!l_exists(*field(l, k))) return No; }
		return Yes;
	} else if (Is_tbseloc(l)) {
		tbseloc *tl= Tbseloc(l);
		uniquify(tl->R);
		return in_keys(tl->K, *location(tl->R));
	} else {
		error("deleting non-target");
		return No;
	}
}

Hidden Procedure l_del(l) loc l; {
	if (Is_simploc(l)) {
		simploc *sl= Simploc(l);
		if (in_keys(sl->i, sl->e->tab)) {
			uniql(&(sl->e->tab)); /*no need?: see delete*/
			e_delete(&(sl->e->tab), sl->i);
		}
	} else if (Is_trimloc(l)) {
		error("deleting trimmed (@ or |) target");
	} else if (Is_compound(l)) {
		intlet k, len= Nfields(l);
		k_Overfields { l_del(*field(l, k)); }
	} else if (Is_tbseloc(l)) {
		tbseloc *tl= Tbseloc(l);
		value *lc;
		uniquify(tl->R);
		lc= location(tl->R);
		if (in_keys(tl->K, *lc)) delete(lc, tl->K);
	} else error("deleting non-target");
}

Visible Procedure l_delete(l) loc l; {
	if (l_exists(l)) l_del(l);
	else error("deleting non-existent target");
}

Visible Procedure l_insert(v, l) value v; loc l; {
	value *ll;
	uniquify(l);
	ll= location(l);
	insert(v, ll);
}

Visible Procedure l_remove(v, l) value v; loc l; {
	uniquify(l);
	remove(v, location(l));
}

Visible Procedure choose(l, v) loc l; value v; {
	value w, s, r;
	if (!Is_tlt(v)) error("choosing from non-text, -list or -table");
	s= size(v);
	if (compare(s, zero) == 0)
		error("choosing from empty text, list or table");
	/* PUT (floor(random*#v) + 1) th'of v IN l */
	r= prod(w= random(), s); release(w); release(s);
	w= floorf(r); release(r);
	r= sum(w, one); release(w);
	put(w= th_of(r, v), l); release(w);
}

Visible Procedure draw(l) loc l; {
	value r= random();
	put(r, l);
	release(r);
}

Visible Procedure bind(l) loc l; {
	if (Is_simploc(l)) {
		simploc *ll= Simploc(l);
		if (!in(ll->i, *bndtgs)) /* kludge */
			insert(ll->i, bndtgs);
	} else if (Is_compound(l)) {
		intlet k, len= Nfields(l);
		k_Overfields { bind(*field(l, k)); }
	} else if (Is_trimloc(l)) {
		pprerr("t@p or t|p not allowed in ranger", "");
	} else if (Is_tbseloc(l)) {
		pprerr("t[e] not allowed in ranger", "");
	} else error("binding non-identifier");
}