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)
		return TrueSymbol;
	else
		return FalseSymbol;
} /* BEBoolSymbol */

BESymbolP
BELiteralSymbol (BESymbKind kind, CleanString value)
{
	SymbolP	symbol;

	symbol	= ConvertAllocType (SymbolS);
	symbol->symb_kind	= kind;
	symbol->symb_int	= ConvertCleanString (value);

	return (symbol);
} /* BELiteralSymbol */

# define	nid_ref_count_sign	nid_scope

#if STRICT_LISTS
static SymbolS unboxed_list_symbols[Nr_Of_Predef_Types][2];

static SymbolP strict_list_cons_symbols[8];

void BEPredefineListConstructorSymbol (int constructorIndex,int moduleIndex,BESymbKind symbolKind,int head_strictness,int tail_strictness)
{
	BEModuleP	module;
	SymbolP symbol_p;

	Assert (moduleIndex == kPredefinedModuleIndex);

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

	Assert ((unsigned int) constructorIndex < module->bem_nConstructors);
	symbol_p=&module->bem_constructors [constructorIndex];
	symbol_p->symb_kind	= symbolKind;
	symbol_p->symb_head_strictness=head_strictness;
	symbol_p->symb_tail_strictness=tail_strictness;

	if (symbolKind==BEConsSymb && head_strictness<4)
		strict_list_cons_symbols[(head_strictness<<1)+tail_strictness]=symbol_p;
}

void BEPredefineListTypeSymbol (int typeIndex,int moduleIndex,BESymbKind symbolKind,int head_strictness,int tail_strictness)
{
	BEModuleP	module;
	SymbolP symbol_p;

	Assert (moduleIndex == kPredefinedModuleIndex);

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

	Assert ((unsigned int) typeIndex < module->bem_nTypes);
	symbol_p=&module->bem_types [typeIndex];
	symbol_p->symb_kind = symbolKind;
	symbol_p->symb_arity = 1;
	symbol_p->symb_head_strictness=head_strictness;
	symbol_p->symb_tail_strictness=tail_strictness;
}

void BEAdjustStrictListConsInstance (int functionIndex,int moduleIndex)
{
	SymbolP symbol_p;

	symbol_p=&gBEState.be_modules[moduleIndex].bem_functions[functionIndex];

	if (symbol_p->symb_kind==definition){
		TypeNode element_type_p,list_type_p;
		SymbDef sdef;
		TypeArgs type_args_p;
		
		sdef=symbol_p->symb_def;
		type_args_p=sdef->sdef_rule_type->rule_type_rule->type_alt_lhs->type_node_arguments;
		element_type_p=type_args_p->type_arg_node;
		list_type_p=type_args_p->type_arg_next->type_arg_node;
		
		Assert (list_type_p->type_node_is_var==0);
		Assert (list_type_p->type_node_symbol->symb_kind==list_type);

		symbol_p->symb_head_strictness=list_type_p->type_node_symbol->symb_head_strictness;
		symbol_p->symb_tail_strictness=list_type_p->type_node_symbol->symb_tail_strictness;

		if (list_type_p->type_node_symbol->symb_head_strictness==3){
			int element_symbol_kind;
			struct unboxed_cons *unboxed_cons_p;

			Assert (element_type_p->type_node_is_var==0);

			element_symbol_kind=element_type_p->type_node_symbol->symb_kind;

			symbol_p->symb_head_strictness=4;

			unboxed_cons_p=ConvertAllocType (struct unboxed_cons);

			unboxed_cons_p->unboxed_cons_sdef_p=sdef;

			if (element_symbol_kind < Nr_Of_Predef_Types)
				unboxed_cons_p->unboxed_cons_state_p = unboxed_list_symbols[element_symbol_kind][symbol_p->symb_tail_strictness].symb_state_p;
			else if (element_symbol_kind==definition && element_type_p->type_node_symbol->symb_def->sdef_kind==RECORDTYPE){
				PolyList new_unboxed_record_cons_element;
				SymbDef record_sdef;
				
				record_sdef=element_type_p->type_node_symbol->symb_def;
				record_sdef->sdef_isused=True;
				sdef->sdef_isused=True;
				unboxed_cons_p->unboxed_cons_state_p = &record_sdef->sdef_record_state;
				
				new_unboxed_record_cons_element=ConvertAllocType (struct poly_list);
				new_unboxed_record_cons_element->pl_elem = sdef;
				new_unboxed_record_cons_element->pl_next = unboxed_record_cons_list;
				unboxed_record_cons_list = new_unboxed_record_cons_element;
				
				sdef->sdef_module=NULL;
			} else
				unboxed_cons_p->unboxed_cons_state_p = &StrictState;
			
			symbol_p->symb_unboxed_cons_p=unboxed_cons_p;
		}
	} else {
		Assert (symbol_p->symb_kind==definition);
		
		debug_message ("BEAdjustStrictListInstance: !(symbol_p->symb_kind==definition) %d %d %d\n",functionIndex,moduleIndex,symbol_p->symb_kind);

		symbol_p->symb_head_strictness=0;
		symbol_p->symb_tail_strictness=0;
	}
	
	symbol_p->symb_kind = cons_symb;
	/* symbol_p->symb_arity = 2; no symb_arity for cons_symb, because symb_state_p is used of this union */
}

