backend.c

#define CODE_INLINE_FLAG
#define DYNAMIC_TYPE 1

# include "compiledefines.h"
# include "types.t"
# include "system.h"
# include "syntaxtr.t"
# include "codegen_types.h"
# include "statesgen.h"
# include "codegen.h"
# include "codegen2.h"
# include "instructions.h"
# include "sizes.h"
# include "set_scope_numbers.h"

# include "scanner.h"		/* InitScanner, ScanInitIdentStringTable */
# include "checker.h"		/* scc_dependency_list, ClearOpenDefinitionModules, AddOpenDefinitionModule */
# include "comsupport.h" 	/* CurrentModule */
# include "buildtree.h"		/* TupleSymbol, ApplySymbol */

# include "backendsupport.h"
# define Clean(ignore)

# include "backend.h"

# include <limits.h>

# if 0
# include "dbprint.h"
# endif

void
BEGetVersion (int *current, int *oldestDefinition, int *oldestImplementation)
{
	*current				= kBEVersionCurrent;
	*oldestDefinition		= kBEVersionOldestDefinition;
	*oldestImplementation	= kBEVersionOldestImplementation;
}

#if STRICT_LISTS
 PolyList unboxed_record_cons_list,unboxed_record_decons_list;
#endif

extern PolyList UserDefinedArrayFunctions;	/* typechecker.c */
extern int StdOutReopened, StdErrorReopened; /* cocl.c */

static char *
ConvertCleanString (CleanString string)
{
	int		length;
	char	*copy;

	length	= string->length;
	copy	= ConvertAlloc (length+1);
	strncpy (copy, string->chars, length);
	copy [length]	= '\0';

	return (copy);
} /* ConvertCleanString */

static short
CountTypeArgs (BETypeArgP args)
{
	short	n;

	n	= 0;
	for (; args != NULL; args = args->type_arg_next)
		n++;

	return (n);
} /* CountTypeArgs */

static short
CountArgs (BEArgP args)
{
	short	n;

	n	= 0;
	for (; args != NULL; args = args->arg_next)
		n++;

	return (n);
} /* CountArgs */

/*
	BE routines
*/
STRUCT (be_module, BEModule)
{
	char			*bem_name;
	Bool			bem_isSystemModule;

	unsigned int	bem_nFunctions;
	SymbolP			bem_functions;
	unsigned int	bem_nTypes;
	SymbolP			bem_types;
	unsigned int	bem_nConstructors;
	SymbolP			bem_constructors;
	unsigned int	bem_nFields;
	SymbolP			bem_fields;
};

STRUCT (be_icl_module, BEIcl)
{
	ImpMod			beicl_module;
	BEModuleS		beicl_dcl_module;

	// +++ remove this (build deps list separately)
	SymbDefP		*beicl_depsP;
};

STRUCT (be_state, BEState)
{
	Bool			be_initialised;

	char			**be_argv;
	int				be_argc;
	int				be_argi;

	BEModuleP		be_modules;

	BEIclS			be_icl;
	unsigned int	be_nModules;

	SymbolP			be_function_symbols;
	SymbolP			be_dontCareSymbol;
	SymbolP			be_dictionarySelectFunSymbol;
	SymbolP			be_dictionaryUpdateFunSymbol;

	// temporary hack
	int				be_dynamicTypeIndex;
	int				be_dynamicModuleIndex;
};

static BEStateS	gBEState = {False /* ... */};

STRUCT (be_locally_generated_function_info, BELocallyGeneratedFunction)
{
	char	*lgf_name;
	int		lgf_arity;
};

static BELocallyGeneratedFunctionS gLocallyGeneratedFunctions[] = {{"_dictionary_select", 3}, {"_dictionary_update", 4}};
# define	kDictionarySelect	0
# define	kDictionaryUpdate	1

// +++ put in gBEState
static NodeIdP (*gCurrentNodeIds)=NULL;
static int n_gCurrentNodeIds = 0;
static SymbolP	gBasicSymbols [Nr_Of_Predef_FunsOrConses];
static SymbolP	gTupleSelectSymbols [MaxNodeArity];

static int number_of_node_ids=0;

typedef IdentP *IdentH;
static IdentH gSpecialIdents[BESpecialIdentCount];

static IdentP
Identifier (char *name)
{
	IdentP	ident;

	ident	= ConvertAllocType (IdentS);
	ident->ident_name	= name;

	return (ident);
} /* Identifier */

static SymbolP
PredefinedSymbol (SymbKind symbolKind, int arity)
{
	SymbolP	symbol;

	symbol	= ConvertAllocType (SymbolS);

	symbol->symb_kind	= symbolKind;
	symbol->symb_arity	= arity;

	return (symbol);
} /* PredefinedSymbol */

