diff options
Diffstat (limited to 'backendC/CleanCompilerSources/backend.c')
| -rw-r--r-- | backendC/CleanCompilerSources/backend.c | 2683 |
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 */ |