--* From PETEB%WATSON.vnet.ibm.com@yktvmv.watson.ibm.com  Sun Mar 13 22:04:04 1994
--* Received: from yktvmv.watson.ibm.com by leonardo.watson.ibm.com (AIX 3.2/UCB 5.64/920123)
--*           id AA24380; Sun, 13 Mar 1994 22:04:04 -0500
--* X-External-Networks: yes
--* Received: from watson.vnet.ibm.com by yktvmv.watson.ibm.com (IBM VM SMTP V2R3)
--*    with BSMTP id 1919; Sun, 13 Mar 94 22:03:43 EST
--* Received: from YKTVMV by watson.vnet.ibm.com with "VAGENT.V1.0"
--*           id <A.PETEB.NOTE.VAGENT2.7931.Mar.13.22:03:41.-0500>
--*           for asbugs@watson; Sun, 13 Mar 94 22:03:42 -0500
--* Received: from YKTVMV by watson.vnet.ibm.com with "VAGENT.V1.0"
--*           id 7927; Sun, 13 Mar 1994 22:03:40 EST
--* Received: from pi.watson.ibm.com by yktvmv.watson.ibm.com (IBM VM SMTP V2R3)
--*    with TCP; Sun, 13 Mar 94 22:03:39 EST
--* Received: by pi.watson.ibm.com (AIX 3.2/UCB 5.64/4.03)
--*           id AA15888; Sun, 13 Mar 1994 22:01:53 -0600
--* Date: Sun, 13 Mar 1994 22:01:53 -0600
--* From: pab@pi.watson.ibm.com
--* Message-Id: <9403140401.AA15888@pi.watson.ibm.com>
--* To: asbugs@watson.ibm.com
--* Subject: [5] Seg. fault in error printing routines [runtime.as][v34.4]

--@ Fixed  by:  PI   Mon Apr 25 17:41:39 EDT 1994 
--@ Tested by:  none 
--@ Summary:    bug found in terror.c. This probably will fix some other bug. 


-- Runtime support library for Asharp.

-- Contains the runtime implementation of domains, and other callbacks
-- made by the code generator.

-- Do not change the interface to these functions without also changing
-- the calls made to them in genfoam.c.

-- This file must be compiled with "-O -Q inline-all -W runtime" when
-- making the asharp runtime library.

-- Because this file implements the code for getting exports from domains,
-- it needs to generate FOAM code that has no "gets" in it, otherwise
-- it would loop infinitely when instantiating itself.  Because of this,
-- the "-W runtime" flag causes it to compile with a flat environment
-- for its types, so we have to disallow parameterized types here.  We
-- also need to avoid direct recursion, but indirect-recursion, through
-- function pointers is used for getting exports from a parent in
-- an "add" chain.

#include "aslib"

macro {
	Ptr		== Pointer;
	Int		== SingleInteger;
	Bit		== Boolean;
	ptr x		== x @ % pretend Ptr;
	Nil S		== nil @ Ptr pretend S;
	Nil?(S)(x)	== x @ S pretend Ptr = nil;
	Reserved	== Pointer;
}

import from Ptr, Int;

-- Hash code type.
macro {
	Hash		== Int;
	wildcard	== -1;
}

-- Value is used for types stored in a single word.  All domain exports
-- must be storable in this type.
local Value: BasicType == Ptr;

macro {
	DomainFun S	== S -> (S, Hash) -> ();
	DomGetter	== (DomainRep, Hash, Hash, Box, Bit) -> Box;
	DomHasher	== DomainRep -> Hash;
	DomNamer	== DomainRep -> String;
	DomInheritTo    == (DomainRep, Domain) -> Domain;
}

macro {
	CatRepInit S		== (S, Domain) -> ();
	CatBuilder		== (CatRep, Domain) -> CatObj;
	CatGetter		== (CatRep, Hash, Hash, Box) -> Box;
	CatHasher		== CatRep -> Hash;
	CatParentCounter	== CatRep -> Int;
	CatParentGetter		== (CatRep, Int) -> CatObj;
	CatNamer		== (CatRep) -> String;
}