static SymbolP
AllocateSymbols (int nFunctions, int nTypesConstructorsAndFields, SymbolP *function_symbols_h)
{
	int	nSymbols;
	
	nSymbols = nFunctions+nTypesConstructorsAndFields;
	if (nSymbols!=0){
		SymbolP	symbols;
		int i;

		symbols	= (SymbolP) ConvertAlloc (nSymbols * sizeof (SymbolS));
		i = 0;

		if (nFunctions>0){
			for (; i < nFunctions; ++i){
				symbols [i].symb_kind	= erroneous_symb;
				symbols [i].symb_next	= &symbols [i+1];
			}
		
			symbols [nFunctions-1].symb_next = *function_symbols_h;
			*function_symbols_h = symbols;
		}
		
		for (; i < nSymbols; i++){
			symbols [i].symb_kind	= erroneous_symb;
			symbols [i].symb_next	= NULL;
		}
		
		return symbols;
	} else
		return NULL;
} /* AllocateSymbols */

static void
InitPredefinedSymbols (void)
{
	int	i;

	gBasicSymbols [int_type]		= PredefinedSymbol (int_type, 0);
	gBasicSymbols [bool_type]		= PredefinedSymbol (bool_type, 0);
	gBasicSymbols [char_type]		= PredefinedSymbol (char_type, 0);
	gBasicSymbols [real_type]		= PredefinedSymbol (real_type, 0);
	gBasicSymbols [file_type]		= PredefinedSymbol (file_type, 0);
	gBasicSymbols [world_type]		= PredefinedSymbol (world_type, 0);
#if DYNAMIC_TYPE
	gBasicSymbols [dynamic_type]= PredefinedSymbol (dynamic_type, 0);
#endif
	gBasicSymbols [array_type]			= PredefinedSymbol (array_type, 1);
	gBasicSymbols [strict_array_type]	= PredefinedSymbol (strict_array_type, 1);
	gBasicSymbols [unboxed_array_type]	= PredefinedSymbol (unboxed_array_type, 1);

	gBasicSymbols [fun_type]	= PredefinedSymbol (fun_type, 2);

	ApplySymbol	= PredefinedSymbol (apply_symb, 2);
	ApplySymbol->symb_instance_apply = 0;
	gBasicSymbols [apply_symb]	= ApplySymbol;

	TupleSymbol	= PredefinedSymbol (tuple_symb, 2); /* arity doesn't matter */
	gBasicSymbols [tuple_symb]	= TupleSymbol;
	gBasicSymbols [tuple_type]	= PredefinedSymbol (tuple_type, 2);

	gBasicSymbols [if_symb]		= PredefinedSymbol (if_symb, 3);
	gBasicSymbols [fail_symb]	= PredefinedSymbol (fail_symb, 0);

	gBasicSymbols [nil_symb]	= PredefinedSymbol (nil_symb, 0);
	gBasicSymbols [cons_symb]	= PredefinedSymbol (cons_symb, 2);

	for (i = 0; i < MaxNodeArity; i++)
		gTupleSelectSymbols [i]	= NULL;

} /* InitPredefinedSymbols */

static void
AddUserDefinedArrayFunction (SymbolP functionSymbol)
{
	PolyList	elem;

	elem	= ConvertAllocType (struct poly_list);

	elem->pl_elem	= functionSymbol;
	elem->pl_next	= UserDefinedArrayFunctions;
	UserDefinedArrayFunctions	= elem;
} /* AddUserDefinedArrayFunction */

static Node
NewGuardNode (NodeP ifNode, NodeP node, NodeDefP nodeDefs, StrictNodeIdP stricts)
{
	NodeP	guardNode;
	
	guardNode	= ConvertAllocType (NodeS);
	
	guardNode->node_kind		= GuardNode;
	guardNode->node_node_defs	= nodeDefs;
	guardNode->node_arity		= 2;
	guardNode->node_guard_strict_node_ids	= stricts;

	guardNode->node_arguments	= BEArgs (ifNode, BEArgs (node, NULL));
	
	return (guardNode);
} /* NewGuardNode */