void BEAdjustUnboxedListDeconsInstance (int functionIndex,int moduleIndex)
{
	SymbolP symbol_p,cons_symbol_p;
	SymbDefP sdef_p;
	TypeNode element_type_p,list_type_p;
	PolyList new_unboxed_record_decons_element;

	symbol_p=&gBEState.be_modules[moduleIndex].bem_functions[functionIndex];

	Assert (symbol_p->symb_kind==definition);
	sdef_p=symbol_p->symb_def;
	
	list_type_p=sdef_p->sdef_rule_type->rule_type_rule->type_alt_lhs->type_node_arguments->type_arg_node;
	element_type_p=list_type_p->type_node_arguments->type_arg_node;
	
	Assert (list_type_p->type_node_is_var==0);
	Assert (list_type_p->type_node_symbol->symb_kind==list_type);
	Assert (list_type_p->type_node_symbol->symb_head_strictness==3);
	Assert (element_type_p->type_node_symbol->symb_def->sdef_kind==RECORDTYPE);
	
	cons_symbol_p=ConvertAllocType (SymbolS);

	cons_symbol_p->symb_kind = cons_symb;
	cons_symbol_p->symb_head_strictness=4;
	cons_symbol_p->symb_tail_strictness=list_type_p->type_node_symbol->symb_tail_strictness;
	cons_symbol_p->symb_state_p=&element_type_p->type_node_symbol->symb_def->sdef_record_state;

	sdef_p->sdef_unboxed_cons_symbol=cons_symbol_p;
	
	new_unboxed_record_decons_element=ConvertAllocType (struct poly_list);
	new_unboxed_record_decons_element->pl_elem = sdef_p;
	new_unboxed_record_decons_element->pl_next = unboxed_record_decons_list;
	unboxed_record_decons_list = new_unboxed_record_decons_element;
}

void BEAdjustOverloadedNilFunction (int functionIndex,int moduleIndex)
{
	SymbolP symbol_p;

	symbol_p=&gBEState.be_modules[moduleIndex].bem_functions[functionIndex];

	symbol_p->symb_head_strictness=1;
	symbol_p->symb_tail_strictness=0;
	
	symbol_p->symb_kind = nil_symb;
}

BESymbolP BEOverloadedConsSymbol (int constructorIndex,int moduleIndex,int deconsIndex,int deconsModuleIndex)
{
	BEModuleP module,decons_module;
	SymbolP constructor_symbol,decons_symbol,list_type_symbol;
	TypeNode list_type,element_type;

	Assert ((unsigned int) deconsModuleIndex < gBEState.be_nModules);
	decons_module = &gBEState.be_modules [deconsModuleIndex];

	Assert ((unsigned int) deconsIndex < decons_module->bem_nFunctions);
	decons_symbol = &decons_module->bem_functions [deconsIndex];

	Assert (decons_symbol->symb_kind==definition);
	
	list_type=decons_symbol->symb_def->sdef_rule_type->rule_type_rule->type_alt_lhs->type_node_arguments->type_arg_node;
	element_type=list_type->type_node_arguments->type_arg_node;
	
	Assert ((unsigned int) moduleIndex < gBEState.be_nModules);
	module = &gBEState.be_modules [moduleIndex];

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

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

	if (moduleIndex != kPredefinedModuleIndex)
		constructor_symbol->symb_def->sdef_isused = True;

	list_type_symbol=list_type->type_node_symbol;

	if (constructor_symbol->symb_head_strictness==1 && list_type_symbol->symb_head_strictness<4)
		constructor_symbol=strict_list_cons_symbols[(list_type_symbol->symb_head_strictness<<1)+list_type_symbol->symb_tail_strictness];

	if (list_type_symbol->symb_head_strictness==3){
		int element_symbol_kind;
		
		Assert (element_type->type_node_is_var==0);

		element_symbol_kind=element_type->type_node_symbol->symb_kind;

		if (element_symbol_kind<Nr_Of_Predef_Types)
			constructor_symbol=&unboxed_list_symbols[element_symbol_kind][list_type_symbol->symb_tail_strictness];
		else if (element_symbol_kind==definition && element_type->type_node_symbol->symb_def->sdef_kind==RECORDTYPE)
			constructor_symbol=decons_symbol->symb_def->sdef_unboxed_cons_symbol;
	}
	
	return constructor_symbol;
}