export {
	-- Functions for creating and enriching asharp domains.

	domainMake:		DomainFun(DomainRep) -> Domain;
		++ domainMake(fun) creates a new lazy domain object.

	domainMakeDispatch:	DomainRep -> Domain;
		++ domainMakeDispatch(dr) wraps a dispatch vector
		++ around a DomainRep.

	domainAddExports!:	(DomainRep,
				 Array Hash, Array Hash, Array Value) -> ();
		++ domainAddExports!(dom, names, types, exports)
		++ Set the exports of a domain.

	domainAddDefaults!:	(DomainRep, CatObj, Domain) -> ();
		++ domainAddDefaults!(dom, defaults, dom)
		++ Sets the default package for a domain.

	domainAddParents!:	(DomainRep, Array Domain) -> ();
		++ defaultsAddExports!(dom, parents)
		++ Set the parents of a default package.

	domainAddHash!:		(DomainRep, Hash) -> ();
		++ domainAddHash!(dom, hash) sets the hash code of a domain.

	domainAddNameFn!: 	(DomainRep, ()->String)->();
		++ sets the domains naming function

	domainGetExport!:	(Domain, Hash, Hash) -> Value;
		++ domainGetExport!(dom, name, type)
		++ Gets an export from a domain, given the hash codes for
		++ its name and type.  Takes a hard error on failure.

	domainTestExport!:	(Domain, Hash, Hash) -> Bit;
		++ domainTestExport!(dom, name, type)
		++ returns true if the given export exists in dom

	domainHash!:		Domain -> Hash;
		++ domainHash!(dom) returns the hash code from a domain.

	domainPrepare!:		Domain -> ();
		++ domainPrepeare!(dom) forces the instantiation of a domain.

	domainName: 		Domain -> String;
		++ domainName returns the name of a domain
	-- Functions for creating and enriching asharp categories.

	categoryAddParents!:	(CatRep, Array CatObj) -> ();
		++ defaultsAddExports!(dom, parents)
		++ Set the parents of a default package.
	categoryAddNameFn!: (CatRep, ()->String) -> ();
		++ Sets the name of a category.

	categoryAddExports!:	(CatRep,
				 Array Hash, Array Hash, Array Value) -> ();
		++ categoryAddExports!(dom, names, types, exports)
		++ Set the exports of a category.

	categoryMake:		CatRepInit(CatRep) -> CatObj;
		++ constructing new cats

	categoryBuild:		(CatObj, Domain) -> CatObj;

	categoryName:		(CatObj) -> String;
		++ Returns the name of a category

	-- Utility functions called from code generation.

	noOperation:		() -> ();
		++ Do nothing --- used to clobber initialisation fns.

	extendMake:		DomainFun(DomainRep) -> Domain;
		++ extendMake(fun) creates a new lazy extend domain object;
	lazyGetExport!:		(Domain, Hash, Hash) -> LazyImport;
		++ creates a lazy function to retrieve the export
	lazyForceImport: 	LazyImport->Value;
		++ forces a get on the lazy value
	stringConcat: (Tuple String) -> String;
		++ Needed as string concatenation is not builtin.
	rtAddStrings: (Array Hash, Array String) -> ();
} to Foreign(Builtin);