static void
DeclareModule (int moduleIndex, char *name, Bool isSystemModule, int nFunctions,
											int nTypes, int nConstructors, int nFields)
{
	BEModuleP	module;
	SymbolP		symbols;

	symbols = AllocateSymbols (nFunctions, nTypes + nConstructors + nFields, &gBEState.be_function_symbols);

	Assert ((unsigned int) moduleIndex < gBEState.be_nModules);
	module	= &gBEState.be_modules [moduleIndex];

	module->bem_name			= name;
	module->bem_isSystemModule	= isSystemModule;

	module->bem_nFunctions	= (unsigned int) nFunctions;
	module->bem_functions	= symbols;
	symbols	+=	nFunctions;

	module->bem_nTypes	= (unsigned int) nTypes;
	module->bem_types = symbols;
	{
		/* +++ change this */
		int		i;
		for (i = 0; i < nTypes; i++)
		{
			SymbDef	newSymbDef;

			newSymbDef	= ConvertAllocType (SymbDefS);
			newSymbDef->sdef_mark		= 0;
			newSymbDef->sdef_isused	= False;
			symbols [i].symb_def	= newSymbDef;
		}
	}
	symbols	+=	nTypes;

	module->bem_nConstructors	= (unsigned int) nConstructors;
	module->bem_constructors = symbols;
	symbols	+=	nConstructors;

	module->bem_nFields	= (unsigned int) nFields;
	module->bem_fields	= symbols;
	symbols	+=	nFields;
} /* DeclareModule */

static int main_dcl_module_n=0;

void
BESetMainDclModuleN (int main_dcl_module_n_parameter)
{
	main_dcl_module_n=main_dcl_module_n_parameter;
}

static DefMod im_def_module;

static void	DeclareFunctionC (char *name, int arity, int functionIndex, unsigned int ancestor);
static BESymbolP CreateDictionarySelectFunSymbol (void);
static BESymbolP CreateDictionaryUpdateFunSymbol (void);

void
BEDeclareIclModule (CleanString name, CleanString modificationTime, int nFunctions, int nTypes, int nConstructors, int nFields)
{
	int		i;
	char	*cName;
	ImpMod	iclModule;
	BEIclP	icl;

	cName	= gBEState.be_modules [main_dcl_module_n].bem_name;

	if (cName == NULL)
		cName	= ConvertCleanString (name);

/*	Assert (strcmp (gBEState.be_modules [main_dcl_module_n].bem_name, cName) == 0); */
	Assert (strncmp (cName, name->chars, name->length) == 0);

	icl	= &gBEState.be_icl;

	icl->beicl_module		= ConvertAllocType (ImpRepr);
	icl->beicl_dcl_module	= gBEState.be_modules [main_dcl_module_n];
	scc_dependency_list	= NULL;
	icl->beicl_depsP	= &scc_dependency_list;

	{
		struct module_type_symbols *dcl_type_symbols_a;
		int n_dcl_type_symbols;
		struct def_list *def_mod;
		
		dcl_type_symbols_a = (struct module_type_symbols*) ConvertAlloc (gBEState.be_nModules * sizeof (struct module_type_symbols));
		n_dcl_type_symbols=0;

		for (def_mod=OpenDefinitionModules; def_mod!=NULL; def_mod=def_mod->mod_next){
			int module_n;
			
			module_n = def_mod->mod_body->dm_module_n;
			if (module_n!=main_dcl_module_n){
				dcl_type_symbols_a[n_dcl_type_symbols].mts_n_types       = gBEState.be_modules [module_n].bem_nTypes;
				dcl_type_symbols_a[n_dcl_type_symbols].mts_type_symbol_a = gBEState.be_modules [module_n].bem_types;
				++n_dcl_type_symbols;
			}
		}
		
		dcl_type_symbols_a[n_dcl_type_symbols].mts_n_types       = gBEState.be_modules [kPredefinedModuleIndex].bem_nTypes;
		dcl_type_symbols_a[n_dcl_type_symbols].mts_type_symbol_a = gBEState.be_modules [kPredefinedModuleIndex].bem_types;
		++n_dcl_type_symbols;

		Assert (n_dcl_type_symbols<=gBEState.be_nModules);

		icl->beicl_module->im_dcl_type_symbols_a = dcl_type_symbols_a;
		icl->beicl_module->im_size_dcl_type_symbols_a = n_dcl_type_symbols;
	}

	nFunctions	+= ArraySize (gLocallyGeneratedFunctions);
	DeclareModule (main_dcl_module_n, cName, False, nFunctions, nTypes, nConstructors, nFields);

	iclModule	= icl->beicl_module;
	iclModule->im_name			= cName;
	iclModule->im_modification_time	= ConvertCleanString (modificationTime);
	iclModule->im_def_module	= im_def_module;
	iclModule->im_rules			= NULL;
	iclModule->im_start			= NULL;
	iclModule->im_type_symbols.mts_n_types = nTypes;
	iclModule->im_type_symbols.mts_type_symbol_a = gBEState.be_modules [main_dcl_module_n].bem_types;
	iclModule->im_function_symbols = gBEState.be_function_symbols;
# if IMPORT_OBJ_AND_LIB
	iclModule->im_imported_objs	= NULL;
	iclModule->im_imported_libs	= NULL;
# endif
	iclModule->im_foreign_exports=NULL;

	CurrentModule	= cName;

	for (i = 0; i < ArraySize (gLocallyGeneratedFunctions); i++)
	{
		BELocallyGeneratedFunctionP	locallyGeneratedFunction;

		locallyGeneratedFunction	= &gLocallyGeneratedFunctions [i];

		DeclareFunctionC (locallyGeneratedFunction->lgf_name, locallyGeneratedFunction->lgf_arity, nFunctions-ArraySize(gLocallyGeneratedFunctions)+i,0);
	}

	/* +++ hack */
	{
		gBEState.be_dictionarySelectFunSymbol	= CreateDictionarySelectFunSymbol ();
		gBEState.be_dictionaryUpdateFunSymbol	= CreateDictionaryUpdateFunSymbol ();
	}
} /* BEDeclareIclModule */

