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

Compare this file to the similar file:
Show the results in this format: 

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

/*
  $Header: b2tcP.c,v 1.4 85/08/22 16:57:02 timo Exp $
*/

/* polytype representation */

#include "b.h"
#include "b1obj.h"
#include "b2tcP.h"

/* A polytype is a compound with two fields.
 * The first field is a B text, and holds the typekind.
 * If the typekind is 'Variable', the second field is 
 *   a B text, holding the identifier of the variable;
 * otherwise, the second field is a compound of sub(poly)types,
 *   indexed from 0 to one less then the number of subtypes.
 */

#define Kin	0
#define Sub	1
#define Id	Sub
#define Asc	0
#define Key	1

#define Kind(u)		((typekind) *Field((value) (u), Kin))
#define Psubtypes(u)	(Field((value) (u), Sub))
#define Ident(u)	(*Field((value) (u), Id))

typekind var_kind;
typekind num_kind;
typekind tex_kind;
typekind lis_kind;
typekind tab_kind;
typekind com_kind;
typekind t_n_kind;
typekind l_t_kind;
typekind tlt_kind;
typekind err_kind;

polytype num_type;
polytype tex_type;
polytype err_type;
polytype t_n_type;

/* Making, setting and accessing (the fields of) polytypes */

Visible polytype mkt_polytype(k, nsub) typekind k; intlet nsub; {
	value u;
	
	u = mk_compound(2);
	*Field(u, Kin)= copy((value) k);
	*Field(u, Sub)= mk_compound(nsub);
	return ((polytype) u);
}

Procedure putsubtype(sub, u, isub) polytype sub, u; intlet isub; {
	*Field(*Psubtypes(u), isub)= (value) sub;
}

typekind kind(u) polytype u; {
	return (Kind(u));
}

intlet nsubtypes(u) polytype u; {
	return (Nfields(*Psubtypes(u)));
}

polytype subtype(u, i) polytype u; intlet i; {
	return ((polytype) *Field(*Psubtypes(u), i));
}

polytype asctype(u) polytype u; {
	return (subtype(u, Asc));
}

polytype keytype(u) polytype u; {
	return (subtype(u, Key));
}

value ident(u) polytype u; {
	return (Ident(u));
}

/* making new polytypes */

polytype mkt_number() {
	return(p_copy(num_type));
}

polytype mkt_text() {
	return(p_copy(tex_type));
}

polytype mkt_tn() {
	return(p_copy(t_n_type));
}

polytype mkt_error() {
	return(p_copy(err_type));
}

polytype mkt_list(s) polytype s; {
	polytype u;
	
	u = mkt_polytype(lis_kind, 1);
	putsubtype(s, u, Asc);
	return (u);
}

polytype mkt_table(k, a) polytype k, a; {
	polytype u;
	
	u = mkt_polytype(tab_kind, 2);
	putsubtype(a, u, Asc);
	putsubtype(k, u, Key);
	return (u);
}

polytype mkt_lt(s) polytype s; {
	polytype u;
	
	u = mkt_polytype(l_t_kind, 1);
	putsubtype(s, u, Asc);
	return (u);
}

polytype mkt_tlt(s) polytype s; {
	polytype u;
	
	u = mkt_polytype(tlt_kind, 1);
	putsubtype(s, u, Asc);
	return (u);
}

polytype mkt_compound(nsub) intlet nsub; {
	return mkt_polytype(com_kind, nsub);
}

polytype mkt_var(id) value id; {
	polytype u;
	
	u = mk_compound(2);
	*Field(u, Kin)= copy((value) var_kind);
	*Field(u, Id)= id;
	return (u);
}

Hidden value nnewvar;

polytype mkt_newvar() {
	value v;
	v = sum(nnewvar, one);
	release(nnewvar);
	nnewvar = v;
	return mkt_var(convert(nnewvar, No, No));
}

polytype p_copy(u) polytype u; {
	return((polytype) copy((polytype) u));
}

Procedure p_release(u) polytype u; {
	release((polytype) u);
}

/* predicates */

