#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 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 */ 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, "", "StaticMessage (True) in backend"); */ /* StaticMessage (False, "", "StaticMessage (False) in backend"); */ /* *(int*)0L= 17; */ } } /* BEArg */ BackEnd BEInit (int argc) { Assert (!gBEState.be_initialised); CheckBEEnumTypes (); CurrentPhase = "Back End"; CurrentModule = ""; 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 */