void
BEDeclareDclModule (int moduleIndex, CleanString name, CleanString modificationTime, int isSystemModule, int nFunctions, int nTypes, int nConstructors, int nFields)
{
	char	*cName;
	SymbolP	moduleNameSymbol;
	DefMod	dclModule;
	SymbolP	saved_function_symbols,previous_all_symbols;

	cName	= ConvertCleanString (name);

	moduleNameSymbol	= ConvertAllocType (SymbolS);
	moduleNameSymbol->symb_ident	= Identifier (cName);

	if (moduleIndex == main_dcl_module_n){
		saved_function_symbols = gBEState.be_function_symbols;
		gBEState.be_function_symbols = NULL;
	}

	previous_all_symbols = gBEState.be_function_symbols;

	DeclareModule (moduleIndex, cName, isSystemModule, nFunctions, nTypes, nConstructors, nFields);

	dclModule	= ConvertAllocType (DefRepr);
	dclModule->dm_name			= cName;
	dclModule->dm_module_n = moduleIndex;
	dclModule->dm_modification_time	= ConvertCleanString (modificationTime);
	dclModule->dm_system_module	= isSystemModule;
	dclModule->dm_function_symbols = gBEState.be_function_symbols;
	dclModule->dm_symbols_end = previous_all_symbols;
	dclModule->dm_system_module_table_kind = FirstSystemModuleTable + moduleIndex;

	AddOpenDefinitionModule (moduleNameSymbol, dclModule);

	if (moduleIndex == main_dcl_module_n){
		gBEState.be_function_symbols = saved_function_symbols;
		im_def_module=dclModule;
	}
} /* BEDeclareDclModule */

void
BEDeclarePredefinedModule (int nTypes, int nConstructors)
{
	char	*cName;

	cName	= "_predef";

	DeclareModule (kPredefinedModuleIndex, cName, False, 0, nTypes, nConstructors, 0);
} /* BEDeclarePredefinedModule */

void
BEDeclareModules (int nModules)
{
	int	i;

	Assert (gBEState.be_modules == NULL);

	gBEState.be_nModules	= (unsigned int) nModules;
	gBEState.be_modules		= (BEModuleP) ConvertAlloc (nModules * sizeof (BEModuleS));

	for (i = 0; i < nModules; i++)
	{
		gBEState.be_modules [i].bem_name	= NULL;
		gBEState.be_modules [i].bem_nFunctions	= 0;
	}
} /* BEDeclareModules */

BESymbolP
BEFunctionSymbol (int functionIndex, int moduleIndex)
{
	BEModuleP	module;
	SymbolP		functionSymbol;

	Assert ((unsigned int) moduleIndex < gBEState.be_nModules);
	module	= &gBEState.be_modules [moduleIndex];

	Assert ((unsigned int) functionIndex < module->bem_nFunctions);
	functionSymbol	= &module->bem_functions [functionIndex];
	Assert (functionSymbol->symb_kind == definition || functionSymbol->symb_kind == cons_symb || functionSymbol->symb_kind == nil_symb
				|| (moduleIndex == kPredefinedModuleIndex && functionSymbol->symb_kind != erroneous_symb));

	if (functionSymbol->symb_kind!=cons_symb && functionSymbol->symb_kind!=nil_symb)
		functionSymbol->symb_def->sdef_isused	= True;

	return (functionSymbol);
} /* BEFunctionSymbol */

void
BEBindSpecialModule (BESpecialIdentIndex index, int moduleIndex)
{
	BEModuleP	module;

	Assert (index >= 0 && index < BESpecialIdentCount);

	Assert ((unsigned int) moduleIndex < gBEState.be_nModules);
	module	= &gBEState.be_modules [moduleIndex];

	(*gSpecialIdents [index])->ident_name	= module->bem_name;
} /* BEBindSpecialModule */