+++ Domain is the top-level domain representaion, designed to operate in
+++ an environment of mixed runtime systems.  The domain consists of
+++ a pointer to the domain's native representation, and a vector of
+++ functions for accessing it.  Currently only "get" and "hash" functions
+++ are required.
Domain: Conditional with {
	new:			DomainRep -> %;
		++ new(dr) creates a new domain by wrapping
		++ a dispatch vector around a DomainRep.

	newExtend:		DomainRep -> %;
		++ extend(dr) creates a new domain by wrapping
		++ the dispatch vector for extensions around a DomainRep.

	prepare!:		% -> ();
		++ prepare(dom) forces a domain to fully instantiate.

	getExport!:		(%, Hash, Hash) -> Value;
		++ getExport!(dom, name, type) gets an export from a domain,
		++ given the hash codes for its name and type.  Takes a hard
		++ error on failure.

	getExportInner!:	(%, Hash, Hash, Box, Bit) -> Box;
		++ getExportInner!(dom, name, type, box, skipDefaults)
		++ Fetch an export from the given domain, putting the result
		++ in the box.  It won't look in category default packages if
		++ if skipDefaults is true.  Returns nullBox on failure.

	getHash!:		% -> Hash;
		++ getHash!(dom) returns the hash code for a domain.

	testExport!:		(%, Hash, Hash) -> Bit;
		++ testExport!(dom, name, type) tests for an
		++ export with the given name and type in the domain
	getName:		%->String;
		++ getName(dom) returns the name of a domain
	inheritTo: 		(%, Domain)->Domain;
		++ returns an object suitable for being a parent of dom2
}
== add {
	Rep ==> Record (dispatcher:	DispatchVector,
			domainRep:	DomainRep);

	import from Rep, DomainRep, DispatchVector;

	domainRep  (td: %): DomainRep		== rep(td).domainRep;
	dispatcher (td: %): DispatchVector	== rep(td).dispatcher;

	new (d: DomainRep) : % ==
		per [asharpDispatchVector(), d];

	newExtend (d: DomainRep) : % ==
		per [extendDispatchVector(), d];

	copy (td: %) : % ==
		per [dispatcher td, domainRep td];

	prepare! (td: %) : () ==
		prepare! domainRep td;

	-- Create a box to use for all calls to getExport.
	local box: Box := new Nil Value;

	getExport0! (td: %, name: Hash, type: Hash) : Box == {
		get := getter dispatcher td;
		val := get(domainRep td, name, type, box, true);
		val => val;
		val := get(domainRep td, name, type, box, false);
	}

	getExport! (td: %, name: Hash, type: Hash) : Value == {
		import from StringTable;
		val := getExport0!(td, name, type);
		val => value val;
		PRINT("Looking in ")(getName(td))(" for ")(find(name))(" with code ")(type)();
		error "Export not found";
	}

	getExportInner! (td: %, name: Hash, type: Hash, box: Box, skip: Bit)
			: Box ==
		(getter dispatcher td)(domainRep td, name, type, box, skip);

	getHash! (td: %) : Hash ==
		(hasher dispatcher td)(domainRep td);

	testExport! (td: %, name: Hash, type: Hash) : Bit ==
		test getExport0!(td, name, type);

	getName(td: %): String == if (tag dispatcher td) = 0 then
					(namer dispatcher td)(domainRep td);
				  else "<SEP>";
	inheritTo(td: %, dom2: Domain): Domain ==
		(inheriter dispatcher td)(domainRep td, dom2);

	-- Conditional operations.

	(d1: %) = (d2: %): Bit == ptr d1 = ptr d2;
	sample : % == Nil %;
	apply (p: OutPort, d: %) : OutPort == p;
	test (d: %) : Bit == not nil? ptr d;

	--!! Remove this when we can inline constants from other domains.
	import {
		stdoutFile:	() -> OutPort;
	} from Foreign();

	PRINT: OutPort		== stdoutFile();
}

