diff options
| -rw-r--r-- | backend/backendconvert.icl | 62 | ||||
| -rw-r--r-- | backendC/CleanCompilerSources/backend.c | 21 | ||||
| -rw-r--r-- | frontend/convertDynamics.icl | 6 | ||||
| -rw-r--r-- | frontend/overloading.icl | 28 | ||||
| -rw-r--r-- | frontend/postparse.icl | 49 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 2 | ||||
| -rw-r--r-- | frontend/typereify.icl | 35 |
7 files changed, 76 insertions, 127 deletions
diff --git a/backend/backendconvert.icl b/backend/backendconvert.icl index 980042b..163fb4c 100644 --- a/backend/backendconvert.icl +++ b/backend/backendconvert.icl @@ -383,7 +383,8 @@ backEndConvertModules p s main_dcl_module_n var_heap attr_var_heap be backEndConvertModulesH :: PredefinedSymbols FrontEndSyntaxTree !Int *BackEndState -> *BackEndState backEndConvertModulesH predefs {fe_icl = - fe_icl =: {icl_name, icl_functions, icl_common,icl_global_functions,icl_imported_objects,icl_foreign_exports,icl_used_module_numbers, icl_modification_time}, + fe_icl =: {icl_name, icl_functions, icl_common,icl_global_functions, + icl_type_funs, icl_imported_objects,icl_foreign_exports,icl_used_module_numbers, icl_modification_time}, fe_components, fe_dcls, fe_arrayInstances} main_dcl_module_n backEnd // sanity check ... @@ -398,7 +399,8 @@ backEndConvertModulesH predefs {fe_icl = = backEnd # backEnd = abort "front end abort" backEnd -*/ #! backEnd = appBackEnd (BESetMainDclModuleN main_dcl_module_n) backEnd +*/ + #! backEnd = appBackEnd (BESetMainDclModuleN main_dcl_module_n) backEnd #! backEnd = appBackEnd (BEDeclareModules (size fe_dcls)) backEnd #! backEnd @@ -442,7 +444,8 @@ backEndConvertModulesH predefs {fe_icl = #! backEnd = appBackEnd (BEDeclareIclModule icl_name.id_name icl_modification_time (size icl_functions) (size icl_common.com_type_defs) (size icl_common.com_cons_defs) (size icl_common.com_selector_defs)) (backEnd -*-> "BEDeclareIclModule") #! backEnd - = declareFunctionSymbols icl_functions functionIndices icl_global_functions (backEnd -*-> "declareFunctionSymbols") + = declareFunctionSymbols icl_functions functionIndices + (icl_type_funs ++ icl_global_functions) (backEnd -*-> "declareFunctionSymbols") #! backEnd = declare main_dcl_module_n icl_common (backEnd -*-> "declare (main_dcl_module_n)") #! backEnd @@ -470,6 +473,16 @@ backEndConvertModulesH predefs {fe_icl = with dcl_common = currentDcl.dcl_common + # backEnd + = foldSt beExportFunction exported_local_type_funs backEnd + + with + exported_local_type_funs + | False && currentDcl.dcl_module_kind == MK_None + = [] + // otherwise + = flatten [[r.ir_from .. r.ir_to-1] + \\ r <- [icl_type_funs!!1]] # backEnd = bindSpecialIdents predefs icl_used_module_numbers backEnd #! backEnd = removeExpandedTypesFromDclModules fe_dcls icl_used_module_numbers backEnd = (backEnd -*-> "backend done") @@ -483,7 +496,9 @@ declareOtherDclModules dcls main_dcl_module_n used_module_numbers where declareOtherDclModule :: ModuleIndex DclModule -> BackEnder declareOtherDclModule moduleIndex dclModule - | moduleIndex == main_dcl_module_n || moduleIndex == cPredefinedModuleIndex || not (inNumberSet moduleIndex used_module_numbers) + | moduleIndex == main_dcl_module_n + || moduleIndex == cPredefinedModuleIndex + || not (inNumberSet moduleIndex used_module_numbers) = identity // otherwise = declareDclModule moduleIndex dclModule @@ -494,7 +509,9 @@ defineOtherDclModules dcls main_dcl_module_n used_module_numbers where defineOtherDclModule :: ModuleIndex DclModule -> BackEnder defineOtherDclModule moduleIndex dclModule - | moduleIndex == main_dcl_module_n || moduleIndex == cPredefinedModuleIndex || not (inNumberSet moduleIndex used_module_numbers) + | moduleIndex == main_dcl_module_n + || moduleIndex == cPredefinedModuleIndex + || not (inNumberSet moduleIndex used_module_numbers) = identity // otherwise = defineDclModule moduleIndex dclModule @@ -518,9 +535,11 @@ declareDclModule moduleIndex {dcl_name, dcl_modification_time, dcl_common, dcl_f = appBackEnd (BEDeclareDclModule moduleIndex dcl_name.id_name dcl_modification_time (isSystem dcl_module_kind) (size dcl_functions) (size dcl_common.com_type_defs) (size dcl_common.com_cons_defs) (size dcl_common.com_selector_defs)) defineDclModule :: ModuleIndex DclModule -> BackEnder -defineDclModule moduleIndex {dcl_name, dcl_common, dcl_functions,dcl_instances} +defineDclModule moduleIndex + {dcl_name, dcl_common, dcl_functions, dcl_type_funs, dcl_instances} = declare moduleIndex dcl_common - o` declareFunTypes moduleIndex dcl_functions dcl_instances.ir_from + o` declareFunTypes moduleIndex dcl_functions + [{ir_from = 0, ir_to = dcl_instances.ir_from}, dcl_type_funs] removeExpandedTypesFromDclModules :: {#DclModule} NumberSet -> BackEnder removeExpandedTypesFromDclModules dcls used_module_numbers @@ -654,7 +673,6 @@ declareFunctionSymbols functions functionIndices globalFunctions backEnd where functionName :: {#Char} Int [IndexRange] -> {#Char} functionName name functionIndex icl_global_functions -// | trace_t ("|"+++toString functionIndex) | index_in_ranges functionIndex icl_global_functions = name = (name +++ ";" +++ toString functionIndex) @@ -744,28 +762,30 @@ instance declareWithIndex (TypeDef a) where declareWithIndex typeIndex moduleIndex {td_ident} = appBackEnd (BEDeclareType typeIndex moduleIndex td_ident.id_name) -declareFunTypes :: ModuleIndex {#FunType} Int -> BackEnder -declareFunTypes moduleIndex funTypes nrOfDclFunctions - = foldStateWithIndexA (declareFunType moduleIndex nrOfDclFunctions) funTypes +declareFunTypes :: ModuleIndex {#FunType} [IndexRange] -> BackEnder +declareFunTypes moduleIndex funTypes ranges + = foldStateWithIndexA (declareFunType moduleIndex ranges) funTypes -declareFunType :: ModuleIndex Index Int FunType -> BackEnder -declareFunType moduleIndex nrOfDclFunctions functionIndex {ft_ident, ft_type_ptr} +declareFunType :: ModuleIndex [IndexRange] Int FunType -> BackEnder +declareFunType moduleIndex ranges functionIndex {ft_ident, ft_type_ptr} = \be0 -> let (vi,be) = read_from_var_heap ft_type_ptr be0 in (case vi of VI_ExpandedType expandedType - -> beDeclareRuleType functionIndex moduleIndex (functionName ft_ident.id_name functionIndex nrOfDclFunctions) + -> beDeclareRuleType functionIndex moduleIndex (functionName ft_ident.id_name functionIndex ranges) o` beDefineRuleType functionIndex moduleIndex (convertTypeAlt functionIndex moduleIndex expandedType) _ -> identity) be where - functionName :: {#Char} Int Int -> {#Char} - functionName name functionIndex nrOfDclFunctions -// | trace_tn (name+++(if (functionIndex < nrOfDclFunctions) "" (";" +++ toString functionIndex))) - - | functionIndex < nrOfDclFunctions + functionName :: {#Char} Int [IndexRange] -> {#Char} + functionName name functionIndex ranges + | index_in_ranges functionIndex ranges = name - // otherwise - = name +++ ";" +++ toString functionIndex + = (name +++ ";" +++ toString functionIndex) + where + index_in_ranges index [{ir_from, ir_to}:ranges] + = (index>=ir_from && index < ir_to) || index_in_ranges index ranges; + index_in_ranges index [] + = False defineTypes :: ModuleIndex {#ConsDef} {#SelectorDef} {#CheckedTypeDef} -> BackEnder defineTypes moduleIndex constructors selectors types diff --git a/backendC/CleanCompilerSources/backend.c b/backendC/CleanCompilerSources/backend.c index 6571c4b..07d18b4 100644 --- a/backendC/CleanCompilerSources/backend.c +++ b/backendC/CleanCompilerSources/backend.c @@ -502,7 +502,10 @@ BEDeclareModules (int nModules) gBEState.be_modules = (BEModuleP) ConvertAlloc (nModules * sizeof (BEModuleS)); for (i = 0; i < nModules; i++) + { gBEState.be_modules [i].bem_name = NULL; + gBEState.be_modules [i].bem_nFunctions = 0; + } } /* BEDeclareModules */ BESymbolP @@ -3431,15 +3434,21 @@ BEExportFunction (int functionIndex) dclModule = &gBEState.be_icl.beicl_dcl_module; - Assert ((unsigned int) functionIndex < dclModule->bem_nFunctions); - functionSymbol = &dclModule->bem_functions [functionIndex]; - Assert (functionSymbol->symb_kind == definition); - dclDef = functionSymbol->symb_def; + if (((unsigned int) functionIndex < dclModule->bem_nFunctions)) + { + functionSymbol = &dclModule->bem_functions [functionIndex]; + Assert (functionSymbol->symb_kind == definition); + dclDef = functionSymbol->symb_def; + + dclDef->sdef_dcl_icl = iclDef; + + Assert (strcmp (iclDef->sdef_ident->ident_name, dclDef->sdef_ident->ident_name) == 0); + } + else + dclDef = NULL; - Assert (strcmp (iclDef->sdef_ident->ident_name, dclDef->sdef_ident->ident_name) == 0); iclDef->sdef_dcl_icl = dclDef; - dclDef->sdef_dcl_icl = iclDef; iclDef->sdef_exported = True; } /* BEExportFunction */ diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index d5c8a59..df56c4e 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -646,14 +646,12 @@ where # predef_type_index = type_index + FirstTypePredefinedSymbolIndex = constructorExp (predefinedTypeConstructor predef_type_index) SK_Function 0 ci - typeConstructor (GTT_Constructor cons_ident fun_ident) ci - # type_cons - = App {app_symb = cons_ident, app_args = [], app_info_ptr = nilPtr} + typeConstructor (GTT_Constructor fun_ident) ci # type_fun = App {app_symb = fun_ident, app_args = [], app_info_ptr = nilPtr} # (to_tc_symb, ci) = getSymbol PD_Dyn__to_TypeCodeConstructor SK_Function 2 ci - = (App {app_symb = to_tc_symb, app_args = [type_cons, type_fun], app_info_ptr = nilPtr}, ci) + = (App {app_symb = to_tc_symb, app_args = [type_fun], app_info_ptr = nilPtr}, ci) typeConstructor (GTT_Basic basic_type) ci = constructorExp (basicTypeConstructor basic_type) SK_Function 0 ci typeConstructor GTT_Function ci diff --git a/frontend/overloading.icl b/frontend/overloading.icl index a8d6729..a8cd068 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -1293,35 +1293,19 @@ toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} c | module_index == cPredefinedModuleIndex = GTT_PredefTypeConstructor type // otherwise - # tc_type_index - = type_index + 1 - # types - = common_defs.[module_index].com_type_defs - // sanity check ... - # type_ident - = types.[type_index].td_ident.id_name + # type + = common_defs.[module_index].com_type_defs.[type_index] # td_fun_index - = types.[type_index].td_fun_index - # tc_type_name - = types.[tc_type_index].td_ident.id_name - | "TC;" +++ type_ident <> tc_type_name - = fatal "toTypeCodeConstructor" ("name mismatch (" +++ type_ident +++ ", " +++ tc_type_name +++ ")") - // ... sanity check - # ({td_rhs=AlgType [{ds_ident, ds_index}:_]}) - = types.[tc_type_index] - # type_constructor - = { symb_ident = ds_ident - , symb_kind = SK_Constructor {glob_module = module_index, glob_object = ds_index} - } + = type.td_fun_index // sanity check ... | td_fun_index == NoIndex - = fatal "toTypeCodeConstructor" ("no function (" +++ type_ident +++ ")") + = fatal "toTypeCodeConstructor" ("no function (" +++ type.td_ident.id_name +++ ")") // ... sanity check # type_fun - = { symb_ident = {ds_ident & id_info = nilPtr} // this is wrong but let's give it a try + = { symb_ident = {type.td_ident & id_info = nilPtr} // this is wrong but let's give it a try , symb_kind = SK_Function {glob_module = module_index, glob_object = td_fun_index} } - = GTT_Constructor type_constructor type_fun + = GTT_Constructor type_fun fatal :: {#Char} {#Char} -> .a fatal function_name message diff --git a/frontend/postparse.icl b/frontend/postparse.icl index 85d5d91..a440111 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -1477,54 +1477,9 @@ reorganiseDefinitionsAndAddTypes mod_ident support_dynamics icl_module defs ca , import_file_position = NoPos } # imports = if (mod_ident == clean_types_module_ident) [] [clean_types_module] - # (rev_defs, ca) - = addTypeConstructors defs [PD_Import imports] ca - = reorganiseDefinitions icl_module (reverse rev_defs) 0 0 0 0 ca + = reorganiseDefinitions icl_module [PD_Import imports : defs] 0 0 0 0 ca + // otherwise = reorganiseDefinitions icl_module defs 0 0 0 0 ca - where - addTypeConstructors [] rev_defs ca - = (rev_defs, ca) - addTypeConstructors [PD_Type type_def : defs] rev_defs ca - # (type_def, tc_def, ca) - = addTypeConstructor type_def ca - = addTypeConstructors defs [PD_Type tc_def, PD_Type type_def : rev_defs] ca - addTypeConstructors [def : defs] rev_defs ca - = addTypeConstructors defs [def : rev_defs] ca - -addTypeConstructor def=:{td_ident, td_attribute, td_attrs, td_args, td_arity, td_pos} ca=:{ca_hash_table} - # tc_name = "TC;" +++ td_ident.id_name - # ({boxed_ident=tc_cons_ident}, ca_hash_table) = putIdentInHashTable tc_name IC_Expression ca_hash_table - # ({boxed_ident=tc_type_ident}, ca_hash_table) = putIdentInHashTable tc_name IC_Type ca_hash_table - = (def, type_tc_def tc_type_ident tc_cons_ident td_ident td_attribute td_attrs td_args - td_arity td_pos, { ca & ca_hash_table = ca_hash_table }) - where - type_tc_def ident cons_ident type_ident attr attrs args arity position - = { td_ident = ident - , td_index = NoIndex - , td_arity = arity - , td_args = args - , td_attrs = attrs - , td_context = [] - , td_rhs = ConsList [type_tc_cons cons_ident type_ident args arity position] - , td_attribute = attr - , td_pos = position - , td_used_types = [] - , td_fun_index = NoIndex - } - type_tc_cons cons_ident type_ident args arity position - = { pc_cons_ident = cons_ident - , pc_cons_arity = 1 - , pc_exi_vars = [] - , pc_arg_types = [type type_ident args arity] - , pc_args_strictness = NotStrict - , pc_cons_prio = NoPrio - , pc_cons_pos = position - } - type type_ident args arity - = { at_attribute = TA_None - , at_type = TA (MakeNewTypeSymbIdent type_ident arity) - [{at_attribute = TA_None, at_type = TV arg.atv_variable} \\ arg <- args] - } belongsToTypeSpec name prio new_name is_infix :== name == new_name && sameFixity prio is_infix diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index e28c750..d36f318 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -1289,7 +1289,7 @@ instance == OverloadedListType :: GlobalTCType = GTT_Basic !BasicType - | GTT_Constructor !SymbIdent !SymbIdent // type_cons type_fun + | GTT_Constructor !SymbIdent | GTT_PredefTypeConstructor !(Global Index) | GTT_Function diff --git a/frontend/typereify.icl b/frontend/typereify.icl index 3f4c1cf..8085c9a 100644 --- a/frontend/typereify.icl +++ b/frontend/typereify.icl @@ -598,8 +598,8 @@ instance reify GlobalTCType where # predef_type_index = type_index + FirstTypePredefinedSymbolIndex = function (predefinedTypeConstructor predef_type_index) - reify (GTT_Constructor type_cons type_fun) - = function PD_Dyn__to_TypeCodeConstructor ` type_cons ` type_fun + reify (GTT_Constructor type_fun) + = function PD_Dyn__to_TypeCodeConstructor ` type_fun predefinedTypeConstructor predef_type_index | predef_type_index == PD_ListType @@ -638,38 +638,21 @@ basic value // copied and adopted from overloading toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} common_defs | module_index == cPredefinedModuleIndex - = GTT_PredefTypeConstructor type + = GTT_PredefTypeConstructor type // otherwise - # tc_type_index - = type_index + 1 - # types - = common_defs.[module_index].com_type_defs - // sanity check ... - # type_ident - = types.[type_index].td_ident.id_name - # tc_type_name - = types.[tc_type_index].td_ident.id_name - | "TC;" +++ type_ident <> tc_type_name - = fatal "toTypeCodeConstructor" ("name mismatch (" +++ type_ident +++ ", " +++ tc_type_name +++ ")") - // ... sanity check - # ({td_rhs=AlgType [{ds_ident, ds_index}:_]}) - = types.[tc_type_index] - # type_constructor - = { symb_ident = ds_ident - , symb_kind = SK_Constructor {glob_module = module_index, glob_object = ds_index} - } + # type + = common_defs.[module_index].com_type_defs.[type_index] # td_fun_index - = types.[type_index].td_fun_index + = type.td_fun_index // sanity check ... | td_fun_index == NoIndex - = fatal "toTypeCodeConstructor" ("no function (" +++ type_ident - +++ " type " +++ toString type_index +++ " module " +++ toString module_index +++ ")") + = fatal "toTypeCodeConstructor" ("no function (" +++ type.td_ident.id_name +++ ")") // ... sanity check # type_fun - = { symb_ident = {ds_ident & id_info = nilPtr} // this is wrong but let's give it a try + = { symb_ident = {type.td_ident & id_info = nilPtr} // this is wrong but let's give it a try , symb_kind = SK_Function {glob_module = module_index, glob_object = td_fun_index} } - = GTT_Constructor type_constructor type_fun + = GTT_Constructor type_fun fatal :: {#Char} {#Char} -> .a fatal function_name message |