void
BEBindSpecialFunction (BESpecialIdentIndex index, int functionIndex, int moduleIndex)
{
	SymbolP		functionSymbol;
	BEModuleP	module;

	Assert (index >= 0 && index < BESpecialIdentCount);

	Assert ((unsigned int) moduleIndex < gBEState.be_nModules);
	module	= &gBEState.be_modules [moduleIndex];

	Assert ((unsigned int) functionIndex < module->bem_nFunctions);
	functionSymbol	= &module->bem_functions [functionIndex];

	if (functionSymbol->symb_kind == definition){
		*gSpecialIdents [index]	= functionSymbol->symb_def->sdef_ident;
		
		if (index==BESpecialIdentSeq && moduleIndex!=main_dcl_module_n){
			functionSymbol->symb_kind=seq_symb;
		}
	}
} /* BEBindSpecialFunction */

extern SymbDefP special_types[]; /* defined in statesgen */

void BEBindSpecialType (int special_type_n,int type_index,int module_index)
{
	SymbolP		type_symbol_p;
	BEModuleP	module;

	module	= &gBEState.be_modules [module_index];
	type_symbol_p = &module->bem_types [type_index];
	if (type_symbol_p->symb_kind==definition)
		special_types[special_type_n] = type_symbol_p->symb_def;
	else
		special_types[special_type_n] = NULL;
}