+++ DomainRep defines the run-time representation of asharp domains.  Domains
+++ are lazy.  Initially domains only hold a function which, when called,
+++ fills in the hash code for the domain, and sets another function.
+++ When this funcation is called, the parent and export fields are set, and
+++ any code from the "add" body is run.
DomainRep: Conditional with {
	new:		DomainFun % -> %;
		++ new(fun) creates a new domain.

	prepare!:	% -> ();
		++ prepare!(dom) forces a domain to fully instantiate.

	addExports!:	(%, Array Hash, Array Hash, Array Value) -> ();
		++ addExports!(dom, names, types, exports)
		++ sets the exports fields of a domain.

	addDefaults!:	(%, CatObj, Domain) -> ();
		++ addDefaults!(dom, defaults, domain)
		++ sets the default package for a domain.
		++ Additional arg is the wrapped domain.

	addParents!:	(%, Array Domain) -> ();
		++ addParents!(dom, parents) sets the parent field of a domain.

	addHash!:	(%, Hash) -> ();
		++ addHash!(dom, hash) sets the hash field of a domain.

	addNameFn!:	(%, ()->String) -> ();
		++ addName!(dom, name) sets the naming fn  of a domain.

	get:		(%, Hash, Hash, Box, Bit) -> Box;
		++ get(dom, name, type, box, skipDefaults)
		++ Fetch an export from the given domain, putting the result
		++ in the box.  It won't look in category default packages if
		++ if skipDefaults is true.  Returns nullBox on failure.
		++ If the type hash code is wildcard, then any type is OK.

	hash:		% -> Hash;
		++ hash(dom) returns the hash code for a domain.

	getExtend:	(%, Hash, Hash, Box, Bit) -> Box;
		++ get(dom, name, type, box, skipDefaults)
		++ Fetch an export from an extended domain.

	hashExtend:	% -> Hash;
		++ hashExtend(dom) returns the hash code for extended domains.

	asharpDispatchVector: () -> DispatchVector;
		++ asharpDispatchVector() creates the dispatch vector for
		++ asharp domains.

	extendDispatchVector: () -> DispatchVector;
		++ extendDispatchVector() creates the dispatch vector for
		++ extended domains.
}
== add {
	Rep1 ==> Ptr;
	Per1 ==> DomainFun %;
	rep1 x ==> x @ Per1 pretend Rep1;
	per1 x ==> x @ Rep1 pretend Per1;

	Rep2 ==> Ptr;
	Per2 ==> (%, Hash) -> ();
	rep2 x ==> x @ Per2 pretend Rep2;
	per2 x ==> x @ Rep2 pretend Per2;

	Rep ==> Record (f1:		Rep1,
			f2:		Rep2,
			hashcode:	Hash,
			parents:	Array Domain,
			defaults:	CatObj,
			names:		Array Hash,
			types:		Array Hash,
			exports:	Array Value,
			ngets:		Int,
			serial: 	SingleInteger,
			idName:		String,
			nameFn:		()->String);

	import from Rep;
	import from Domain, CatObj;
	import from Array Hash, Array Value, Array Domain;
	import from Format, String;

	local serialThis: SingleInteger := 0;
	domainStdName(): String == "<domain>";

	new(fn1: DomainFun %): % == {
		free serialThis;
		serialThis := serialThis + 1;
		per [rep1 fn1, rep2 Nil Per2, 0, Nil Array Domain, Nil CatObj,
		     Nil Array Hash, Nil Array Hash, Nil Array Value, 0,
		     serialThis, "<anon dom>", domainStdName]
	}
	prepare!(dom: %): () ==
		prepareGetter!(dom);

	addExports!(dom: %, nams: Array Hash, typs: Array Hash,
		    expts: Array Value): () == {
		rep(dom).names    := nams;
		rep(dom).types    := typs;
		rep(dom).exports  := expts;
	}

	addDefaults!(dom: %, defs: CatObj, domAsDomain: Domain): () ==
		rep(dom).defaults := categoryBuild(defs, domAsDomain);

	addParents!(dom: %, parnts: Array Domain): () ==
		rep(dom).parents  := [inheritTo(parnt, new(dom)) for parnt in parnts];

	addHash!(dom: %, code: Hash): () ==
		rep(dom).hashcode := code;

	addNameFn!(dom: %, namefn: ()->String): () == {
		rep(dom).nameFn := namefn;
	}

	prepareGetter!(dom: %): () == {
		h := hash(dom);
		if Nil?(Array Hash)(rep(dom).names) then
			per2(rep(dom).f2)(dom, h);
	}

	prepareHash!(dom: %): () == {
		if Nil?(Rep2)(rep(dom).f2) then
			rep(dom).f2 := rep2(per1(rep(dom).f1)(dom));
		PRINT("Initialised: ")(name(dom))("with hashcode")(rep(dom).hashcode)();
	}

	get(dom: %, nameCode: Hash, type: Hash, box: Box, skip: Bit): Box == {
		rep(dom).ngets := rep(dom).ngets + 1;
		if rep(dom).ngets > 10 then {
			import from String, OutPort, SingleInteger;
			(stdoutFile())(name dom)();
			error "Circular get broken";
		}
		val := getaux(dom, nameCode, type, box, skip);
		rep(dom).ngets := rep(dom).ngets - 1;
		val;
	}
	getaux(dom: %, name: Hash, type: Hash, box: Box, skip: Bit): Box == {
		local newBox: Box;
		prepareGetter! dom;
		for expName  in rep(dom).names
		for expType  in rep(dom).types
		for expValue in rep(dom).exports
	        repeat {
			name=expName and (type=expType or type=wildcard) => {
				setVal!(box, expValue);
				return box;
			}
		}
		pars := rep(dom).parents;
		if not Nil?(Array Domain)(pars) then {
			for par in pars repeat {
				if par then {
					newBox := getExportInner!(
							par,
							name, type, box, skip);
					newBox => return newBox;
				}
			}
		}
		def := rep(dom).defaults;
		if def and not skip then {
			newBox := getDefault!(def, name, type, box);
			newBox => return newBox;
		}
		nullBox();
	}

	hash(dom: %): Hash == {
		prepareHash! dom;
		rep(dom).hashcode;
	}

	name(dom: %): String == (rep(dom).nameFn)();
	
	inheritTo(dom: %, child: Domain): Domain == {
		-- NB Cannot re-initialise the new domain
		dr := new( (self: %): ((%, Hash) -> ()) +-> {
			 	prepareHash!(dom);
				addHash!(self, hash(child));
				rep(dom).f2
			});
		new(dr)
	}

	-- Operations for extension domains.

	getExtend (dom: %, name: Hash, type: Hash, box: Box, skip: Bit): Box
	== {
		local newBox: Box;
		prepareHash! dom;
		pars := rep(dom).parents;
		if not Nil?(Array Domain)(pars) then {
			for par in pars repeat {
				if par then {
					newBox := getExportInner!(par, name,
							type, box, skip);
					newBox => return newBox;
				}
			}
		}
		nullBox();
	}

	hashExtend (dom: %): Hash == {
		prepareHash! dom;
		getHash! rep(dom).parents.1;
	}
	nameExtend(dom: %): String ==
		domainName rep(dom).parents.1;
	
	inheritToExtend(dom: %, child: Domain): Domain == {
		dr:=new((self: %): ((%, Hash)->()) +->
			[ inheritTo(p, child) for p in parents dom ];
			(x: %, h: Hash): () +-> return);
		newExtend(dr);
	}
		
	-- Dispatch vector creation operations.

	--!! These functions are here rather than in DispatchVector so
	--!! we can initialize the functions used to construct the vector
	--!! using global constants instead of using calls to domainGetExport!.

	DV ==> DispatchVector;

	local adv: DV := Nil DV;
	local edv: DV := Nil DV;

	asharpDispatchVector () : DV == {
		free adv: DV;
		not adv => adv := new(name@(%->String) pretend DomNamer,
				      get pretend DomGetter,
				      hash@(%->Hash) pretend DomHasher);
				     		adv;
	}

	extendDispatchVector () : DV == {
		free edv: DV;
		not edv => edv := new(nameExtend pretend DomNamer,
			 	      getExtend pretend DomGetter,
				      hashExtend pretend DomHasher);
				      		edv;
	}

	-- Conditional operations.

	(d1: %) = (d2: %): Bit == ptr d1 = ptr d2;
	sample : % == Nil %;
	apply (p: OutPort, d: %) : OutPort == p;
	test (d: %) : Bit == not nil? ptr d;

	--!! Remove this when we can inline constants from other domains.
	import {
		stdoutFile:	() -> OutPort;
	} from Foreign();
}

