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

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

/* B tables */
#include "b.h"
#include "b1obj.h"
#include "B1tlt.h"

Visible value* key(v, k) value v; intlet k; { /* k in {0..size-1}; no copy */
	return Key(v, k);
}

Visible value* assoc(v, k) value v; intlet k; { /* k in {0..size-1}; no copy */
	return Assoc(v, k);
}

Visible value keys(ta) value ta; {
	value li= grab_lis(Length(ta)), *le, *te= (value *)Ats(ta);
	int k, len= Length(ta);
	if(!Is_table(ta)) error("in keys t, t is not a table");
	le= (value *)Ats(li);
	Overall { *le++= copy(Cts(*te++)); }
	return li;
}

Visible value key_elem(t, i) value t; intlet i; { /*The key of the i-th entry*/
	return *Key(t, i);
}

/* adrassoc returns a pointer to the associate, rather than
   the associate itself, so that the caller can decide if a copy
   should be taken or not. If the key is not found, Pnil is returned. */
Visible value* adrassoc(t, ke) value t, ke; {
	intlet where;
	if (t->type != Tab && t->type != ELT) error("selection on non-table");
	return found(key_elem, t, ke, &where) ? Assoc(t, where) : Pnil;
}

Visible Procedure uniq_assoc(ta, ke) value ta, ke; {
	intlet k;
	if (found(key_elem, ta, ke, &k)) {
		uniql(Ats(ta)+k);
		uniql(Assoc(ta,k));
	} else syserr("uniq_assoc called for non-existent table entry");
}

Visible Procedure replace(v, ta, ke) value *ta, ke, v; {
	intlet len= Length(*ta); value *tp, *tq;
	intlet k, kk;
	uniql(ta);
	if ((*ta)->type == ELT) (*ta)->type = Tab;
	else if ((*ta)->type != Tab) error("replacing in non-table");
	if (found(key_elem, *ta, ke, &k)) {
		value *a;
		uniql(Ats(*ta)+k);
		a= Assoc(*ta, k);
		uniql(a);
		release(*a);
		*a= copy(v);
		return;
	} else {
		xtndlt(ta, 1);
		tq= Ats(*ta)+len; tp= tq-1;
		for (kk= len; kk > k; kk--) *tq--= *tp--;
		*tq= grab_com(2);
		Cts(*tq)= copy(ke);
		Dts(*tq)= copy(v);
	}
}

Visible bool in_keys(ke, tl) value ke, tl; {
	intlet dummy;
	if (tl->type == ELT) return No;
	if (tl->type != Tab) syserr("in_keys applied to non-table");
	return found(key_elem, tl, ke, &dummy);
}

Visible Procedure delete(tl, ke) value *tl, ke; {
	intlet len, k; value *tp;
	if ((*tl)->type == ELT) syserr("deleting table entry from empty table");
	if ((*tl)->type != Tab) syserr("deleting table entry from non-table");
	tp= Ats(*tl); len= Length(*tl);
	if (!found(key_elem, *tl, ke, &k))
		syserr("deleting non-existent table entry");
	if (Unique(*tl)) {
		release(*(tp+=k));
		for (k= k; k < len; k++) {*tp= *(tp+1); tp++;}
		xtndlt(tl, -1);
	} else {
		intlet kk; value *tq= Ats(*tl);
		release(*tl);
		*tl= grab_tab(--len);
		tp= Ats(*tl);
		for (kk= 0; kk < len; kk++) {
			*tp++= copy (*tq++);
			if (kk == k) tq++;
		}
	}
}