BESymbolP
BESpecialArrayFunctionSymbol (BEArrayFunKind arrayFunKind, int functionIndex, int moduleIndex)
{
	BEModuleP	module;
	SymbolP		functionSymbol,previousFunctionSymbol;
	SymbDefP	originalsdef;
	TypeAlt		*typeAlt;
	TypeNode	elementType, arrayType;

	Assert ((unsigned int) moduleIndex < gBEState.be_nModules);
	module	= &gBEState.be_modules [moduleIndex];

	Assert ((unsigned int) functionIndex < module->bem_nFunctions);
	functionSymbol	= &module->bem_functions [functionIndex];
	Assert (functionSymbol->symb_kind == definition
				|| (moduleIndex == kPredefinedModuleIndex && functionSymbol->symb_kind != erroneous_symb));

	originalsdef	= functionSymbol->symb_def;

	typeAlt	= originalsdef->sdef_rule_type->rule_type_rule;
	switch (arrayFunKind)
	{
		case BE_UnqArraySelectFun:
		case BE_UnqArraySelectLastFun:
			Assert (typeAlt->type_alt_lhs->type_node_arity == 2);
			elementType	= typeAlt->type_alt_rhs;
			arrayType	= typeAlt->type_alt_lhs->type_node_arguments->type_arg_node;
			Assert (originalsdef->sdef_arfun == BEArraySelectFun);
			break;
		case BE_ArrayUpdateFun:
			elementType	= typeAlt->type_alt_lhs->type_node_arguments->type_arg_next->type_arg_next->type_arg_node;
			arrayType	= typeAlt->type_alt_lhs->type_node_arguments->type_arg_node;
			Assert (originalsdef->sdef_arfun == BEArrayUpdateFun);
			break;
		default:
			Assert (False);
			return (functionSymbol);
	}

	previousFunctionSymbol	= functionSymbol;
	functionSymbol	= functionSymbol->symb_next;

	if (functionSymbol != NULL && functionSymbol->symb_kind == definition){
		if (functionSymbol->symb_def->sdef_arfun == (ArrayFunKind) arrayFunKind)
			return functionSymbol;

		if (arrayFunKind == BE_UnqArraySelectLastFun && functionSymbol->symb_def->sdef_arfun == BE_UnqArraySelectFun){
			previousFunctionSymbol	= functionSymbol;
			functionSymbol	= functionSymbol->symb_next;

			if (functionSymbol != NULL && functionSymbol->symb_kind == definition &&
				functionSymbol->symb_def->sdef_arfun == (ArrayFunKind) arrayFunKind)
			{
				return functionSymbol;
			}
		}
	}

	{
		char		*functionName, *functionPrefix;
		TypeAlt		*newTypeAlt;
		IdentP		newIdent;
		SymbDefP	newsdef;
		SymbolP		newFunctionSymbol;
		RuleTypes	newRuleType;
		TypeArgs	lhsArgs;
		TypeNode	rhs;

		newFunctionSymbol	= ConvertAllocType (SymbolS);
		newsdef				= ConvertAllocType (SymbDefS);
		newIdent			= ConvertAllocType (IdentS);

		newTypeAlt	= ConvertAllocType (TypeAlt);

		Assert (!arrayType->type_node_is_var);
		switch (arrayType->type_node_symbol->symb_kind)
		{
			case strict_array_type:
			case unboxed_array_type:
				elementType->type_node_annotation	= StrictAnnot;
				break;
			case array_type:
				break;
			default:
				Assert (False);
				break;
		}

		switch (arrayFunKind)
		{
			case BE_UnqArraySelectFun:
				rhs	= BESymbolTypeNode (NoAnnot,NoUniAttr,gBasicSymbols [tuple_type],
											BETypeArgs (elementType, BETypeArgs (arrayType, NULL)));
				lhsArgs	= BETypeArgs (arrayType, BETypeArgs (BESymbolTypeNode (StrictAnnot,NoUniAttr,gBasicSymbols [int_type], NULL), NULL));
				functionPrefix	= "_uselectf";
				break;
			case BE_UnqArraySelectLastFun:
			{
				TypeNode			rType;

				rType	= BEVar0TypeNode (StrictAnnot,NoUniAttr);
				rhs	= BESymbolTypeNode (NoAnnot,NoUniAttr,gBasicSymbols [tuple_type],
											BETypeArgs (elementType, BETypeArgs (rType, NULL)));
				lhsArgs	= BETypeArgs (
							BESymbolTypeNode (StrictAnnot,NoUniAttr,gBasicSymbols [tuple_type],
									BETypeArgs (arrayType, BETypeArgs (rType, NULL))),
							BETypeArgs (BESymbolTypeNode (StrictAnnot,NoUniAttr,gBasicSymbols [int_type], NULL), NULL));
				functionPrefix	= "_uselectl";
				break;
			}
			case BE_ArrayUpdateFun:
			{
				TypeNode			rType;

				rType	= BEVar0TypeNode (StrictAnnot,NoUniAttr);
				rhs	= rType;
				lhsArgs	= BETypeArgs (
							BESymbolTypeNode (StrictAnnot,NoUniAttr,gBasicSymbols [tuple_type],
									BETypeArgs (arrayType, BETypeArgs (rType, NULL))),
							BETypeArgs (BESymbolTypeNode (StrictAnnot,NoUniAttr,gBasicSymbols [int_type], NULL),
							BETypeArgs (elementType,
							NULL)));
				functionPrefix	= "_updatei";
				break;
			}
			default:
				Assert (False);
				break;
		}

		functionName	= ConvertAlloc (strlen (functionPrefix) + 1 + strlen (originalsdef->sdef_ident->ident_name) + 1);
		strcpy (functionName, functionPrefix);
		strcat (functionName, ";");
		strcat (functionName, originalsdef->sdef_ident->ident_name);

		newTypeAlt->type_alt_lhs	= BESymbolTypeNode (NoAnnot,NoUniAttr,newFunctionSymbol, lhsArgs);
		newTypeAlt->type_alt_rhs	= rhs;
		newTypeAlt->type_alt_strict_positions	= NULL;

		newIdent->ident_symbol	= newFunctionSymbol;
		newIdent->ident_name	= functionName;

		newRuleType	= ConvertAllocType (struct rule_type);
		newRuleType->rule_type_rule	= newTypeAlt;

		newsdef->sdef_ident			= newIdent;
		newsdef->sdef_module		= gBEState.be_icl.beicl_module->im_name;
		newsdef->sdef_mark		= 0;
		newsdef->sdef_isused		= True;
		newsdef->sdef_exported		= False;
		newsdef->sdef_arity			= newTypeAlt->type_alt_lhs->type_node_arity;
		newsdef->sdef_arfun			= arrayFunKind;
		newsdef->sdef_kind 			= SYSRULE;
		newsdef->sdef_rule_type		= newRuleType;
		newsdef->sdef_ident			= newIdent;
		newsdef->sdef_mark			= 0;

		newFunctionSymbol->symb_kind	= definition;
		newFunctionSymbol->symb_def		= newsdef;

		functionSymbol						= previousFunctionSymbol->symb_next;
		previousFunctionSymbol->symb_next	= newFunctionSymbol;
		newFunctionSymbol->symb_next		= functionSymbol;

		AddUserDefinedArrayFunction (newFunctionSymbol);

		functionSymbol	= newFunctionSymbol;
	}

	return (functionSymbol);
} /* BESpecialArrayFunctionSymbol */