+++ Structure containing a domain's protocol for getting exports and
+++ producing hash codes.  This is in a separate structure to accomodate
+++ mixed runtime environments.
DispatchVector: Conditional with {
	new:		(DomNamer, DomGetter, DomHasher) -> %;
		++ new(get, hash) constructs a dispatch vector.

	getter:		% -> DomGetter;
		++ getter(dv) returns the getter function.

	hasher:		% -> DomHasher;
		++ hasher(dv) returns the hash code function.
	namer:		%->  DomNamer;
		++ namer(dv) returns the function giving the name of a domain
	tag: 		% -> Int;
	reserved:	% -> Reserved;
	inheriter:	% -> DomInheritTo;
}
== add {
	Rep ==> Record(tag: Int,
		       namer:  DomNamer,
		       noname:  Reserved,
                       getter: DomGetter,
		       hasher: DomHasher,
		       inheriter: DomInheritTo);

	import from Rep;

        asharpDispatchTag ==> 0;

	new(n: DomNamer, g: DomGetter, h: DomHasher): %
		== per [asharpDispatchTag, n, nil, g, h];

	tag(dv: %)   : Int	  == rep(dv).tag;
	reserved(dv: %): Reserved == rep(dv).noname;
	getter(dv: %): DomGetter  == rep(dv).getter;
	hasher(dv: %): DomHasher  == rep(dv).hasher;
	namer(dv: %) : DomNamer   == rep(dv).namer;
	inheriter(dv: %) : DomInheritTo  == rep(dv).inheriter;
	-- Conditional operations.

	(d1: %) = (d2: %): Bit == ptr d1 = ptr d2;
	sample : % == Nil %;
	apply (p: OutPort, d: %) : OutPort == p;
	test (d: %) : Bit == not nil? ptr d;
}