BENodeP BEOverloadedPushNode (int arity,BESymbolP symbol,BEArgP arguments,BENodeIdListP nodeIds,BENodeP decons_node)
{
	NodeP	push_node;

	push_node	= ConvertAllocType (NodeS);

	push_node->node_kind		= PushNode;
	push_node->node_arity		= arity;
	push_node->node_arguments	= arguments;
	push_node->node_push_symbol = symbol;
	push_node->node_decons_node = decons_node;
	push_node->node_node_ids	= nodeIds;
	push_node->node_number		= 0;

	Assert (arguments->arg_node->node_kind == NodeIdNode);
	Assert (arguments->arg_node->node_node_id->nid_ref_count_sign == -1);
		
	arguments->arg_node->node_node_id->nid_refcount++;
	
	return push_node;
}
#endif

void
BEPredefineConstructorSymbol (int arity, int constructorIndex, int moduleIndex, BESymbKind symbolKind)
{
	BEModuleP	module;

	Assert (moduleIndex == kPredefinedModuleIndex);

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

	Assert ((unsigned int) constructorIndex < module->bem_nConstructors);
	Assert (module->bem_constructors [constructorIndex].symb_kind == erroneous_symb);

	module->bem_constructors [constructorIndex].symb_kind	= symbolKind;
	module->bem_constructors [constructorIndex].symb_arity	= arity;
} /* BEPredefineConstructorSymbol */

void
BEPredefineTypeSymbol (int arity, int typeIndex, int moduleIndex, BESymbKind symbolKind)
{
	BEModuleP	module;

	Assert (moduleIndex == kPredefinedModuleIndex);

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

	Assert ((unsigned int) typeIndex < module->bem_nTypes);
	Assert (module->bem_types [typeIndex].symb_kind == erroneous_symb);

	module->bem_types [typeIndex].symb_kind		= symbolKind;
	module->bem_types [typeIndex].symb_arity	= arity;
} /* BEPredefineTypeSymbol */

BESymbolP
BEBasicSymbol (BESymbKind kind)
{
	Assert (gBasicSymbols [kind] != NULL);

	return (gBasicSymbols [kind]);
} /* BEBasicSymbol */

BETypeNodeP
BEVar0TypeNode (BEAnnotation annotation, BEAttribution attribution)
{
	TypeNode node;

	node = ConvertAllocType (struct type_node);

	node->type_node_is_var		= True;
	node->type_node_tv_argument_n = 0;
	node->type_node_arity		= 0;
	node->type_node_annotation	= annotation;
	node->type_node_attribute	= attribution;

	return node;
}

BETypeNodeP
BEVarNTypeNode (BEAnnotation annotation, BEAttribution attribution, int argument_n)
{
	TypeNode node;

	node = ConvertAllocType (struct type_node);

	node->type_node_is_var		= True;
	node->type_node_tv_argument_n = argument_n;
	node->type_node_arity		= 0;
	node->type_node_annotation	= annotation;
	node->type_node_attribute	= attribution;

	return node;
}

BETypeNodeP
BESymbolTypeNode (BEAnnotation annotation, BEAttribution attribution, BESymbolP symbol, BETypeArgP args)
{
	TypeNode	node;

	node	= ConvertAllocType (struct type_node);

	node->type_node_is_var		= False;
	node->type_node_arity		= CountTypeArgs (args);
	node->type_node_annotation	= annotation;
	node->type_node_attribute	= attribution;
	node->type_node_symbol		= symbol;
	node->type_node_arguments	= args;

	return node;
}

BETypeArgP
BENoTypeArgs (void)
{
	return (NULL);
} /* BENoTypeArgs */

BETypeArgP
BETypeArgs (BETypeNodeP node, BETypeArgP nextArgs)
{
	TypeArgs	arg;

	arg	= ConvertAllocType (TypeArg);

	arg->type_arg_node	= node;
	arg->type_arg_next	= nextArgs;

	return (arg);
} /* BETypeArgs */

BETypeAltP
BETypeAlt (BETypeNodeP lhs, BETypeNodeP rhs)
{
	TypeAlt	*alt;

	alt	= ConvertAllocType (struct type_alt);

	alt->type_alt_lhs	= lhs;
	alt->type_alt_rhs	= rhs;

	alt->type_alt_strict_positions	= NULL;

	return (alt);
} /* BETypeAlt */