static SymbolP
CreateLocallyDefinedFunction (int index, char ** abcCode, TypeArgs lhsArgs, TypeNode rhsType)
{
	int				i, arity, functionIndex;
	NodeP			lhs;
	BEStringListP	instructions, *instructionsP;
	BECodeBlockP	codeBlock;
	RuleAltP		ruleAlt;
	SymbolP			functionSymbol;
	TypeAlt			*typeAlt;
	ArgP			args;

	functionIndex	= gBEState.be_modules[main_dcl_module_n].bem_nFunctions - ArraySize (gLocallyGeneratedFunctions) + index;
	functionSymbol	= BEFunctionSymbol (functionIndex, main_dcl_module_n);
	functionSymbol->symb_def->sdef_isused	= False;

	instructionsP	= &instructions;
	for (i = 0; abcCode [i] != NULL; i++)
	{
		BEStringListP	string;

		string	= ConvertAllocType (struct string_list);

		string->sl_string	= abcCode [i];
		string->sl_next		= instructions;

		*instructionsP	= string;
		instructionsP	= &string->sl_next;
	}
	*instructionsP	=	NULL;

	codeBlock	= BEAbcCodeBlock (False, instructions);
		
	lhs		= BENormalNode (functionSymbol, NULL);
	arity	= CountTypeArgs (lhsArgs);

	args	= NULL;
	for (i = 0; i < arity; i++)
		args	= BEArgs (BENodeIdNode (BEWildCardNodeId (), NULL), args);

	lhs->node_arguments	= args;
	lhs->node_arity		= arity;

	Assert (arity == functionSymbol->symb_def->sdef_arity);

	ruleAlt		= BECodeAlt (0, NULL, lhs, codeBlock);

	typeAlt	= ConvertAllocType (TypeAlt);

	typeAlt->type_alt_lhs	= BESymbolTypeNode (NoAnnot,NoUniAttr,functionSymbol, lhsArgs);
	typeAlt->type_alt_rhs	= rhsType;
	typeAlt->type_alt_strict_positions	= NULL;

	BERule (functionIndex, BEIsNotACaf, typeAlt, ruleAlt);
	
	return (functionSymbol);
} /* CreateLocallyDefinedFunction */

static BESymbolP
CreateDictionarySelectFunSymbol (void)
{
	TypeNode		rhsType;
	TypeArgs		lhsArgs;

	/* selectl :: !((a e) Int -> e) !(!a e, !r) !Int -> (e, !r) */
	/* select _ _ _ = code */
	static char *abcCode[] = {
		"push_a 1",
		"push_a 1",
		"build e_system_dAP 2 e_system_nAP",
		"buildI_b 0",
		"push_a 1",
		"update_a 1 2",
		"update_a 0 1",
		"pop_a 1",
		"build e_system_dAP 2 e_system_nAP",
		"push_a 3",
		"push_a 1",
		"update_a 1 2",
		"update_a 0 1",
		"pop_a 1",
		"update_a 1 4",
		"update_a 0 3",
		"pop_a 3",
		"pop_b 1",
		NULL
	};

	/*	actual type simplified to !a !(!a,!a) !Int -> (a,!a) */
	lhsArgs	=	BETypeArgs (
					BEVar0TypeNode (StrictAnnot,NoUniAttr),
				BETypeArgs (
					BESymbolTypeNode (StrictAnnot,NoUniAttr,gBasicSymbols [tuple_type],
								BETypeArgs (
									BEVar0TypeNode (StrictAnnot,NoUniAttr),
								BETypeArgs (
									BEVar0TypeNode (StrictAnnot,NoUniAttr),
								NULL))),
				BETypeArgs (
					BESymbolTypeNode (StrictAnnot,NoUniAttr,gBasicSymbols [int_type], NULL),
				NULL)));
	rhsType	= BESymbolTypeNode (NoAnnot,NoUniAttr,gBasicSymbols [tuple_type],
								BETypeArgs (BEVar0TypeNode (NoAnnot,NoUniAttr), BETypeArgs (BEVar0TypeNode (StrictAnnot,NoUniAttr), NULL)));

	return (CreateLocallyDefinedFunction (kDictionarySelect, abcCode, lhsArgs, rhsType));
} /* CreateDictionarySelectFunSymbol */

static BESymbolP
CreateDictionaryUpdateFunSymbol (void)
{
	TypeNode		rhsType;
	TypeArgs		lhsArgs;

	/* updatei :: !(*(a .e) -> *(!Int -> *(.e -> .(a .e)))) !(!*(a .e), !*r) !Int .e -> *r // !(!.(a .e), !*r) */
	/* updatei _ _ _ _ = code */
	static char *abcCode[] = {
		"push_a 3",
		"buildI_b 0",
		"push_a 3",
		"push_a 3",
		"pop_b 1",
		"update_a 6 7",
		"update_a 3 6",
		"update_a 2 5",
		"update_a 1 4",
		"updatepop_a 0 3",
		"jsr_ap 3",
		"pop_a 1",
		NULL
	};

	/*	actual type simplified to !a !(!a,!a) !Int a -> a */
	lhsArgs	=	BETypeArgs (
					BEVar0TypeNode (StrictAnnot,NoUniAttr),
				BETypeArgs (
					BESymbolTypeNode (StrictAnnot,NoUniAttr,gBasicSymbols [tuple_type],
								BETypeArgs (
									BEVar0TypeNode (StrictAnnot,NoUniAttr),
								BETypeArgs (
									BEVar0TypeNode (StrictAnnot,NoUniAttr),
								NULL))),
				BETypeArgs (
					BESymbolTypeNode (StrictAnnot,NoUniAttr,gBasicSymbols [int_type], NULL),
				BETypeArgs (
					BEVar0TypeNode (NoAnnot,NoUniAttr),
				NULL))));

	rhsType	= BEVar0TypeNode (NoAnnot,NoUniAttr);

	return (CreateLocallyDefinedFunction (kDictionaryUpdate, abcCode, lhsArgs, rhsType));
} /* CreateDictionaryUpdateFunSymbol */