bool are_same_types(u, v) polytype u, v; {
	if (compare((value) Kind(u), (value) Kind(v)) NE 0)
		return (No);
	else if (t_is_var(Kind(u)))
		return (compare(Ident(u), Ident(v)) EQ 0);
	else
		return (
			(nsubtypes(u) EQ nsubtypes(v))
			&&
			(compare(*Psubtypes(u), *Psubtypes(v)) EQ 0)
		);
}

bool have_same_structure(u, v) polytype u, v; {
	return(
		(compare((value) Kind(u), (value) Kind(v)) EQ 0)
		&&
		nsubtypes(u) EQ nsubtypes(v)
	);
}

bool t_is_number(kind) typekind kind; {
	return (compare((value) kind, (value) num_kind) EQ 0 ? Yes : No);
}

bool t_is_text(kind) typekind kind; {
	return (compare((value) kind, (value) tex_kind) EQ 0 ? Yes : No);
}

bool t_is_tn(kind) typekind kind; {
	return (compare((value) kind, (value) t_n_kind) EQ 0 ? Yes : No);
}

bool t_is_error(kind) typekind kind; {
	return (compare((value) kind, (value) err_kind) EQ 0 ? Yes : No);
}

bool t_is_list(kind) typekind kind; {
	return (compare((value) kind, (value) lis_kind) EQ 0 ? Yes : No);
}

bool t_is_table(kind) typekind kind; {
	return (compare((value) kind, (value) tab_kind) EQ 0 ? Yes : No);
}

bool t_is_lt(kind) typekind kind; {
	return (compare((value) kind, (value) l_t_kind) EQ 0 ? Yes : No);
}

bool t_is_tlt(kind) typekind kind; {
	return (compare((value) kind, (value) tlt_kind) EQ 0 ? Yes : No);
}

bool t_is_compound(kind) typekind kind; {
	return (compare((value) kind, (value) com_kind) EQ 0 ? Yes : No);
}

bool t_is_var(kind) typekind kind; {
	return (compare((value) kind, (value) var_kind) EQ 0 ? Yes : No);
}

bool has_number(kind) typekind kind; {
	if (compare(kind, num_kind) EQ 0 || compare(kind, t_n_kind) EQ 0)
		return (Yes);
	else
		return (No);
}

bool has_text(kind) typekind kind; {
	if (compare(kind, tex_kind) EQ 0 || compare(kind, t_n_kind) EQ 0)
		return (Yes);
	else
		return (No);
}

bool has_lt(kind) typekind kind; {
	if (compare(kind, l_t_kind) EQ 0 || compare(kind, tlt_kind) EQ 0)
		return (Yes);
	else
		return (No);
}

/* The table "typeof" maps the identifiers of the variables (B texts)
 * to polytypes.
 */
 
value typeof;

Procedure repl_type_of(u, p) polytype u, p; {
	replace((value) p, &typeof, Ident(u));
}

bool table_has_type_of(u) polytype u; {
	return(in_keys(Ident(u), typeof));
}

polytype type_of(u) polytype u; {
	return((polytype) *adrassoc(typeof, Ident(u)));
}

polytype bottom_var(u) polytype u; {
	polytype b;

	if (!t_is_var(Kind(u)))
		return (u);
	/* Kind(u) == Variable */
	while (table_has_type_of(u)) {
		b = type_of(u);
		if (t_is_var(Kind(b)))
			u = b;
		else
			break;
	}
	/* Kind(u) == Variable && !table_has_type_of(u)*/
	return (u);
}

Visible Procedure usetypetable(t) value t; {
	typeof = t;
}

Visible Procedure deltypetable() {
	release(typeof);
}

/* init */

Visible Procedure initpol() {
	num_kind = mk_text("Number");
	num_type = mkt_polytype(num_kind, 0);
	tex_kind = mk_text("Text");
	tex_type = mkt_polytype(tex_kind, 0);
	t_n_kind = mk_text("TN");
	t_n_type = mkt_polytype(t_n_kind, 0);
	err_kind = mk_text("Error");
	err_type = mkt_polytype(err_kind, 0);
	
	lis_kind = mk_text("List");
	tab_kind = mk_text("Table");
	com_kind = mk_text("Compound");
	l_t_kind = mk_text("LT");
	tlt_kind = mk_text("TLT");
	var_kind = mk_text("Variable");
	
	nnewvar = zero;
}