aboutsummaryrefslogtreecommitdiff
path: root/backendC/CleanCompilerSources/backend.c
diff options
context:
space:
mode:
Diffstat (limited to 'backendC/CleanCompilerSources/backend.c')
-rw-r--r--backendC/CleanCompilerSources/backend.c2683
1 files changed, 2683 insertions, 0 deletions
diff --git a/backendC/CleanCompilerSources/backend.c b/backendC/CleanCompilerSources/backend.c
new file mode 100644
index 0000000..630f19d
--- /dev/null
+++ b/backendC/CleanCompilerSources/backend.c
@@ -0,0 +1,2683 @@
+
+#define CODE_INLINE_FLAG
+#define DYNAMIC_TYPE 1
+
+# include "system.h"
+# include "compiledefines.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 "dynamics.h"
+
+# include "backend.h"
+
+# include <limits.h>
+
+void
+BEGetVersion (int *current, int *oldestDefinition, int *oldestImplementation)
+{
+ *current = kBEVersionCurrent;
+ *oldestDefinition = kBEVersionOldestDefinition;
+ *oldestImplementation = kBEVersionOldestImplementation;
+}
+
+
+extern PolyList UserDefinedArrayFunctions; /* typechecker.c */
+extern StdOutReopened, StdErrorReopened; /* cocl.c */
+
+/*
+ Strings
+ =======
+*/
+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 */
+
+/*
+ Counting routines
+*/
+
+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_nConstructors;
+
+ unsigned int bem_nTypes;
+ SymbolP *bem_types;
+
+ 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;
+ unsigned int beicl_previousAncestor;
+};
+
+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_allSymbols;
+ SymbolP be_dontCareSymbol;
+ SymbolP be_dictionarySelectFunSymbol;
+ SymbolP be_dictionaryUpdateFunSymbol;
+};
+
+static BEStateS gBEState = {False /* ... */};
+
+/* +++ dynamic allocation */
+# define kMaxNumberOfNodeIds 1000
+
+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 [kMaxNumberOfNodeIds];
+static SymbolP gBasicSymbols [Nr_Of_Predef_FunsOrConses];
+static SymbolP gTupleSelectSymbols [MaxNodeArity];
+
+static int number_of_node_ids=0;
+
+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 nSymbols, SymbolP otherSymbols)
+{
+ int i;
+ SymbolP symbols;
+
+ if (nSymbols > 0)
+ {
+ symbols = (SymbolP) ConvertAlloc (nSymbols * sizeof (SymbolS));
+
+ for (i = 0; i < nSymbols; i++)
+ {
+ symbols [i].symb_kind = erroneous_symb;
+ symbols [i].symb_next = &symbols [i+1];
+ }
+ symbols [nSymbols-1].symb_next = otherSymbols;
+ }
+ else
+ symbols = otherSymbols;
+
+ return (symbols);
+} /* 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);
+ 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 void
+DeclareModule (int moduleIndex, char *name, Bool isSystemModule, int nFunctions,
+ int nTypes, int nConstructors, int nFields)
+{
+ BEModuleP module;
+ SymbolP symbols, allSymbols;
+
+ allSymbols = gBEState.be_allSymbols;
+
+ allSymbols = AllocateSymbols (nFunctions + nTypes + nConstructors + nFields, allSymbols);
+
+ Assert ((unsigned int) moduleIndex < gBEState.be_nModules);
+ module = &gBEState.be_modules [moduleIndex];
+
+ module->bem_name = name;
+ module->bem_isSystemModule = isSystemModule;
+
+ symbols = allSymbols;
+
+ module->bem_nFunctions = (unsigned int) nFunctions;
+ module->bem_functions = symbols;
+ symbols += nFunctions;
+
+ module->bem_nTypes = (unsigned int) nTypes;
+// module->bem_types = symbols;
+ {
+ /* +++ do this lazily */
+ int i;
+
+ module->bem_types = (SymbolP *) ConvertAlloc (nTypes * sizeof (SymbolP));
+
+ for (i = 0; i < nTypes; i++)
+ {
+ module->bem_types [i] = &symbols [i];
+ }
+ }
+ {
+ /* +++ change this */
+ int i;
+ for (i = 0; i < nTypes; i++)
+ {
+ SymbDef newSymbDef;
+
+ newSymbDef = ConvertAllocType (SymbDefS);
+ newSymbDef->sdef_isused = False;
+ symbols [i].symb_def = newSymbDef;
+ }
+ }
+ symbols += nTypes;
+
+ module->bem_nConstructors = (unsigned int) nConstructors;
+// module->bem_constructors = symbols;
+ {
+ /* +++ do this lazily */
+ int i;
+
+ module->bem_constructors = (SymbolP *) ConvertAlloc (nConstructors * sizeof (SymbolP));
+
+ for (i = 0; i < nConstructors; i++)
+ {
+ module->bem_constructors [i] = &symbols [i];
+ }
+ }
+ symbols += nConstructors;
+
+ module->bem_nFields = (unsigned int) nFields;
+ module->bem_fields = symbols;
+ symbols += nFields;
+
+ gBEState.be_allSymbols = allSymbols;
+} /* DeclareModule */
+
+void
+BEDeclareIclModule (CleanString name, int nFunctions, int nTypes, int nConstructors, int nFields)
+{
+ int i;
+ char *cName;
+ SymbolP moduleNameSymbol;
+ ImpMod iclModule;
+ BEIclP icl;
+
+ cName = ConvertCleanString (name);
+
+ moduleNameSymbol = ConvertAllocType (SymbolS);
+ moduleNameSymbol->symb_ident = Identifier (cName);
+
+ Assert (strcmp (gBEState.be_modules [kIclModuleIndex].bem_name, cName) == 0);
+
+ icl = &gBEState.be_icl;
+
+ icl->beicl_module = ConvertAllocType (ImpRepr);
+ icl->beicl_dcl_module = gBEState.be_modules [kIclModuleIndex];
+ icl->beicl_previousAncestor = UINT_MAX;
+ scc_dependency_list = NULL;
+ icl->beicl_depsP = &scc_dependency_list;
+
+ nFunctions += ArraySize (gLocallyGeneratedFunctions);
+ DeclareModule (kIclModuleIndex, cName, False, nFunctions, nTypes, nConstructors, nFields);
+
+ iclModule = icl->beicl_module;
+ iclModule->im_name = moduleNameSymbol;
+ iclModule->im_def_module = NULL;
+ iclModule->im_rules = NULL;
+ iclModule->im_start = NULL;
+ iclModule->im_symbols = gBEState.be_allSymbols;
+# if IMPORT_OBJ_AND_LIB
+ iclModule->im_imported_objs = NULL;
+ iclModule->im_imported_libs = NULL;
+# endif
+
+ CurrentModule = cName;
+
+ for (i = 0; i < ArraySize (gLocallyGeneratedFunctions); i++)
+ {
+ static void DeclareFunctionC (char *name, int arity, int functionIndex, unsigned int ancestor);
+ BELocallyGeneratedFunctionP locallyGeneratedFunction;
+
+ locallyGeneratedFunction = &gLocallyGeneratedFunctions [i];
+
+ DeclareFunctionC (locallyGeneratedFunction->lgf_name, locallyGeneratedFunction->lgf_arity, nFunctions-ArraySize(gLocallyGeneratedFunctions)+i, UINT_MAX);
+ }
+
+ /* +++ hack */
+ {
+ static BESymbolP CreateDictionarySelectFunSymbol (void);
+ static BESymbolP CreateDictionaryUpdateFunSymbol (void);
+
+ gBEState.be_dictionarySelectFunSymbol = CreateDictionarySelectFunSymbol ();
+ gBEState.be_dictionaryUpdateFunSymbol = CreateDictionaryUpdateFunSymbol ();
+ }
+} /* BEDeclareIclModule */
+
+void
+BEDeclareDclModule (int moduleIndex, CleanString name, int isSystemModule, int nFunctions, int nTypes, int nConstructors, int nFields)
+{
+ char *cName;
+ SymbolP moduleNameSymbol;
+ DefMod dclModule;
+
+ cName = ConvertCleanString (name);
+
+ moduleNameSymbol = ConvertAllocType (SymbolS);
+ moduleNameSymbol->symb_ident = Identifier (cName);
+
+ DeclareModule (moduleIndex, cName, isSystemModule, nFunctions, nTypes, nConstructors, nFields);
+
+ dclModule = ConvertAllocType (DefRepr);
+ dclModule->dm_name = moduleNameSymbol;
+ dclModule->dm_system_module = isSystemModule;
+ dclModule->dm_symbols = gBEState.be_allSymbols; /* ??? too many symbols? */
+
+ if (moduleIndex != kIclModuleIndex)
+ AddOpenDefinitionModule (moduleNameSymbol, 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)
+{
+ Assert (gBEState.be_modules == NULL);
+
+ gBEState.be_nModules = (unsigned int) nModules;
+ gBEState.be_modules = (BEModuleP) ConvertAlloc (nModules * sizeof (BEModuleS));
+} /* 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
+ || (moduleIndex == kPredefinedModuleIndex && functionSymbol->symb_kind != erroneous_symb));
+
+ functionSymbol->symb_def->sdef_isused = True;
+
+ return (functionSymbol);
+} /* BEFunctionSymbol */
+
+static void
+GetArrayFunctionType (SymbDefP sdef, TypeNode *elementTypeP, TypeNode *arrayTypeP)
+{
+ TypeAlt *typeAlt;
+
+ typeAlt = sdef->sdef_rule_type->rule_type_rule;
+
+ switch (sdef->sdef_arfun)
+ {
+ case BEArraySelectFun:
+ case BEUnqArraySelectFun:
+ case BE_UnqArraySelectFun:
+ case BE_UnqArraySelectNextFun:
+ case BE_UnqArraySelectLastFun:
+ break;
+ case BEArrayUpdateFun:
+ case BE_ArrayUpdateFun:
+ Assert (typeAlt->type_alt_lhs->type_node_arity == 3);
+ *elementTypeP = typeAlt->type_alt_lhs->type_node_arguments->type_arg_next->type_arg_next->type_arg_node;
+ *arrayTypeP = typeAlt->type_alt_lhs->type_node_arguments->type_arg_node;
+ break;
+ default:
+ *elementTypeP = NULL;
+ *arrayTypeP = NULL;
+ break;
+ }
+} /* GetArrayFunctionType */
+
+BESymbolP
+BESpecialArrayFunctionSymbol (BEArrayFunKind arrayFunKind, int functionIndex, int moduleIndex)
+{
+ Bool isSpecialArrayFunction;
+ BEModuleP module;
+ SymbolP functionSymbol;
+ SymbDefP sdef;
+ 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;
+ isSpecialArrayFunction = False;
+ switch (arrayFunKind)
+ {
+ case BEArraySelectFun:
+ Assert (originalsdef->sdef_arfun == BEArraySelectFun || originalsdef->sdef_arfun == BEUnqArraySelectFun);
+ break;
+ 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;
+
+ isSpecialArrayFunction = True;
+ Assert (originalsdef->sdef_arfun == BEArraySelectFun);
+ break;
+ case BE_ArrayUpdateFun:
+ isSpecialArrayFunction = True;
+ 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;
+ /* fall through! */
+ case BEArrayUpdateFun:
+ Assert (originalsdef->sdef_arfun == BEArrayUpdateFun);
+ break;
+ default:
+ Assert (False);
+ break;
+ }
+
+ if (isSpecialArrayFunction)
+ {
+ SymbolP previousFunctionSymbol;
+ Bool allreadyCreated;
+
+ previousFunctionSymbol = functionSymbol;
+ functionSymbol = functionSymbol->symb_next;
+
+ allreadyCreated = False;
+ if (functionSymbol != NULL && functionSymbol->symb_kind == definition)
+ {
+ sdef = functionSymbol->symb_def;
+ allreadyCreated = sdef->sdef_arfun == (ArrayFunKind) arrayFunKind;
+ if (!allreadyCreated && arrayFunKind == BE_UnqArraySelectLastFun && sdef->sdef_arfun == BE_UnqArraySelectFun)
+ {
+ previousFunctionSymbol = functionSymbol;
+ functionSymbol = functionSymbol->symb_next;
+
+ if (functionSymbol != NULL && functionSymbol->symb_kind == definition)
+ {
+ sdef = functionSymbol->symb_def;
+ allreadyCreated = sdef->sdef_arfun == (ArrayFunKind) arrayFunKind;
+ }
+ }
+ }
+
+ if (!allreadyCreated)
+ {
+ 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);
+
+ newTypeAlt->type_alt_type_context = NULL; /* used in PrintType */
+ newTypeAlt->type_alt_attr_equations = NULL; /* used in PrintType */
+
+ 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 = BENormalTypeNode (gBasicSymbols [tuple_type],
+ BETypeArgs (elementType, BETypeArgs (arrayType, NULL)));
+ lhsArgs = BETypeArgs (arrayType, BETypeArgs (BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (gBasicSymbols [int_type], NULL)), NULL));
+ functionPrefix = "_uselectf";
+ break;
+ case BE_UnqArraySelectLastFun:
+ {
+ struct clean_string rName = {1, 'r'};
+ TypeNode rType;
+
+ rType = BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&rName));
+ rhs = BENormalTypeNode (gBasicSymbols [tuple_type],
+ BETypeArgs (elementType, BETypeArgs (rType, NULL)));
+ lhsArgs = BETypeArgs (
+ BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (gBasicSymbols [tuple_type],
+ BETypeArgs (arrayType, BETypeArgs (rType, NULL)))),
+ BETypeArgs (BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (gBasicSymbols [int_type], NULL)), NULL));
+ functionPrefix = "_uselectl";
+ break;
+ }
+ case BE_ArrayUpdateFun:
+ {
+ struct clean_string rName = {1, 'r'};
+ TypeNode rType;
+
+ rType = BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&rName));
+ rhs = rType;
+ lhsArgs = BETypeArgs (
+ BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (gBasicSymbols [tuple_type],
+ BETypeArgs (arrayType, BETypeArgs (rType, NULL)))),
+ BETypeArgs (BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (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 = BENormalTypeNode (newFunctionSymbol, lhsArgs);
+ newTypeAlt->type_alt_rhs = rhs;
+
+ 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->symb_def->sdef_module; /* phew! */
+ newsdef->sdef_over_arity = 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[kIclModuleIndex].bem_nFunctions - ArraySize (gLocallyGeneratedFunctions) + index;
+ functionSymbol = BEFunctionSymbol (functionIndex, kIclModuleIndex);
+ 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_type_context = NULL; /* used in PrintType */
+ typeAlt->type_alt_attr_equations = NULL; /* used in PrintType */
+ typeAlt->type_alt_lhs = BENormalTypeNode (functionSymbol, lhsArgs);
+ typeAlt->type_alt_rhs = rhsType;
+
+ BERule (functionIndex, BEIsNotACaf, typeAlt, ruleAlt);
+
+ return (functionSymbol);
+} /* CreateLocallyDefinedFunction */
+
+static BESymbolP
+CreateDictionarySelectFunSymbol (void)
+{
+ TypeNode rhsType;
+ TypeArgs lhsArgs;
+ struct clean_string aName = {1, 'a'};
+
+ /* 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 (
+ BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&aName)),
+ BETypeArgs (
+ BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (gBasicSymbols [tuple_type],
+ BETypeArgs (
+ BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&aName)),
+ BETypeArgs (
+ BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&aName)),
+ NULL)))),
+ BETypeArgs (
+ BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (gBasicSymbols [int_type], NULL)),
+ NULL)));
+ rhsType = BENormalTypeNode (gBasicSymbols [tuple_type],
+ BETypeArgs (BEVarTypeNode (&aName), BETypeArgs (BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&aName)), NULL)));
+
+ return (CreateLocallyDefinedFunction (kDictionarySelect, abcCode, lhsArgs, rhsType));
+} /* CreateDictionarySelectFunSymbol */
+
+static BESymbolP
+CreateDictionaryUpdateFunSymbol (void)
+{
+ TypeNode rhsType;
+ TypeArgs lhsArgs;
+ struct clean_string aName = {1, 'a'};
+
+ /* updatei :: !(*(a .e) -> *(!Int -> *(.e -> .(a .e)))) !(!*(a .e), !*r) !Int .e -> *r // !(!.(a .e), !*r) */
+ /* updatei _ _ _ _ = code */
+ static char *abcCode[] = {
+ " push_a 1",
+ " push_a 1",
+ " build _Nil 0 _hnf",
+ " update_a 0 4",
+ " pop_a 1",
+ ".d 2 0",
+ " jsr e_system_sAP",
+ ".o 1 0",
+ " buildI_b 0",
+ " push_a 1",
+ " update_a 1 2",
+ " update_a 0 1",
+ " pop_a 1",
+ " pop_b 1",
+ ".d 2 0",
+ " jsr e_system_sAP",
+ ".o 1 0",
+ " push_a 4",
+ " push_a 1",
+ " update_a 1 2",
+ " update_a 0 1",
+ " pop_a 1",
+ " build _Nil 0 _hnf",
+ " update_a 0 6",
+ " pop_a 1",
+ ".d 2 0",
+ " jsr e_system_sAP",
+ ".o 1 0",
+ " update_a 3 4",
+ " pop_a 4",
+ NULL
+ };
+
+ /* actual type simplified to !a !(!a,!a) !Int a -> a */
+ lhsArgs = BETypeArgs (
+ BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&aName)),
+ BETypeArgs (
+ BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (gBasicSymbols [tuple_type],
+ BETypeArgs (
+ BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&aName)),
+ BETypeArgs (
+ BEAnnotateTypeNode (StrictAnnot, BEVarTypeNode (&aName)),
+ NULL)))),
+ BETypeArgs (
+ BEAnnotateTypeNode (StrictAnnot, BENormalTypeNode (gBasicSymbols [int_type], NULL)),
+ BETypeArgs (
+ BEVarTypeNode (&aName),
+ NULL))));
+
+ rhsType = BEVarTypeNode (&aName);
+
+ 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 == kIclModuleIndex)
+ typeSymbol->symb_def->sdef_isused = True;
+
+ return (typeSymbol);
+} /* BETypeSymbol */
+
+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];
+
+ /* RWS +++ hack for record constructors, remove this */
+ if (constructorSymbol->symb_kind == erroneous_symb)
+ return (constructorSymbol);
+
+ Assert (constructorSymbol->symb_kind == definition
+ || (moduleIndex == kPredefinedModuleIndex && constructorSymbol->symb_kind != erroneous_symb));
+
+ if (moduleIndex != kPredefinedModuleIndex)
+ 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)
+{
+/* JVG: */
+ if (value)
+ return TrueSymbol;
+ else
+ return FalseSymbol;
+/*
+ SymbolP symbol;
+
+ symbol = ConvertAllocType (SymbolS);
+ symbol->symb_kind = bool_denot;
+ symbol->symb_bool = value;
+
+ return (symbol);
+*/
+} /* BEBoolSymbol */
+
+BESymbolP
+BELiteralSymbol (BESymbKind kind, CleanString value)
+{
+ SymbolP symbol;
+
+ symbol = ConvertAllocType (SymbolS);
+ symbol->symb_kind = kind;
+ symbol->symb_int = ConvertCleanString (value);
+
+ return (symbol);
+} /* BELiteralSymbol */
+
+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
+BEVarTypeNode (CleanString name)
+{
+ TypeNode node;
+
+ node = ConvertAllocType (struct type_node);
+
+ node->type_node_is_var = True;
+ node->type_node_tv = BETypeVar (name);
+ node->type_node_arity = 0;
+ node->type_node_annotation = NoAnnot;
+ node->type_node_attribute = NoUniAttr;
+
+ return (node);
+} /* BEVarTypeNode */
+
+BETypeNodeP
+BENormalTypeNode (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 = NoAnnot;
+ node->type_node_attribute = NoUniAttr;
+ node->type_node_symbol = symbol;
+ node->type_node_arguments = args;
+
+ return (node);
+} /* BENormalTypeNode */
+
+BETypeNodeP
+BEAttributeTypeNode (BEAttribution attribution, BETypeNodeP typeNode)
+{
+ Assert (typeNode->type_node_attribute == NoUniAttr);
+ typeNode->type_node_attribute = (AttributeKind) attribution;
+
+ return (typeNode);
+} /* BEAttributeTypeNode */
+
+BETypeNodeP
+BEAnnotateTypeNode (BEAnnotation annotation, BETypeNodeP typeNode)
+{
+ Assert (typeNode->type_node_annotation == NoAnnot);
+ typeNode->type_node_annotation = (Annotation) annotation;
+
+ return (typeNode);
+} /* BEAnnotateTypeNode */
+
+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_type_context = NULL; /* used in PrintType */
+ alt->type_alt_attr_equations = NULL; /* used in PrintType */
+
+ 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;
+
+ /* +++ 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);
+
+ 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);
+
+ 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;
+
+ 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_rules = NIL;
+ thenElseInfo->if_then_strict_node_ids = thenStricts;
+ thenElseInfo->if_else_node_defs = elseNodeDefs;
+ thenElseInfo->if_else_rules = NIL;
+ 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))));
+
+ return (node);
+} /* BEGuardNode */
+
+BENodeP
+BESelectorNode (BESelectorKind selectorKind, BESymbolP fieldSymbol, BEArgP args)
+{
+ NodeP node;
+
+ Assert (CountArgs (args) == 1);
+
+ node = ConvertAllocType (NodeS);
+
+ node->node_annotation = NoAnnot;
+ node->node_kind = SelectorNode;
+ node->node_symbol = fieldSymbol;
+ node->node_arity = selectorKind;
+ node->node_arguments = args;
+
+ return (node);
+} /* BESelectorNode */
+
+BENodeP
+BEUpdateNode (BEArgP args)
+{
+ NodeP node;
+ SymbolP recordSymbol;
+
+ Assert (CountArgs (args) == 2);
+ Assert (args->arg_next->arg_node->node_kind == SelectorNode);
+ Assert (args->arg_next->arg_node->node_arity == BESelector);
+
+ recordSymbol = args->arg_next->arg_node->node_symbol->symb_def->sdef_type->type_lhs->ft_symbol;
+
+ node = ConvertAllocType (NodeS);
+
+ node->node_annotation = NoAnnot;
+ node->node_kind = UpdateNode;
+ node->node_symbol = recordSymbol;
+ node->node_arity = 2;
+ node->node_arguments = args;
+
+ return (node);
+} /* BEUpdateNode */
+
+BENodeP
+BENodeIdNode (BENodeIdP nodeId, BEArgP args)
+{
+ NodeP node;
+
+ node = ConvertAllocType (NodeS);
+
+ node->node_annotation = NoAnnot;
+ node->node_kind = NodeIdNode;
+ node->node_node_id = nodeId;
+ node->node_arity = CountArgs (args);
+ node->node_arguments = args;
+
+ return (node);
+} /* BENodeIdNode */
+
+BEArgP
+BENoArgs (void)
+{
+ return (NULL);
+} /* BENoArgs */
+
+BEArgP
+BEArgs (BENodeP node, BEArgP nextArgs)
+{
+ ArgP arg;
+
+ arg = ConvertAllocType (ArgS);
+
+ arg->arg_node = node;
+ arg->arg_next = nextArgs;
+
+ return (arg);
+} /* BEArgs */
+
+
+# define nid_ref_count_sign nid_scope
+
+void
+BEDeclareNodeId (int sequenceNumber, int lhsOrRhs, CleanString name)
+{
+ IdentP newIdent;
+ NodeIdP newNodeId;
+
+ Assert (sequenceNumber < kMaxNumberOfNodeIds);
+
+ /* +++ ifdef DEBUG */
+ if (sequenceNumber>=number_of_node_ids){
+ int i;
+
+ for (i=number_of_node_ids; i<=sequenceNumber; ++i)
+ gCurrentNodeIds[i] = NULL;
+
+ number_of_node_ids=sequenceNumber+1;
+ }
+ /* endif DEBUG */
+
+ Assert (gCurrentNodeIds [sequenceNumber] == NULL);
+
+ /* +++ share idents ??? */
+ newIdent = ConvertAllocType (IdentS);
+ newIdent->ident_name = ConvertCleanString (name);
+
+ newNodeId = ConvertAllocType (NodeIdS);
+ newNodeId->nid_ident = newIdent;
+
+ newNodeId->nid_node_def = NULL;
+ newNodeId->nid_forward_node_id = NULL;
+ newNodeId->nid_node = NULL;
+ newNodeId->nid_state.state_kind = 0;
+ newNodeId->nid_mark = 0;
+ newNodeId->nid_mark2 = 0;
+ newNodeId->nid_ref_count_sign = lhsOrRhs==BELhsNodeId ? -1 : 1;
+ newNodeId->nid_refcount = 0;
+/* RWS test ... */
+ newNodeId->nid_ref_count_copy = 0;
+/* ... test */
+
+ gCurrentNodeIds [sequenceNumber] = newNodeId;
+} /* BEDeclareNodeId */
+
+BENodeIdP
+BENodeId (int sequenceNumber)
+{
+ NodeIdP nodeId;
+
+ Assert ((unsigned)sequenceNumber < (unsigned)kMaxNumberOfNodeIds);
+
+ /* +++ ifdef DEBUG */
+ if (sequenceNumber>=number_of_node_ids){
+ int i;
+
+ for (i=number_of_node_ids; i<=sequenceNumber; ++i)
+ gCurrentNodeIds[i] = NULL;
+
+ number_of_node_ids=sequenceNumber+1;
+ }
+ /* endif DEBUG */
+
+ nodeId = gCurrentNodeIds [sequenceNumber];
+
+ Assert (nodeId != NULL);
+
+ nodeId->nid_refcount += nodeId->nid_ref_count_sign;
+
+ return (nodeId);
+} /* BENodeId */
+
+BENodeIdP
+BEWildCardNodeId (void)
+{
+ NodeIdP newNodeId;
+
+ /* +++ share wild card nodeids ??? */
+
+ newNodeId = ConvertAllocType (NodeIdS);
+
+ newNodeId->nid_ident = NULL;
+ newNodeId->nid_node_def = NULL;
+ newNodeId->nid_forward_node_id = NULL;
+ newNodeId->nid_node = NULL;
+ newNodeId->nid_state.state_kind = 0;
+ newNodeId->nid_mark = 0;
+ newNodeId->nid_mark2 = 0;
+ newNodeId->nid_ref_count_sign = 0;
+ newNodeId->nid_refcount = -1;
+
+ return (newNodeId);
+} /* BEWildCardNodeId */
+
+BENodeDefP
+BENodeDef (int sequenceNumber, BENodeP node)
+{
+ NodeIdP nodeId;
+ NodeDefP nodeDef;
+
+ Assert ((unsigned)sequenceNumber < (unsigned)kMaxNumberOfNodeIds);
+
+ /* +++ ifdef DEBUG */
+ if (sequenceNumber>=number_of_node_ids){
+ int i;
+
+ for (i=number_of_node_ids; i<=sequenceNumber; ++i)
+ gCurrentNodeIds[i] = NULL;
+
+ number_of_node_ids=sequenceNumber+1;
+ }
+ /* endif DEBUG */
+
+ nodeDef = ConvertAllocType (NodeDefS);
+
+ nodeId = gCurrentNodeIds [sequenceNumber];
+
+ Assert (nodeId != NULL);
+ Assert (nodeId->nid_node == NULL);
+ nodeId->nid_node_def = nodeDef;
+ nodeId->nid_node = node;
+
+ nodeDef->def_id = nodeId;
+ nodeDef->def_node = node;
+ /* ifdef DEBUG */
+ nodeDef->def_next = NULL;
+ /* endif DEBUG */
+
+ return (nodeDef);
+} /* BENodeDef */
+
+BENodeDefP
+BENodeDefs (BENodeDefP nodeDef, BENodeDefP nodeDefs)
+{
+ Assert (nodeDef->def_next == NULL);
+
+ nodeDef->def_next = nodeDefs;
+
+ return (nodeDef);
+} /* BENodeDefs */
+
+BENodeDefP
+BENoNodeDefs (void)
+{
+ return (NULL);
+} /* BENoNodeDefs */
+
+BEStrictNodeIdP
+BEStrictNodeId (BENodeIdP nodeId)
+{
+ StrictNodeId strictNodeId;
+
+ strictNodeId = ConvertAllocType (struct strict_node_id);
+ strictNodeId->snid_mark = 0;
+ strictNodeId->snid_node_id = nodeId;
+
+ /* +++ remove this hack */
+ nodeId->nid_refcount--;
+
+ /* ifdef DEBUG */
+ strictNodeId->snid_next = NULL;
+ /* endif */
+
+ return (strictNodeId);
+} /* BEStrictNodeId */
+
+BEStrictNodeIdP
+BEStrictNodeIds (BEStrictNodeIdP strictNodeId, BEStrictNodeIdP strictNodeIds)
+{
+ Assert (strictNodeId->snid_next == NULL);
+
+ strictNodeId->snid_next = strictNodeIds;
+
+ return (strictNodeId);
+} /* BEStrictNodeIds */
+
+BEStrictNodeIdP
+BENoStrictNodeIds (void)
+{
+ return (NULL);
+} /* BENoStrictNodeIds */
+
+BERuleAltP
+BERuleAlt (int line, BENodeDefP lhsDefs, BENodeP lhs, BENodeDefP rhsDefs, BEStrictNodeIdP rhsStrictNodeIds, BENodeP rhs)
+{
+ RuleAltP alt;
+
+ alt = ConvertAllocType (RuleAltS);
+
+ alt->alt_lhs_root = lhs;
+ alt->alt_lhs_defs = lhsDefs;
+ alt->alt_rhs_root = rhs;
+ alt->alt_rhs_defs = rhsDefs;
+ alt->alt_line = line;
+ alt->alt_kind = Contractum;
+ alt->alt_strict_node_ids = rhsStrictNodeIds;
+
+ /* +++ ifdef DEBUG */
+ alt->alt_next = NULL;
+ number_of_node_ids=0;
+ /* endif DEBUG */
+
+ set_scope_numbers (alt);
+
+ return (alt);
+} /* BERuleAlt */
+
+BERuleAltP
+BECodeAlt (int line, BENodeDefP lhsDefs, BENodeP lhs, BECodeBlockP codeBlock)
+{
+ RuleAltP alt;
+
+ alt = ConvertAllocType (RuleAltS);
+
+ alt->alt_lhs_root = lhs;
+ alt->alt_lhs_defs = lhsDefs;
+ alt->alt_rhs_code = codeBlock;
+ alt->alt_rhs_defs = NULL;
+ alt->alt_line = line;
+ alt->alt_kind = ExternalCall;
+ alt->alt_strict_node_ids = NULL;
+
+ /* +++ ifdef DEBUG */
+ alt->alt_next = NULL;
+ number_of_node_ids=0;
+ /* endif DEBUG */
+
+# ifdef CODE_INLINE_FLAG
+ /* RWS +++ move to code generator ??? */
+ if (codeBlock->co_is_abc_code && codeBlock->co_is_inline)
+ {
+ char *functionName, *instructionLine;
+ Instructions instruction;
+
+ Assert (lhs->node_kind == NormalNode);
+ Assert (lhs->node_symbol->symb_kind == definition);
+ functionName = lhs->node_symbol->symb_def->sdef_ident->ident_name;
+
+ /* .inline <name> */
+ instructionLine = ConvertAlloc (sizeof (".inline ") + strlen (functionName));
+ strcpy (instructionLine, ".inline ");
+ strcat (instructionLine, functionName);
+
+ instruction = ConvertAllocType (Instruction);
+ instruction->instr_this = instructionLine;
+ instruction->instr_next = codeBlock->co_instr;
+ codeBlock->co_instr = instruction;
+
+ for (; instruction->instr_next != NULL; instruction = instruction->instr_next)
+ /* find last element */;
+ instruction = instruction->instr_next = ConvertAllocType (Instruction);
+
+ instruction->instr_this = ".end";
+ instruction->instr_next = NULL;
+ }
+# endif
+
+ return (alt);
+} /* BECodeAlt */
+
+BERuleAltP
+BERuleAlts (BERuleAltP alt, BERuleAltP alts)
+{
+ Assert (alt->alt_next == NULL);
+
+ alt->alt_next = alts;
+
+ return (alt);
+} /* BERuleAlts*/
+
+BERuleAltP
+BENoRuleAlts (void)
+{
+ return (NULL);
+} /* BENoRuleAlts */
+
+static void
+DeclareFunctionC (char *name, int arity, int functionIndex, unsigned int ancestor)
+{
+ SymbDefP newSymbDef;
+ Ident newIdent;
+ SymbolP functions;
+ BEIcl icl;
+ BEModule module;
+
+ icl = &gBEState.be_icl;
+
+ module = &gBEState.be_modules [kIclModuleIndex];
+ functions = module->bem_functions;
+ Assert (functions != NULL);
+
+ Assert (icl->beicl_previousAncestor >= ancestor);
+ icl->beicl_previousAncestor = ancestor;
+
+ Assert (functionIndex < module->bem_nFunctions);
+ newSymbDef = ConvertAllocType (SymbDefS);
+
+ newSymbDef->sdef_kind = IMPRULE;
+ newSymbDef->sdef_mark = 0;
+ newSymbDef->sdef_over_arity = 0;
+ newSymbDef->sdef_arity = arity;
+ newSymbDef->sdef_module = module->bem_name;
+ newSymbDef->sdef_ancestor = ancestor;
+ newSymbDef->sdef_arfun = NoArrayFun;
+ newSymbDef->sdef_next_scc = NULL;
+ newSymbDef->sdef_exported = False;
+ newSymbDef->sdef_dcl_icl = NULL;
+ newSymbDef->sdef_isused = 0;
+ newSymbDef->sdef_no_sa = False;
+
+ newSymbDef->sdef_nr_of_lifted_nodeids = 0; /* used in PrintType */
+ newSymbDef->sdef_line = 0; /* used in PrintType */
+
+ *icl->beicl_depsP = newSymbDef;
+ icl->beicl_depsP = &newSymbDef->sdef_next_scc;
+ newSymbDef->sdef_arfun = NoArrayFun;
+
+ newIdent = ConvertAllocType (IdentS);
+
+ newIdent->ident_name = name;
+ newIdent->ident_symbol = &functions [functionIndex];
+
+ newSymbDef->sdef_ident = newIdent;
+
+ Assert (functions [functionIndex].symb_kind == erroneous_symb);
+ functions [functionIndex].symb_kind = definition;
+ functions [functionIndex].symb_def = newSymbDef;
+
+
+ /* +++ ugly */
+ if (strcmp (newIdent->ident_name, "Start") == 0)
+ {
+ Assert (icl->beicl_module->im_start == NULL);
+ icl->beicl_module->im_start = newSymbDef;
+ }
+} /* DeclareFunctionC */
+
+void
+BEDeclareFunction (CleanString name, int arity, int functionIndex, int ancestor)
+{
+ /* +++ ugly */
+ if (strncmp (name->chars, "Start;", 6) == 0)
+ name->length = 5;
+
+ DeclareFunctionC (ConvertCleanString (name), arity, functionIndex, ancestor);
+} /* BEDeclareFunction */
+
+BEImpRuleP
+BERules (BEImpRuleP rule, BEImpRuleP rules)
+{
+ Assert (rule->rule_next == NULL);
+
+ rule->rule_next = rules;
+
+ return (rule);
+} /* BERules */
+
+BEImpRuleP
+BENoRules (void)
+{
+ return (NULL);
+} /* BENoRules */
+
+BEImpRuleP
+BERule (int functionIndex, int isCaf, BETypeAltP type, BERuleAltP alts)
+{
+ SymbDefP functionDef;
+ SymbolP functionSymbol;
+ ImpRuleP rule;
+ BEModule module;
+
+ rule = ConvertAllocType (ImpRuleS);
+
+ module = &gBEState.be_modules [kIclModuleIndex];
+ functionSymbol = &module->bem_functions [functionIndex];
+ functionDef = functionSymbol->symb_def;
+ functionDef->sdef_rule = rule;
+
+ rule->rule_type = type;
+ rule->rule_alts = alts;
+ rule->rule_mark = isCaf ? RULE_CAF_MASK : 0;
+
+ rule->rule_root = alts->alt_lhs_root;
+
+ /* ifdef DEBUG */
+ rule->rule_next = NULL;
+ /* endif DEBUG */
+
+ return (rule);
+} /* BERule */
+
+void
+BEDeclareRuleType (int functionIndex, int moduleIndex, CleanString name)
+{
+ IdentP newIdent;
+ SymbDefP newSymbDef;
+ SymbolP functions;
+ BEModuleP module;
+
+ module = &gBEState.be_modules [moduleIndex];
+
+ Assert ((unsigned int) functionIndex < module->bem_nFunctions);
+
+ functions = module->bem_functions;
+
+ Assert (functions != NULL);
+ Assert (functions [functionIndex].symb_kind == erroneous_symb);
+
+ if (module->bem_isSystemModule)
+ /* for inline code */
+ newIdent = PutStringInHashTable (ConvertCleanString (name), SymbolIdTable);
+ else
+ {
+ newIdent = ConvertAllocType (IdentS);
+ newIdent->ident_name = ConvertCleanString (name);
+ }
+
+ newIdent->ident_symbol = &functions [functionIndex];
+
+ newSymbDef = ConvertAllocType (SymbDefS);
+ newSymbDef->sdef_kind = NEWDEFINITION;
+ newSymbDef->sdef_exported = False;
+ newSymbDef->sdef_module = module->bem_name;
+ newSymbDef->sdef_ident = newIdent;
+ newSymbDef->sdef_isused = 0;
+ newSymbDef->sdef_line = 0; /* used in PrintSymbolOfIdent */
+
+ functions [functionIndex].symb_kind = definition;
+ functions [functionIndex].symb_def = newSymbDef;
+
+} /* BEDeclareRuleType */
+
+void
+BEDefineRuleType (int functionIndex, int moduleIndex, BETypeAltP typeAlt)
+{
+ SymbolP functionSymbol;
+ SymbDef sdef;
+ RuleTypes ruleType;
+ BEModule module;
+
+ ruleType = ConvertAllocType (struct rule_type);
+ ruleType->rule_type_rule = typeAlt;
+
+ module = &gBEState.be_modules [moduleIndex];
+ functionSymbol = &module->bem_functions [functionIndex];
+
+ sdef = functionSymbol->symb_def;
+ Assert (sdef->sdef_kind == NEWDEFINITION);
+ sdef->sdef_over_arity = 0;
+ sdef->sdef_arity = typeAlt->type_alt_lhs->type_node_arity;
+ sdef->sdef_arfun = NoArrayFun;
+ sdef->sdef_kind = module->bem_isSystemModule ? SYSRULE : DEFRULE;
+ sdef->sdef_rule_type = ruleType;
+} /* BEDefineRuleType */
+
+void
+BEAdjustArrayFunction (BEArrayFunKind arrayFunKind, int functionIndex, int moduleIndex)
+{
+ SymbolP functionSymbol;
+ SymbDef sdef;
+ BEModule module;
+
+ module = &gBEState.be_modules [moduleIndex];
+ functionSymbol = &module->bem_functions [functionIndex];
+
+ sdef = functionSymbol->symb_def;
+
+ Assert (sdef->sdef_kind == DEFRULE || (moduleIndex == kIclModuleIndex && sdef->sdef_kind == IMPRULE));
+ sdef->sdef_arfun = arrayFunKind;
+ sdef->sdef_mark = 0;
+
+ if (sdef->sdef_kind == DEFRULE && moduleIndex == kIclModuleIndex)
+ {
+ AddUserDefinedArrayFunction (functionSymbol);
+ sdef->sdef_kind = SYSRULE;
+ }
+} /* BEAdjustArrayFunction */
+
+BETypeP
+BETypes (BETypeP type, BETypeP types)
+{
+ Assert (type->type_next == NULL);
+
+ type->type_next = types;
+
+ return (type);
+} /* BETypes */
+
+BETypeP
+BENoTypes (void)
+{
+ return (NULL);
+} /* BENoTypes */
+
+void
+BEDeclareType (int typeIndex, int moduleIndex, CleanString name)
+{
+ SymbDefP newSymbDef;
+ Ident newIdent;
+ SymbolP *types;
+ BEModuleP module;
+ module = &gBEState.be_modules [moduleIndex];
+
+ Assert ((unsigned int) typeIndex < module->bem_nTypes);
+ Assert (module->bem_types [typeIndex]->symb_kind == erroneous_symb);
+
+ types = module->bem_types;
+ Assert (types != NULL);
+
+ newIdent = ConvertAllocType (IdentS);
+ newIdent->ident_name = ConvertCleanString (name);
+ newIdent->ident_symbol = types [typeIndex];
+/* RWS change this
+ newSymbDef = ConvertAllocType (SymbDefS);
+*/
+ newSymbDef = types [typeIndex]->symb_def;
+ Assert (newSymbDef != NULL);
+
+ newSymbDef->sdef_kind = NEWDEFINITION;
+ newSymbDef->sdef_exported = False;
+ newSymbDef->sdef_dcl_icl = NULL;
+ newSymbDef->sdef_isused = 0;
+
+ newSymbDef->sdef_module = module->bem_name;
+ newSymbDef->sdef_ident = newIdent;
+
+ types [typeIndex]->symb_kind = definition;
+ types [typeIndex]->symb_def = newSymbDef;
+} /* BEDeclareType */
+
+BETypeVarP
+BETypeVar (CleanString name)
+{
+ IdentP ident;
+ TypeVar typeVar;
+
+ ident = ConvertAllocType (IdentS);
+ typeVar = ConvertAllocType (struct type_var);
+
+ ident->ident_name = ConvertCleanString (name);
+ ident->ident_tv = typeVar;
+
+ typeVar->tv_ident = ident;
+ typeVar->tv_argument_nr = 0; /* ??? */
+
+ return (typeVar);
+} /* BETypeVar */
+
+BETypeVarListP
+BETypeVars (BETypeVarP typeVar, BETypeVarListP typeVarList)
+{
+ TypeVarList typeVarListElement;
+
+ typeVarListElement = ConvertAllocType (struct type_var_list);
+ typeVarListElement->tvl_elem = typeVar;
+ typeVarListElement->tvl_next = typeVarList;
+
+ return (typeVarListElement);
+} /* BETypeVars */
+
+BETypeVarListP
+BENoTypeVars (void)
+{
+ return (NULL);
+} /* BENoTypeVars */
+
+BEFlatTypeP
+BEFlatType (BESymbolP symbol, BETypeVarListP arguments)
+{
+ FlatType flatType;
+ int i;
+
+ flatType = ConvertAllocType (struct flat_type);
+
+ flatType->ft_symbol = symbol;
+ flatType->ft_arguments = arguments;
+ i = 0;
+ for (; arguments != NULL; arguments=arguments->tvl_next)
+ i++;
+ flatType->ft_arity = i;
+
+ flatType->ft_cons_vars = NULL; /* used in PrintType */
+
+ return (flatType);
+} /* BEFlatType */
+
+void
+BEAlgebraicType (BEFlatTypeP lhs, BEConstructorListP constructors)
+{
+ Types type;
+ SymbDefP sdef;
+ int nConstructors;
+
+ type = ConvertAllocType (struct type);
+ /* ifdef DEBUG */
+ type->type_next = NULL;
+ /* endif */
+
+ type->type_lhs = lhs;
+ type->type_line = 0; /* ??? */
+ type->type_constructors = constructors;
+
+ nConstructors = 0;
+ for (; constructors != NULL; constructors = constructors->cl_next)
+ {
+ SymbDef cdef;
+
+ Assert (!constructors->cl_constructor->type_node_is_var);
+ Assert (constructors->cl_constructor->type_node_symbol->symb_kind == definition);
+
+ cdef = constructors->cl_constructor->type_node_symbol->symb_def;
+ Assert (cdef->sdef_type == NULL);
+ cdef->sdef_type = type;
+
+ nConstructors++;
+ }
+
+ type->type_nr_of_constructors = nConstructors;
+
+ Assert (type->type_lhs->ft_symbol->symb_kind == definition);
+ sdef = type->type_lhs->ft_symbol->symb_def;
+ Assert (sdef->sdef_kind == NEWDEFINITION);
+ sdef->sdef_over_arity = 0;
+ sdef->sdef_kind = TYPE;
+ sdef->sdef_type = type;
+} /* BEAlgebraicType */
+
+void
+BERecordType (int moduleIndex, BEFlatTypeP lhs, BETypeNodeP constructorType, BEFieldListP fields)
+{
+ int nFields;
+ Types type;
+ SymbDefP sdef;
+ BEConstructorListP constructor;
+
+ type = ConvertAllocType (struct type);
+ /* ifdef DEBUG */
+ type->type_next = NULL;
+ /* endif */
+
+ constructor = ConvertAllocType (struct constructor_list);
+
+ constructor->cl_next = NULL;
+ constructor->cl_constructor = constructorType;
+
+ type->type_lhs = lhs;
+ type->type_line = 0; /* ??? */
+ type->type_constructors = constructor;
+ type->type_fields = fields;
+
+ nFields = 0;
+ for (; fields != NULL; fields = fields->fl_next)
+ {
+ SymbDef fdef;
+
+ Assert (fields->fl_symbol->symb_kind == definition);
+
+ fdef = fields->fl_symbol->symb_def;
+ Assert (fdef->sdef_type == NULL);
+ fdef->sdef_type = type;
+ fdef->sdef_sel_field_number = nFields++;
+ }
+
+ type->type_nr_of_constructors = 0;
+
+ Assert (type->type_lhs->ft_symbol->symb_kind == definition);
+ sdef = type->type_lhs->ft_symbol->symb_def;
+ Assert (sdef->sdef_kind == NEWDEFINITION);
+ sdef->sdef_over_arity = 0;
+ sdef->sdef_cons_arity = constructorType->type_node_arity;
+ sdef->sdef_checkstatus = TypeChecked;
+ sdef->sdef_kind = RECORDTYPE;
+ sdef->sdef_type = type;
+ sdef->sdef_arity = constructorType->type_node_arity;
+
+ // +++ change this
+ {
+ int i;
+ BEModuleP module;
+
+ module = &gBEState.be_modules [moduleIndex];
+
+ for (i = 0; i < module->bem_nConstructors; i++)
+ if (module->bem_constructors [i] == constructorType->type_node_symbol)
+ break;
+
+ Assert (i < module->bem_nConstructors);
+ module->bem_constructors [i] = type->type_lhs->ft_symbol;
+ }
+} /* BERecordType */
+
+void
+BEAbsType (BEFlatTypeP lhs)
+{
+ AbsTypes absType;
+ SymbDefP sdef;
+
+ absType = ConvertAllocType (struct abs_type);
+ /* ifdef DEBUG */
+ absType->abs_next = NULL;
+ /* endif */
+
+ absType->abs_graph = lhs;
+ absType->abs_line = 0; /* ??? */
+
+ Assert (lhs->ft_symbol->symb_kind == definition);
+ sdef = lhs->ft_symbol->symb_def;
+ Assert (sdef->sdef_kind == NEWDEFINITION);
+ sdef->sdef_over_arity = 0;
+ sdef->sdef_checkstatus = TypeChecked;
+ sdef->sdef_kind = ABSTYPE;
+ sdef->sdef_abs_type = absType;
+
+} /* BEAbsType */
+
+BEConstructorListP
+BEConstructors (BEConstructorListP constructor, BEConstructorListP constructors)
+{
+ Assert (constructor->cl_next == NULL);
+
+ constructor->cl_next = constructors;
+
+ return (constructor);
+} /* BEConstructors */
+
+BEConstructorListP
+BENoConstructors (void)
+{
+ return (NULL);
+} /* BENoConstructors */
+
+BEConstructorListP
+BEConstructor (BETypeNodeP type)
+{
+ ConstructorList constructor;
+ SymbDef sdef;
+
+ Assert (!type->type_node_is_var);
+ Assert (type->type_node_symbol->symb_kind == definition);
+
+ sdef = type->type_node_symbol->symb_def;
+
+ constructor = ConvertAllocType (struct constructor_list);
+
+ /* ifdef DEBUG */
+ constructor->cl_next = NULL;
+ /* endif */
+ constructor->cl_constructor = type;
+
+ sdef->sdef_kind = CONSTRUCTOR;
+ sdef->sdef_constructor = constructor;
+ sdef->sdef_arity = type->type_node_arity;
+ sdef->sdef_over_arity = 0;
+ /* ifdef DEBUG */
+ sdef->sdef_type = NULL;
+ /* endif */
+
+ return (constructor);
+} /* BEConstructor */
+
+void
+BEDeclareField (int fieldIndex, int moduleIndex, CleanString name)
+{
+ SymbDefP newSymbDef;
+ Ident newIdent;
+ SymbolP fields;
+ BEModuleP module;
+
+ module = &gBEState.be_modules [moduleIndex];
+ Assert ((unsigned) fieldIndex < module->bem_nFields);
+ Assert (module->bem_fields [fieldIndex].symb_kind == erroneous_symb);
+
+ fields = module->bem_fields;
+ Assert (fields != NULL);
+
+ newIdent = ConvertAllocType (IdentS);
+ newIdent->ident_name = ConvertCleanString (name);
+ newIdent->ident_symbol = &fields [fieldIndex];
+
+ newSymbDef = ConvertAllocType (SymbDefS);
+ newSymbDef->sdef_kind = NEWDEFINITION;
+ newSymbDef->sdef_exported = False;
+ newSymbDef->sdef_module = module->bem_name;
+ newSymbDef->sdef_ident = newIdent;
+ newSymbDef->sdef_isused = 0;
+
+ fields [fieldIndex].symb_kind = definition;
+ fields [fieldIndex].symb_def = newSymbDef;
+} /* BEDeclareField */
+
+BEFieldListP
+BEField (int fieldIndex, int moduleIndex, BETypeNodeP type)
+{
+ SymbDef sdef;
+ SymbolP fields;
+ BEModuleP module;
+ FieldList field;
+
+ module = &gBEState.be_modules [moduleIndex];
+ Assert ((unsigned) fieldIndex < module->bem_nFields);
+ Assert (module->bem_fields [fieldIndex].symb_kind == definition);
+
+ fields = module->bem_fields;
+ Assert (fields != NULL);
+
+ field = ConvertAllocType (struct field_list);
+
+ /* ifdef DEBUG */
+ field->fl_next = NULL;
+ /* endif */
+ field->fl_symbol = &fields [fieldIndex];
+ field->fl_type = type;
+
+ sdef = fields [fieldIndex].symb_def;
+
+ sdef->sdef_kind = FIELDSELECTOR;
+ sdef->sdef_sel_field = field;
+ sdef->sdef_arity = 1;
+ sdef->sdef_over_arity = 0;
+ sdef->sdef_mark = 0;
+ /* ifdef DEBUG */
+ sdef->sdef_type = NULL;
+ /* endif */
+
+ return (field);
+} /* BEField */
+
+BEFieldListP
+BEFields (BEFieldListP field, BEFieldListP fields)
+{
+ Assert (field->fl_next == NULL);
+
+ field->fl_next = fields;
+
+ return (field);
+} /* BEFields */
+
+BEFieldListP
+BENoFields (void)
+{
+ return (NULL);
+} /* BENoFields */
+
+void
+BEDeclareConstructor (int constructorIndex, int moduleIndex, CleanString name)
+{
+ SymbDefP newSymbDef;
+ Ident newIdent;
+ SymbolP *constructors;
+ BEModuleP module;
+
+ module = &gBEState.be_modules [moduleIndex];
+ Assert ((unsigned) constructorIndex < module->bem_nConstructors);
+ Assert (module->bem_constructors [constructorIndex]->symb_kind == erroneous_symb);
+
+ constructors = module->bem_constructors;
+ Assert (constructors != NULL);
+
+ newIdent = ConvertAllocType (IdentS);
+ newIdent->ident_name = ConvertCleanString (name);
+ newIdent->ident_symbol = constructors [constructorIndex];
+
+ newSymbDef = ConvertAllocType (SymbDefS);
+ newSymbDef->sdef_kind = NEWDEFINITION;
+ newSymbDef->sdef_exported = False;
+ newSymbDef->sdef_module = module->bem_name;
+ newSymbDef->sdef_ident = newIdent;
+ newSymbDef->sdef_isused = 0;
+ newSymbDef->sdef_no_sa = False;
+
+ constructors [constructorIndex]->symb_kind = definition;
+ constructors [constructorIndex]->symb_def = newSymbDef;
+} /* BEDeclareConstructor */
+
+void
+BEDefineRules (BEImpRuleP rules)
+{
+ gBEState.be_icl.beicl_module->im_rules = rules;
+} /* BEDefineRules */
+
+void
+BEDefineImportedObjsAndLibs (BEStringListP objs, BEStringListP libs)
+{
+ gBEState.be_icl.beicl_module->im_imported_objs = objs;
+ gBEState.be_icl.beicl_module->im_imported_libs = libs;
+} /* BEDefineRules */
+
+BEStringListP
+BEString (CleanString cleanString)
+{
+ struct string_list *string;
+
+ string = ConvertAllocType (struct string_list);
+
+ string->sl_string = ConvertCleanString (cleanString);
+ /* ifdef DEBUG */
+ string->sl_next = NULL;
+ /* endif */
+
+ return (string);
+} /* BEString */
+
+BEStringListP
+BEStrings (BEStringListP string, BEStringListP strings)
+{
+ Assert (string->sl_next == NULL);
+
+ string->sl_next = strings;
+
+ return (string);
+} /* BEStringList*/
+
+BEStringListP
+BENoStrings (void)
+{
+ return (NULL);
+} /* BENoStrings */
+
+BECodeBlockP
+BEAbcCodeBlock (int inlineFlag, BEStringListP instructions)
+{
+ CodeBlock codeBlock;
+
+ codeBlock = ConvertAllocType (CodeBlockS);
+
+ codeBlock->co_instr = (Instructions) instructions;
+ codeBlock->co_is_abc_code = True;
+ codeBlock->co_is_inline = inlineFlag;
+
+ return (codeBlock);
+} /* BEAbcCodeBlock */
+
+BECodeBlockP
+BEAnyCodeBlock (BECodeParameterP inParams, BECodeParameterP outParams, BEStringListP instructions)
+{
+ CodeBlock codeBlock;
+
+ codeBlock = ConvertAllocType (CodeBlockS);
+
+ codeBlock->co_instr = (Instructions) instructions;
+ codeBlock->co_is_abc_code = False;
+ codeBlock->co_parin = inParams;
+ codeBlock->co_parout = outParams;
+
+ return (codeBlock);
+} /* BEAnyCodeBlock */
+
+BECodeParameterP
+BECodeParameter (CleanString location, BENodeIdP nodeId)
+{
+ Parameters parameter;
+
+ parameter = ConvertAllocType (struct parameter);
+
+ parameter->par_kind = 0;
+ parameter->par_node_id = nodeId;
+ parameter->par_loc = Identifier (ConvertCleanString (location));
+
+ /* ifdef DEBUG */
+ parameter->par_next = NULL;
+ /* endif */
+
+ return (parameter);
+} /* BECodeParameter */
+
+BECodeParameterP
+BECodeParameters (BECodeParameterP parameter, BECodeParameterP parameters)
+{
+ Assert (parameter->par_next == NULL);
+
+ parameter->par_next = parameters;
+
+ return (parameter);
+} /* BECodeParameters */
+
+BECodeParameterP
+BENoCodeParameters (void)
+{
+ return (NULL);
+} /* BENoCodeParameters */
+
+static void
+RemoveSpecialArrayFunctionsFromSymbolList (SymbolP *symbolH)
+{
+ SymbolP symbolP;
+
+ while ((symbolP = *symbolH) != NULL)
+ {
+ SymbDefP sdef;
+
+ sdef = symbolP->symb_def;
+
+ if (symbolP->symb_kind == definition && sdef->sdef_kind == IMPRULE && sdef->sdef_arfun != NoArrayFun)
+ *symbolH = symbolP->symb_next;
+ else
+ symbolH = &symbolP->symb_next;
+ }
+} /* RemoveSpecialArrayFunctionsFromSymbolList */
+
+int
+BEGenerateCode (CleanString outputFile)
+{
+ char *outputFileName;
+ ImpRule rule;
+
+ if (CompilerError)
+ return False;
+
+ // RemoveSpecialArrayFunctionsFromSymbolList (&gBEState.be_icl.beicl_module->im_symbols);
+
+ /* +++ hack */
+ rule = gBEState.be_dictionarySelectFunSymbol->symb_def->sdef_rule;
+ rule->rule_next = gBEState.be_icl.beicl_module->im_rules;
+ gBEState.be_icl.beicl_module->im_rules = rule;
+
+ rule = gBEState.be_dictionaryUpdateFunSymbol->symb_def->sdef_rule;
+ rule->rule_next = gBEState.be_icl.beicl_module->im_rules;
+ gBEState.be_icl.beicl_module->im_rules = rule;
+
+ outputFileName = ConvertCleanString (outputFile);
+ CodeGeneration (gBEState.be_icl.beicl_module, outputFileName);
+
+ return (!CompilerError);
+} /* BEGenerateCode */
+
+void
+BEExportType (int dclTypeIndex, int iclTypeIndex)
+{
+ BEModuleP dclModule, iclModule;
+ SymbolP typeSymbol;
+ SymbDefP iclDef, dclDef;
+
+ iclModule = &gBEState.be_modules [kIclModuleIndex];
+
+ Assert ((unsigned int) iclTypeIndex < iclModule->bem_nTypes);
+ typeSymbol = iclModule->bem_types [iclTypeIndex];
+ Assert (typeSymbol->symb_kind == definition);
+
+ iclDef = typeSymbol->symb_def;
+ iclDef->sdef_exported = True;
+
+ dclModule = &gBEState.be_icl.beicl_dcl_module;
+
+ /* +++ remove -1 hack */
+ if (dclTypeIndex == -1)
+ dclDef = iclDef;
+ else
+ {
+ Assert ((unsigned int) dclTypeIndex < dclModule->bem_nTypes);
+ typeSymbol = dclModule->bem_types [dclTypeIndex];
+ Assert (typeSymbol->symb_kind == definition);
+ dclDef = typeSymbol->symb_def;
+ }
+ Assert (strcmp (iclDef->sdef_ident->ident_name, dclDef->sdef_ident->ident_name) == 0);
+
+ iclDef->sdef_dcl_icl = dclDef;
+ dclDef->sdef_dcl_icl = iclDef;
+} /* BEExportType */
+
+void
+BESwapTypes (int frm, int to)
+{
+ BEModuleP module;
+ SymbolP save;
+
+ module = &gBEState.be_modules [kIclModuleIndex];
+
+ Assert ((unsigned int) frm < module->bem_nTypes);
+ Assert ((unsigned int) to < module->bem_nTypes);
+
+ save = module->bem_types [frm];
+ module->bem_types [frm] = module->bem_types [to];
+ module->bem_types [to] = save;
+} /* BESwapTypes */
+
+void
+BEExportConstructor (int dclConstructorIndex, int iclConstructorIndex)
+{
+ BEModuleP dclModule, iclModule;
+ SymbolP constructorSymbol;
+ SymbDefP iclDef, dclDef;
+
+ iclModule = &gBEState.be_modules [kIclModuleIndex];
+
+ Assert ((unsigned int) iclConstructorIndex < iclModule->bem_nConstructors);
+ constructorSymbol = iclModule->bem_constructors [iclConstructorIndex];
+ Assert (constructorSymbol->symb_kind == definition);
+
+ iclDef = constructorSymbol->symb_def;
+ iclDef->sdef_exported = True;
+
+ if (0)
+ {
+ dclModule = &gBEState.be_icl.beicl_dcl_module;
+
+ Assert ((unsigned int) dclConstructorIndex < dclModule->bem_nConstructors);
+ constructorSymbol = dclModule->bem_constructors [dclConstructorIndex];
+ Assert (constructorSymbol->symb_kind == definition);
+ dclDef = constructorSymbol->symb_def;
+
+ Assert (strcmp (iclDef->sdef_ident->ident_name, dclDef->sdef_ident->ident_name) == 0);
+ }
+ else
+ dclDef = iclDef;
+
+ iclDef->sdef_dcl_icl = dclDef;
+ dclDef->sdef_dcl_icl = iclDef;
+} /* BEExportConstructor */
+
+void
+BEExportField (int dclFieldIndex, int iclFieldIndex)
+{
+ BEModuleP dclModule, iclModule;
+ SymbolP fieldSymbol;
+ SymbDefP iclDef, dclDef;
+
+ iclModule = &gBEState.be_modules [kIclModuleIndex];
+
+ Assert ((unsigned int) iclFieldIndex < iclModule->bem_nFields);
+ fieldSymbol = &iclModule->bem_fields [iclFieldIndex];
+ Assert (fieldSymbol->symb_kind == definition);
+
+ iclDef = fieldSymbol->symb_def;
+ iclDef->sdef_exported = True;
+
+ /* +++ remove -1 hack */
+ if (dclFieldIndex == -1)
+ dclDef = iclDef;
+ else
+ {
+ dclModule = &gBEState.be_icl.beicl_dcl_module;
+
+ Assert ((unsigned int) dclFieldIndex < dclModule->bem_nFields);
+ fieldSymbol = &dclModule->bem_fields [dclFieldIndex];
+ Assert (fieldSymbol->symb_kind == definition);
+ dclDef = fieldSymbol->symb_def;
+ }
+
+ Assert (strcmp (iclDef->sdef_ident->ident_name, dclDef->sdef_ident->ident_name) == 0);
+
+ iclDef->sdef_dcl_icl = dclDef;
+ dclDef->sdef_dcl_icl = iclDef;
+} /* BEExportField */
+
+void
+BEExportFunction (int dclFunctionIndex, int iclFunctionIndex)
+{
+ BEModuleP dclModule, iclModule;
+ SymbolP functionSymbol;
+ SymbDefP iclDef, dclDef;
+
+ iclModule = &gBEState.be_modules [kIclModuleIndex];
+
+ Assert ((unsigned int) iclFunctionIndex < iclModule->bem_nFunctions);
+ functionSymbol = &iclModule->bem_functions [iclFunctionIndex];
+ Assert (functionSymbol->symb_kind == definition);
+
+ iclDef = functionSymbol->symb_def;
+ iclDef->sdef_exported = True;
+
+ dclModule = &gBEState.be_icl.beicl_dcl_module;
+
+ Assert ((unsigned int) dclFunctionIndex < dclModule->bem_nFunctions);
+ functionSymbol = &dclModule->bem_functions [dclFunctionIndex];
+ Assert (functionSymbol->symb_kind == definition);
+ dclDef = functionSymbol->symb_def;
+
+ Assert (strcmp (iclDef->sdef_ident->ident_name, dclDef->sdef_ident->ident_name) == 0);
+
+ iclDef->sdef_dcl_icl = dclDef;
+ dclDef->sdef_dcl_icl = iclDef;
+} /* BEExportFunction */
+
+static void
+CheckBEEnumTypes (void)
+{
+ /* Annotation */
+ Assert (NoAnnot == BENoAnnot);
+ Assert (StrictAnnot == BEStrictAnnot);
+
+ /* Annotation */
+ Assert (NoUniAttr == BENoUniAttr);
+ Assert (NotUniqueAttr == BENotUniqueAttr);
+ Assert (UniqueAttr == BEUniqueAttr);
+ Assert (ExistsAttr == BEExistsAttr);
+ Assert (UniqueVariable == BEUniqueVariable);
+ Assert (FirstUniVarNumber == BEFirstUniVarNumber);
+
+ /* SymbKind */
+ Assert (int_type == BEIntType);
+ Assert (bool_type == BEBoolType);
+ Assert (char_type == BECharType);
+ Assert (real_type == BERealType);
+ Assert (file_type == BEFileType);
+ Assert (string_type == BEStringType);
+ Assert (world_type == BEWorldType);
+ Assert (procid_type == BEProcIdType);
+ Assert (redid_type == BERedIdType);
+ Assert (Nr_Of_Basic_Types == BENrOfBasicTypes);
+ Assert (int_denot == BEIntDenot);
+ Assert (bool_denot == BEBoolDenot);
+ Assert (char_denot == BECharDenot);
+ Assert (real_denot == BERealDenot);
+ Assert (Nr_Of_Basic_Denots == BENrOfBasicDenots);
+ Assert (string_denot == BEStringDenot);
+ Assert (fun_type == BEFunType);
+ Assert (array_type == BEArrayType);
+ Assert (strict_array_type == BEStrictArrayType);
+ Assert (unboxed_array_type == BEUnboxedArrayType);
+ Assert (list_type == BEListType);
+ Assert (tuple_type == BETupleType);
+ Assert (empty_type == BEEmptyType);
+#if DYNAMIC_TYPE
+ Assert (dynamic_type == BEDynamicType);
+#endif
+ Assert (Nr_Of_Predef_Types == BENrOfPredefTypes);
+ Assert (tuple_symb == BETupleSymb);
+ Assert (cons_symb == BEConsSymb);
+ Assert (nil_symb == BENilSymb);
+ Assert (apply_symb == BEApplySymb);
+ Assert (if_symb == BEIfSymb);
+ Assert (fail_symb == BEFailSymb);
+ Assert (all_symb == BEAllSymb);
+ Assert (select_symb == BESelectSymb);
+ Assert (Nr_Of_Predef_FunsOrConses == BENrOfPredefFunsOrConses);
+ Assert (definition == BEDefinition);
+ Assert (newsymbol == BENewSymbol);
+ Assert (instance_symb == BEInstanceSymb);
+ Assert (empty_symbol == BEEmptySymbol);
+ Assert (field_symbol_list == BEFieldSymbolList);
+ Assert (erroneous_symb == BEErroneousSymb);
+
+ /* ArrayFunKind */
+ Assert (CreateArrayFun == BECreateArrayFun);
+ Assert (ArraySelectFun == BEArraySelectFun);
+ Assert (UnqArraySelectFun == BEUnqArraySelectFun);
+ Assert (ArrayUpdateFun == BEArrayUpdateFun);
+ Assert (ArrayReplaceFun == BEArrayReplaceFun);
+ Assert (ArraySizeFun == BEArraySizeFun);
+ Assert (UnqArraySizeFun == BEUnqArraySizeFun);
+ Assert (_CreateArrayFun == BE_CreateArrayFun);
+ Assert (_UnqArraySelectFun == BE_UnqArraySelectFun);
+ Assert (_UnqArraySelectNextFun == BE_UnqArraySelectNextFun);
+ Assert (_UnqArraySelectLastFun == BE_UnqArraySelectLastFun);
+ Assert (_ArrayUpdateFun == BE_ArrayUpdateFun);
+ Assert (NoArrayFun == BENoArrayFun);
+
+ /* SelectorKind */
+ Assert (1 == BESelector);
+ Assert (SELECTOR_U == BESelector_U);
+ Assert (SELECTOR_F == BESelector_F);
+ Assert (SELECTOR_L == BESelector_L);
+ Assert (SELECTOR_N == BESelector_N);
+} /* CheckBEEnumTypes */
+
+void
+BEArg (CleanString arg)
+{
+ Assert (gBEState.be_argi < gBEState.be_argc);
+
+ gBEState.be_argv [gBEState.be_argi++] = ConvertCleanString (arg);
+
+ // +++ ugly
+ if (gBEState.be_argi == gBEState.be_argc)
+ {
+ char *dummy;
+ extern Bool ParseCommandArgs (int argc, char **argv, char **file_name_p, char **output_file_name_p);
+
+ (void) ParseCommandArgs (gBEState.be_argc, gBEState.be_argv, &dummy, &dummy);
+
+ /* FatalCompError ("backend", "BEInit", "FatalCompError in backend"); */
+ /* ErrorInCompiler ("backend", "BEInit", "ErrorInCompiler in backend"); */
+ /* StaticMessage (True, "<backend>", "StaticMessage (True) in backend"); */
+ /* StaticMessage (False, "<backend>", "StaticMessage (False) in backend"); */
+ /* *(int*)0L= 17; */
+ }
+} /* BEArg */
+
+BackEnd
+BEInit (int argc)
+{
+ Assert (!gBEState.be_initialised);
+
+ CheckBEEnumTypes ();
+
+ CurrentPhase = "Back End";
+ CurrentModule = "<unknown module>";
+ CurrentExt = "";
+
+ gBEState.be_argv = ConvertAlloc ((argc+1) * sizeof (char *));
+ gBEState.be_argv [argc] = NULL;
+ gBEState.be_argc = argc;
+ gBEState.be_argi = 0;
+
+ InitStorage ();
+ /* +++ remove symbol table from backend */
+ ScanInitIdentStringTable ();
+ InitScanner (); /* for inlining */
+ DeltaBId = Identifier ("StdBool");
+ ApplyId = Identifier ("AP");
+ ListId = Identifier ("List");
+ TupleId = Identifier ("Tuple");
+ ConsId = Identifier ("[:]");
+ NilId = Identifier ("[]");
+ SelectId = Identifier ("_Select");
+ IfId = Identifier ("if");
+ FailId = Identifier ("_Fail");
+#if DYNAMIC_TYPE
+ DynamicId = Identifier ("Dynamic");
+#endif
+
+ UserDefinedArrayFunctions = NULL;
+
+ InitPredefinedSymbols ();
+
+ ClearOpenDefinitionModules ();
+
+ InitStatesGen ();
+ InitCoding ();
+ InitInstructions ();
+
+ gBEState.be_modules = NULL;
+ gBEState.be_allSymbols = NULL;
+ gBEState.be_dontCareSymbol = NULL;
+ gBEState.be_dictionarySelectFunSymbol = NULL;
+ gBEState.be_dictionaryUpdateFunSymbol = NULL;
+
+ gBEState.be_initialised = True;
+
+ return ((BackEnd) &gBEState);
+} /* BEInit */
+
+void
+BEFree (BackEnd backEnd)
+{
+ Assert (backEnd == (BackEnd) &gBEState);
+
+ FreeConvertBuffers ();
+ CompFree ();
+
+ Assert (gBEState.be_initialised);
+ gBEState.be_initialised = False;
+
+ if (StdErrorReopened)
+ fclose (StdError);
+ if (StdOutReopened)
+ fclose (StdOut);
+} /* BEFree */