+++ CatObj is the top-level category representation.
CatObj: Conditional with {
	new:		CatRep -> %;
		++ new(cr) creates a new category by wrapping
		++ a dispatch vector around a CatRep.

	getDefault!:	(%, Hash, Hash, Box) -> Box;
		++ getDefault!(cat, name, type, box)
		++ Find a default from the given category,
		++ putting the result in box.  Returns nullBox on failure.

	getParent:	(%, Int) -> %;
		++ getParent(cat, i) finds the i-th parent of cat.

	build:		(%, Domain) -> %;

	name:		% -> String;
}
== add {
	Rep ==> Record (cdv:	CatDispatchVector,
			catRep:	CatRep);

	import from Rep, CatRep, CatDispatchVector;

	catRep     (cat: %): CatRep		== rep(cat).catRep;
	dispatcher (cat: %): CatDispatchVector	== rep(cat).cdv;

	new (crep: CatRep) : % ==
		per [asharpCatDispatchVector(), crep];

	getDefault!(cat: %, name: Hash, type: Hash, box: Box): Box == {
		val := (getter dispatcher cat)(catRep cat, name, type, box);
		val => val;
		i := 1;
		l := (parentCounter dispatcher cat)(catRep cat);
		while i <= l repeat {
			p := getParent(cat, i);
			if p then {
				val := getDefault!(p, name, type, box);
				val => return val;
			}
			i := i + 1;
		}
		nullBox();
	}

	getParent(cat: %, i: Int): % ==
		(parentGetter dispatcher cat)(catRep cat, i) pretend %;

	build(cat: %, dom: Domain): % ==
		(builder dispatcher cat)(catRep cat, dom) pretend %;

	name(cat: %): String ==
		(namer dispatcher cat)(catRep cat);

	-- Conditional operations.

	(d1: %) = (d2: %): Bit == ptr d1 = ptr d2;
	sample : % == Nil %;
	apply (p: OutPort, d: %) : OutPort == p;
	test (d: %) : Bit == not nil? ptr d;
}

+++ CatRep defines the run-time representation of asharp categories.
CatRep: Conditional with {
	new:		CatRepInit % -> %;
		++ new(fun) creates a new category.

	prepare!:	% -> ();
		++ prepare!(cat) forces a category to fully instantiate.

	addExports!:	(%, Array Hash, Array Hash, Array Value) -> ();
		++ addExports!(cat, names, types, exports)
		++ sets the exports fields of a category.

	addParents!:	(%, Array CatObj) -> ();
		++ addParents!(cat, pars) set the parent field of a category.
	addNameFn!: 	(%, ()->String) -> ();
		++ addName! sets the name of an category.
	build:		(%, Domain) -> CatObj;
	get:		(%, Hash, Hash, Box) -> Box;
	hash:		% -> Hash;
	parentCount:	% -> Int;
	parentGet:	(%, Int) -> CatObj;
	name:		% -> String;

	asharpCatDispatchVector: () -> CatDispatchVector;
		++ asharpCatDispatchVector() creates the dispatch vector
		++ for asharp categories.
}
== add {
	Rep1 ==> Ptr;
	Per1 ==> CatRepInit %;
	rep1 x ==> x @ Per1 pretend Rep1;
	per1 x ==> x @ Rep1 pretend Per1;

	Rep ==> Record (buildFn:	Rep1,
			domain:		Domain,
			parents:	Array CatObj,
			nparents:	Int,
			names:		Array Hash,
			types:		Array Hash,
			exports:	Array Value,
			nameFn:		()->String);

	import from Rep;
	import from Array CatObj, Array Hash, Array Value;
	import from String, Format;

	local serialThis: Int := 1;

	categoryStdName(): String == "<category>";

	new(fn: Per1): % ==
		per [rep1 fn, Nil Domain, Nil Array CatObj, 0,
		     Nil Array Hash, Nil Array Hash, Nil Array Value,
		     categoryStdName ];

	names	(x: %): Array Hash	== rep(x).names;
	types	(x: %): Array Hash	== rep(x).types;
	exports	(x: %): Array Value	== rep(x).exports;
	parents	(x: %): Array CatObj	== rep(x).parents;
	nparents(x: %): Int		== rep(x).nparents;
	builder	(x: %): Per1		== per1(rep(x).buildFn);
	dom	(x: %): Domain		== rep(x).domain;
	nameFn	(x: %): ()->String	== rep(x).nameFn;

	prepare! (cat: %): () ==
		if (Nil?(Array Hash)(names(cat))) then
			builder(cat)(cat, dom(cat));

	addExports!(cat: %, nams: Array Hash, typs: Array Hash,
		    expts: Array Value): () == {
		rep(cat).names    := nams;
		rep(cat).types    := typs;
		rep(cat).exports  := expts;
	}

	addParents!(cat: %, prnts: Array CatObj): () == {
		dom0 := dom(cat);
		i := 0;
		for p: CatObj in prnts repeat {
			if p then {
				i := i + 1;
				prnts.i := categoryBuild(p, dom0);
			}
		}
		rep(cat).parents  := prnts;
		rep(cat).nparents := i;
	}

	addNameFn!(cat: %, nmfn: ()->String): () == {
		rep(cat).nameFn := nmfn;
	}
	
	build(cat: %, d: Domain): CatObj == {
		newCat := new(builder(cat));
		rep(newCat).domain := d;
		new(newCat pretend CatRep);
	}

	get(cat: %, name: Hash, type: Hash, box: Box): Box == {
		prepare!(cat);
		for expName  in names(cat)
		for expType  in types(cat)
		for expValue in exports(cat)
		repeat {
			name=expName and (type=expType or type=wildcard) => {
				setVal!(box, expValue);
				return box;
			}
		}
		nullBox();
	}

	hash(cat: %): Hash == 0;

	parentCount(cat: %): Int == {
		prepare!(cat);
		nparents(cat);
	}

	parentGet(cat: %, i: Int): CatObj == {
		prepare!(cat);
		parents(cat).i;
	}

	name(cat: %): String == nameFn(cat)();

	-- Dispatch vector creation operations.

	--!! These functions are here rather than in CatDispatchVector so
	--!! we can initialize the functions used to construct the vector
	--!! using global constants instead of using calls to domainGetExport!.

	DV ==> CatDispatchVector;

	local dv: DV := Nil DV;

	asharpCatDispatchVector (): DV == {
		free dv: DV;
		not dv => dv := new(name  pretend CatNamer,
				    build pretend CatBuilder,
				    get   pretend CatGetter,
				    hash@(%->Hash)      pretend CatHasher,
				    parentCount pretend CatParentCounter,
				    parentGet   pretend CatParentGetter);
		dv;
	}

	-- Conditional operations.

	(d1: %) = (d2: %): Bit == ptr d1 = ptr d2;
	sample : % == Nil %;
	apply (p: OutPort, d: %) : OutPort == p;
	test (d: %) : Bit == not nil? ptr d;
}