BESymbolP
BEDictionarySelectFunSymbol (void)
{
	gBEState.be_dictionarySelectFunSymbol->symb_def->sdef_isused	= True;

	return (gBEState.be_dictionarySelectFunSymbol);
} /* BEDictionarySelectFunSymbol */

BESymbolP
BEDictionaryUpdateFunSymbol (void)
{
	gBEState.be_dictionaryUpdateFunSymbol->symb_def->sdef_isused	= True;

	return (gBEState.be_dictionaryUpdateFunSymbol);
} /* BEDictionaryUpdateFunSymbol */

BESymbolP
BETypeSymbol (int typeIndex, int moduleIndex)
{
	BEModuleP	module;
	SymbolP		typeSymbol;

	if ((unsigned int) moduleIndex >= gBEState.be_nModules)
		Assert ((unsigned int) moduleIndex < gBEState.be_nModules);
	module	= &gBEState.be_modules [moduleIndex];

	Assert ((unsigned int) typeIndex < module->bem_nTypes);
	typeSymbol	= &module->bem_types [typeIndex];
/*	Assert (typeSymbol->symb_kind == definition
				|| (moduleIndex == kPredefinedModuleIndex && typeSymbol->symb_kind != erroneous_symb));
*/
	if (moduleIndex == main_dcl_module_n)
		typeSymbol->symb_def->sdef_isused	= True;

	return (typeSymbol);
} /* BETypeSymbol */

BESymbolP BETypeSymbolNoMark (int typeIndex, int moduleIndex)
{
	return &gBEState.be_modules [moduleIndex].bem_types [typeIndex];
}

BESymbolP
BEDontCareDefinitionSymbol (void)
{
	SymbolP	symbol;

	symbol	= gBEState.be_dontCareSymbol;
	if (symbol == NULL)
	{
		SymbDefP	symbDef;

		symbDef	= ConvertAllocType (SymbDefS);
		symbDef->sdef_kind	= ABSTYPE;

		symbDef->sdef_ident	= Identifier ("_Don'tCare"); /* +++ name */

		symbol	= ConvertAllocType (SymbolS);
		symbol->symb_kind	= definition;
		symbol->symb_def	= symbDef;

		gBEState.be_dontCareSymbol	= symbol;
	}

	return (symbol);
} /* BEDontCareDefinitionSymbol */

BESymbolP
BEConstructorSymbol (int constructorIndex, int moduleIndex)
{
	BEModuleP	module;
	SymbolP		constructorSymbol;

	Assert ((unsigned int) moduleIndex < gBEState.be_nModules);
	module	= &gBEState.be_modules [moduleIndex];

	Assert ((unsigned int) constructorIndex < module->bem_nConstructors);
	constructorSymbol = &module->bem_constructors [constructorIndex];

	Assert (constructorSymbol->symb_kind == definition || constructorSymbol->symb_kind == cons_symb
				|| (moduleIndex == kPredefinedModuleIndex && constructorSymbol->symb_kind != erroneous_symb));

	if (moduleIndex != kPredefinedModuleIndex && constructorSymbol->symb_kind!=cons_symb)
		constructorSymbol->symb_def->sdef_isused	= True;

	return (constructorSymbol);
} /* BEConstructorSymbol */

BESymbolP
BEFieldSymbol (int fieldIndex, int moduleIndex)
{
	BEModuleP	module;
	SymbolP		fieldSymbol;

	Assert ((unsigned int) moduleIndex < gBEState.be_nModules);
	module	= &gBEState.be_modules [moduleIndex];

	Assert ((unsigned int) fieldIndex < module->bem_nFields);
	fieldSymbol	= &module->bem_fields [fieldIndex];
	Assert (fieldSymbol->symb_kind == definition);

	fieldSymbol->symb_def->sdef_isused	= True;

	return (fieldSymbol);
} /* BEFieldSymbol */

BESymbolP
BEBoolSymbol (int value)
{
	if (value)