static Node
GenerateApplyNodes (Node root, int offarity, int demarity)
{
	if (offarity > demarity)
	{
		int		i;
		Args	lastarg, nextarg;
		
		if (demarity != 0)
		{
			for (i=1, lastarg = root->node_arguments; i < demarity; i++)
				lastarg = lastarg->arg_next;
		
			nextarg = lastarg->arg_next;
			lastarg->arg_next = NULL;
		}
		else
		{
			nextarg = root->node_arguments;
			root->node_arguments = NULL;
		}
		root->node_arity = (short) demarity;
		
		for (i=demarity+1; i<=offarity; i++)
		{
			Args	arg;

			arg	= BEArgs (root, nextarg);

   			nextarg	= nextarg->arg_next;
			arg->arg_next->arg_next = NULL;

			root	= BENormalNode (gBasicSymbols [apply_symb], arg);
		}
	}

	return (root);
} /* GenerateApplyNodes */

BENodeP
BENormalNode (BESymbolP symbol, BEArgP args)
{
	NodeP	node;

	node	= ConvertAllocType (NodeS);

	node->node_annotation	= NoAnnot;
	node->node_kind			= NormalNode;
	node->node_symbol		= symbol;
	node->node_arity		= CountArgs (args);
	node->node_arguments	= args;
	node->node_number=0;

	/* +++ hackerdiehack */
	if (symbol->symb_kind == definition)
		node	= GenerateApplyNodes (node, node->node_arity, symbol->symb_def->sdef_arity);

	return (node);
} /* BENormalNode */

BENodeP
BEMatchNode (int arity, BESymbolP symbol, BENodeP node)
{
	NodeP	matchNode;

	if (symbol->symb_kind == tuple_symb)
		return (node);

	matchNode	= ConvertAllocType (NodeS);

	matchNode->node_annotation	= NoAnnot;
	matchNode->node_kind		= MatchNode;
	matchNode->node_symbol		= symbol;
	matchNode->node_arity		= arity;
	matchNode->node_arguments	= BEArgs (node, NULL);
	matchNode->node_number=0;

	return (matchNode);
} /* BEMatchNode */

BENodeP
BETupleSelectNode (int arity, int index, BENodeP node)
{
	SymbolP symbol;
	NodeP	select;

	if ((symbol = gTupleSelectSymbols [arity-1]) == NULL)
	{
		symbol	= ConvertAllocType (SymbolS);
	
		symbol->symb_kind	= select_symb;
		symbol->symb_arity	= arity;

		gTupleSelectSymbols [arity-1]	= symbol;
	}

	select	= ConvertAllocType (NodeS);

	select->node_annotation	= NoAnnot;
	select->node_kind		= NormalNode;
	select->node_symbol		= symbol;
	select->node_arity		= index+1;
	select->node_arguments	= BEArgs (node, NULL);
	select->node_number		= 0;

	return (select);
} /* BETupleSelectNode */

BENodeP
BEIfNode (BENodeP cond, BENodeP then, BENodeP elsje)
{
	NodeP	node;

	node	= ConvertAllocType (NodeS);

	node->node_annotation	= NoAnnot;
	node->node_kind			= NormalNode;
	node->node_symbol		= gBasicSymbols [if_symb];
	node->node_arguments	= BEArgs (cond, BEArgs (then, BEArgs (elsje, NULL)));
	node->node_arity		= 3;
	node->node_number		= 0;

	return (node);
} /* BEIfNode */

BENodeP
BEGuardNode (BENodeP cond, BENodeDefP thenNodeDefs, BEStrictNodeIdP thenStricts, BENodeP then, BENodeDefP elseNodeDefs, BEStrictNodeIdP elseStricts, BENodeP elsje)
{
	NodeP	node;
	struct if_node_contents *thenElseInfo;

	thenElseInfo = ConvertAllocType (struct if_node_contents);

	thenElseInfo->if_then_node_defs			= thenNodeDefs;
	thenElseInfo->if_then_strict_node_ids	= thenStricts;
	thenElseInfo->if_else_node_defs			= elseNodeDefs;
	thenElseInfo->if_else_strict_node_ids	= elseStricts;

	node	= ConvertAllocType (NodeS);

	node->node_annotation			= NoAnnot;
	node->node_kind					= IfNode;
	node->node_contents.contents_if	= thenElseInfo;
	node->node_arguments			= BEArgs (cond, BEArgs (then, BEArgs (elsje, NULL)));
	node->node_number				= 0;

	switch (elsje->node_kind)
	{
		case SwitchNode:
			thenElseInfo->if_else_node_defs			= NULL;
			thenElseInfo->if_else_strict_node_ids	= NULL;
			node->node_arguments->arg_next->arg_next->arg_node
								= BENormalNode (BEBasicSymbol (BEFailSymb), BENoArgs ());

			node	= NewGuardNode (node, elsje, elseNodeDefs, elseStricts);
			break;
		case GuardNode:
			/* move the GuardNode to the top */
			node->node_arguments->arg_next->arg_next->arg_node
								= elsje->node_arguments->arg_node;
			elsje->node_arguments->arg_node	=	node;
			node	= elsje;
			break;
		default:
			break;
	}

	return (node);
} /* BEGuardNode */