+++ Structure containing a category's protocol for getting parents/hash codes.
CatDispatchVector: Conditional with {
	new:		(CatNamer, CatBuilder, CatGetter, CatHasher,
			 CatParentCounter, CatParentGetter) -> %;
		++ new(build, get, hash, parentCount, parentGet)
		++ constructs a category dispatch vector.

	builder:	% -> CatBuilder;
		++ builder(cat) returns the building function of the category.

	getter:		% -> CatGetter;
		++ getter(cat) returns the getter function of the category.

	hasher:		% -> CatHasher;
		++ hasher(cat) returns the hasher function of the category.
	namer:		% -> CatNamer;
		++ returns the naming function of the category.
	parentCounter:	% -> CatParentCounter;
		++ parentCounter(cat) returns the #parents function.

	parentGetter:	% -> CatParentGetter;
		++ parentGetter returns the getParent function.
	reserved:	% -> Reserved;
		++ Slot to be filled in later.
}
== add {
	Rep ==> Record (tag:		Int,
			namer:		CatNamer,
			noname:		Reserved,
			getter:		CatGetter,
			hasher:		CatHasher,
			builder:	CatBuilder,
			parentCounter:	CatParentCounter,
			parentGetter:	CatParentGetter);
			
	import from Rep;

	asharpCatDispatchTag ==> 10;

	new	( namer:	CatNamer,
		 builder:	CatBuilder,
		 getter:	CatGetter,
		 hasher:	CatHasher,
		 parentCounter:	CatParentCounter,
		 parentGetter:	CatParentGetter) : %

		== per[asharpCatDispatchTag, namer, nil, getter, hasher,
		       builder, parentCounter, parentGetter];

	builder	(cdv: %): CatBuilder		== rep(cdv).builder;
	reserved(cdv: %): Reserved		== rep(cdv).noname;
	getter	(cdv: %): CatGetter		== rep(cdv).getter;
	hasher	(cdv: %): CatHasher		== rep(cdv).hasher;
	parentCounter(cdv: %): CatParentCounter	== rep(cdv).parentCounter;
	parentGetter (cdv: %): CatParentGetter	== rep(cdv).parentGetter;
	namer	(cdv: %): CatNamer		== rep(cdv).namer;
	-- Conditional operations.

	(d1: %) = (d2: %): Bit == ptr d1 = ptr d2;
	sample : % == Nil %;
	apply (p: OutPort, d: %) : OutPort == p;
	test (d: %) : Bit == not nil? ptr d;
}

Box: Conditional with {
	new:		Value -> %;
		++ new(val) creates an initialized box.

	value:		% -> Value;
		++ value(box) returns the value from the box.

	setVal!:	(%, Value) -> ();
		++ setVal!(box, val) sets the value in a box.

	nullBox:	() -> %;
		++ nullBox() returns the distinguished empty box,
		++ which cannot hold a value.
}
== add {
	Rep ==> Record(value: Value);

	import from Rep;

	new	(v: Value): %		== per [v];
	value	(b: %): Value		== rep(b).value;
	setVal!	(b: %, v: Value): ()	== rep(b).value := v;
	nullBox	(): %			== Nil %;

	-- Conditional operations.

	(d1: %) = (d2: %): Bit == ptr d1 = ptr d2;
	sample : % == Nil %;
	apply (p: OutPort, d: %) : OutPort == p;
	test (d: %) : Bit == not nil? ptr d;
}

local dge := domainGetExport!;

LazyImport: with {
	makeLazyImport: (Domain, Hash, Hash) -> %;
	force: %->Value;
} == add {
	--Need set!$Union, or for closures to work better under -Wruntime
	Rep ==> Record(got: Boolean,
		       dom: Domain,
		       name: Hash, type: Hash,
		       value: Value);
	import from Domain, Rep;
	makeLazyImport(dom: Domain, n: Hash, t: Hash): % ==
		per [false, dom, n, t, Nil Value];

	force(lv: %): Value == {
		if not rep(lv).got then {
			rep(lv).value := domainGetExport!(rep(lv).dom, rep(lv).name, rep(lv).type);
			rep(lv).got := true;
			rep(lv).dom := Nil Domain;
		}
		return rep(lv).value;
	}		
}

StringTable: with {
	addNames: (Array Hash, Array String)->();
	find: Hash->String;
} == add {
	import from List String, List Hash;
	names: List String := empty();
	codes: List SingleInteger := empty();

	addNames(a1: Array Hash, a2: Array String):() == {
		free names, codes;
		for code in a1
		for name in a2 repeat {
			codes := cons(code, codes);
			names := cons(name, names);
		}
	}

	find(i: Hash): String == {
		for code in codes
		for name in names repeat {
			if code = i then return name
		}
		return "<Unknown Name>"
	}
}

domainMake(df: DomainFun DomainRep): Domain ==
	new(new(df)$DomainRep);

domainMakeDispatch(dr: DomainRep): Domain ==
	new dr;

domainAddExports!(d: DomainRep, names: Array Hash, types: Array Hash,
		  exports: Array Value): () ==
	addExports!(d, names, types, exports);

domainAddDefaults!(d: DomainRep, defaults: CatObj, d2: Domain): () ==
	addDefaults!(d, defaults, d2);

domainAddParents!(d: DomainRep, parents: Array Domain): () ==
	addParents!(d, parents);

domainAddHash!(d: DomainRep, hash: Hash): () ==
	addHash!(d, hash);

domainAddNameFn!(d: DomainRep, namefn: ()->String): () ==
	addNameFn!(d, namefn);

domainPrepare!(td: Domain): () ==
	prepare! td;

domainGetExport!(td: Domain, name: Hash, type: Hash): Value ==
	getExport!(td, name, type);

domainTestExport!(td: Domain, name: Hash, type: Hash): Bit ==
	testExport!(td, name, type);
	
domainHash!(td: Domain): Hash ==
	getHash!(td);

domainName(td: Domain): String ==
	getName(td);
	
categoryMake(fn: CatRepInit CatRep): CatObj ==
	new(new(fn)$CatRep);

categoryAddParents!(c: CatRep, parents: Array CatObj): () ==
	addParents!(c, parents);

categoryAddExports!(c: CatRep, names: Array Hash, types: Array Hash,
		  exports: Array Value): () ==
	addExports!(c, names, types, exports);

categoryAddNameFn!(cat: CatRep, name: ()->String): () ==
	addNameFn!(cat, name);

categoryBuild(cat: CatObj, dom: Domain): CatObj ==
	build(cat, dom);

categoryName(cat: CatObj): String ==
	name(cat);

lazyGetExport!(dom: Domain, n: Hash, t: Hash): LazyImport ==
	makeLazyImport(dom, n, t);

lazyForceImport(li: LazyImport): Value == force(li);

noOperation():() == ();

extendMake(df: DomainFun DomainRep): Domain ==
	newExtend(new(df)$DomainRep);

stringConcat(t: Tuple String): String == { import from String; concat t }

rtAddStrings(a1:Array Hash, a2: Array String): () == {
	import from StringTable;
	addNames(a1, a2);
}