diff options
Diffstat (limited to 'frontend/explicitimports.icl')
| -rw-r--r-- | frontend/explicitimports.icl | 865 |
1 files changed, 865 insertions, 0 deletions
diff --git a/frontend/explicitimports.icl b/frontend/explicitimports.icl new file mode 100644 index 0000000..e683a83 --- /dev/null +++ b/frontend/explicitimports.icl @@ -0,0 +1,865 @@ +implementation module explicitimports + +import StdEnv + +import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef, RWSDebug + + +temporary_import_solution_XXX yes no :== yes +// to switch between importing modes. +// iff this is yes, then explicit imports happen in the old Clean 1.3 fashion. +// This feature will be removed, when all programs are ported to Clean 2.0. The last Constructors of AtomType +// and StructureType should then be removed also +do_temporary_import_solution_XXX :== temporary_import_solution_XXX True False + +// MW was cIclModIndex :== 0 + +// MW DclModule +:: ExplicitImports :== (![AtomicImport], ![StructureImport]) +:: AtomicImport :== (!Ident, !AtomType) +:: StructureImport :== (!Ident, !StructureInfo, !StructureType, !OptimizeInfo) + +:: AtomType = AT_Function | AT_Class | AT_Instance | AT_RecordType | AT_AlgType | AT_Type + | AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen Bool // XXX +:: StructureInfo = SI_DotDot + // The .. notation was used for the structure + // (currently nothing is known about the elements) + | SI_Elements ![Ident] !Bool + // list of elements, that were not imported yet. + // Bool: the elements were listed explicitly in the structure +:: StructureType = ST_AlgType | ST_RecordType | ST_Class + | ST_stomm_stomm_stomm String +:: IdentWithKind :== (!Ident, !STE_Kind) +:: IdentWithCKind :== (!Ident, !ConsequenceKind) + +:: OptimizeInfo :== (Optional !Index) + +:: ConsequenceKind = CK_Function !(Global Index) + | CK_DynamicPatternType ExprInfoPtr + | CK_Macro + | CK_Constructor + | CK_Selector !(Global DefinedSymbol) + | CK_Type + | CK_Class + +:: FunctionConsequence :== Optional !(!Int, !Optional ![IdentWithCKind]) + // Int i: The consequences of this function/macro have already been considered for all dcl modules with indices <= i + +check_completeness_of_all_dcl_modules :: !*{#DclModule} !*{#FunDef} !*ExpressionHeap !*CheckState + -> (!Int, !(!*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap, !*CheckState)) +check_completeness_of_all_dcl_modules modules icl_functions expr_heap cs + # (nr_modules, modules) = usize modules + (nr_functions, icl_functions) = usize icl_functions + f_consequences = f_consequences nr_functions + result + = iFoldSt check_completeness_of_dcl_module 0 (nr_modules) (f_consequences, modules, icl_functions, expr_heap, cs) + = (nr_modules, result) + where + f_consequences :: !Int -> *{!FunctionConsequence} + f_consequences i = createArray i No + +check_completeness_of_dcl_module mod_index (f_consequences, modules, icl_functions, expr_heap, cs=:{cs_predef_symbols}) + # pre_mod = cs_predef_symbols.[PD_PredefinedModule] + | pre_mod.pds_def == mod_index + = (f_consequences, modules, icl_functions, expr_heap, cs) // predefined module should not be checked for completeness of explicit imports + # (modul=:{ dcl_name, dcl_declared=dcl_declared=:{dcls_import,dcls_local, dcls_explicit}}, modules) + = modules![mod_index] + cs = addDeclaredSymbolsToSymbolTable cIsADclModule mod_index dcls_local dcls_import cs + (f_consequences, modules, icl_functions, expr_heap, cs) + = check_completeness_of_module mod_index dcls_explicit (dcl_name.id_name+++".dcl") (f_consequences, modules, icl_functions, expr_heap, cs) + (_, cs_symbol_table) = retrieveAndRemoveImportsFromSymbolTable [(mod_index, dcl_declared)] [] cs.cs_symbol_table + cs = { cs & cs_symbol_table=cs_symbol_table } + = (f_consequences, modules, icl_functions, expr_heap, cs) + +possibly_filter_decls :: .[ImportDeclaration] u:[w:(.Index,y:Declarations)] (.FileName,.LineNr) *{#.DclModule} *CheckState -> (v:[x:(Index,z:Declarations)],.{#DclModule},.CheckState), [y <= z, w <= x, u <= v]; +possibly_filter_decls [] decls_of_imported_module _ modules cs // implicit import can't go wrong + = (decls_of_imported_module, modules, cs) +possibly_filter_decls listed_symbols decls_of_imported_module (file_name, line_nr) modules cs + // explicit import + #! + ident_pos = { ip_ident= { id_name="", id_info=nilPtr } + , ip_line = line_nr + , ip_file = file_name + } + cs = { cs & cs_error = pushErrorAdmin ident_pos cs.cs_error } + (result, modules, cs) = filter_explicitly_imported_decl listed_symbols decls_of_imported_module [] line_nr modules cs + cs = { cs & cs_error = popErrorAdmin cs.cs_error } + = (result, modules, cs) + +filter_explicitly_imported_decl _ [] akku _ modules cs + = (akku, modules, cs) +filter_explicitly_imported_decl import_symbols [(index,{dcls_import,dcls_local,dcls_explicit}):new_decls] akku + line_nr modules cs + # undefined = -1 + atoms = flatten (map toAtom import_symbols) + structures = flatten (map toStructure import_symbols) + (checked_atoms, cs) = checkAtoms atoms cs + unimported = (checked_atoms, structures) + ((dcls_import,unimported), modules, cs) + = filter_decl dcls_import [] unimported undefined modules cs + ((dcls_local,unimported), modules, cs) + = filter_decl dcls_local [] unimported index modules cs + cs_error = foldSt checkAtomError (fst unimported) cs.cs_error + cs_error = foldSt checkStructureError (snd unimported) cs_error + cs = { cs & cs_error=cs_error } + | (isEmpty dcls_import && isEmpty dcls_local && isEmpty dcls_explicit) + = filter_explicitly_imported_decl import_symbols new_decls akku line_nr modules cs + # local_imports = [ { declaration & dcl_kind = STE_Imported declaration.dcl_kind index } + \\ declaration <- dcls_local] + new_dcls_explicit = [ (dcls, line_nr) \\ dcls<-dcls_import++local_imports ] + newAkku = [(index, { dcls_import=dcls_import, dcls_local=dcls_local , dcls_explicit=new_dcls_explicit}) : akku] + = filter_explicitly_imported_decl import_symbols new_decls newAkku line_nr modules cs + where + toAtom (ID_Function {ii_ident}) + = [(ii_ident, temporary_import_solution_XXX + (AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen False) + AT_Function)] + toAtom (ID_Class {ii_ident} _) + = [(ii_ident, AT_Class)] + toAtom (ID_Type {ii_ident} (Yes _)) + = [(ii_ident, AT_AlgType)] + toAtom (ID_Type {ii_ident} No) + = [(ii_ident, AT_Type)] + toAtom (ID_Record {ii_ident} yesOrNo) + = [(ii_ident, AT_RecordType)] + toAtom (ID_Instance _ ident _) + = [(ident, AT_Instance)] + toAtom _ + = [] + + atomTypeString AT_Function = "function" + atomTypeString AT_Class = "class" + atomTypeString AT_Instance = "instance" + atomTypeString _ = "type" + + toStructure (ID_Class {ii_ident} yesOrNo) + = to_structure ii_ident yesOrNo ST_Class + toStructure (ID_Type {ii_ident} yesOrNo) + = to_structure ii_ident yesOrNo ST_AlgType + toStructure (ID_Record {ii_ident} yesOrNo) + = to_structure ii_ident yesOrNo ST_RecordType +// MW added + toStructure (ID_Function {ii_ident}) + | do_temporary_import_solution_XXX + = [(ii_ident, SI_DotDot, ST_stomm_stomm_stomm ii_ident.id_name, No)] +// ..MW + toStructure _ + = [] + + to_structure _ No _ + = [] + to_structure ident (Yes []) structureType + = [(ident, SI_DotDot, structureType, No)] + to_structure ident (Yes elements) structureType + # element_idents = removeDup [ ii_ident \\ {ii_ident}<-elements] + = [(ident, (SI_Elements element_idents True),structureType, No)] + + checkAtoms l cs + # groups = grouped l + # wrong = filter isErrornous groups + unique = map hd groups + | isEmpty wrong + = (unique, cs) + = (unique, foldSt error wrong cs) + where + isErrornous l=:[(_,AT_Type),_:_] = True + isErrornous l=:[(_,AT_AlgType),_:_] = True + isErrornous l=:[(_,AT_RecordType),_:_] = True + isErrornous _ = False + + error [(ident, atomType):_] cs + = { cs & cs_error = checkError ("type "+++ident.id_name) "imported more than once in one from statement" + cs.cs_error } + + checkAtomError (id, AT_Instance) cs_error + = checkError ("specified instance of class "+++id.id_name) "not exported by the specified module" cs_error + checkAtomError (id, AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen was_imported_at_least_once) cs_error + | do_temporary_import_solution_XXX + = case was_imported_at_least_once of + True -> cs_error + _ -> checkError id ("not exported by the specified module") cs_error + checkAtomError (id, atomType) cs_error + = checkError id ("not exported as a "+++atomTypeString atomType+++" by the specified module") cs_error + +// MW remove this later.. + checkStructureError (_,_, ST_stomm_stomm_stomm _, _) cs_error + | do_temporary_import_solution_XXX + = cs_error + // further with next alternative +// ..MW + checkStructureError (struct_id, (SI_Elements wrong_elements _), st, _) cs_error + = foldSt err wrong_elements cs_error + where + err element_id cs_error + # (element_type, structure_type) = case st of + ST_AlgType -> ("constructor", "algebraic type") + ST_RecordType -> ("field", "record type") + ST_Class -> ("member", "class") + = checkError element_id ( "not a "+++element_type+++" of "+++structure_type + +++" "+++struct_id.id_name) cs_error + checkStructureError _ cs_error + = cs_error + + // collect groups, e.g. grouped [3,5,1,3,1] = [[1,1],[3,3],[5]] + grouped [] + = [] + grouped l + # sorted = qsort l + = grouped_ [hd sorted] (tl sorted) [] + where + grouped_ group [] akku + = [group:akku] + grouped_ group=:[x:_] [h:t] akku + | x==h = grouped_ [h:group] t akku + = grouped_ [h] t [group:akku] + + qsort [] = [] + qsort [h:t] = qsort left++[h: qsort right] + where + left = [x \\ x<-t | greater x h] + right = [x \\ x<-t | not (greater x h) || x==h] + greater ({id_name=id_name_l}, atomType_l) ({id_name=id_name_r}, atomType_r) + | id_name_l >id_name_r = True + | id_name_l==id_name_r = toInt atomType_l > toInt atomType_r + = False + +instance == AtomType + where + (==) l r = toInt l==toInt r + +instance toInt AtomType + where + toInt AT_Function = 0 + toInt AT_Class = 1 + toInt AT_Instance = 2 + toInt AT_RecordType = 3 + toInt AT_AlgType = 3 + toInt AT_Type = 3 // AT_RecordType, AT_AlgType & AT_Type are in one class !!! + toInt (AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen _) + = 0 + +instance == ConsequenceKind + where + (==) CK_Type c = case c of CK_Type -> True + _ -> False + (==) CK_Constructor c = case c of CK_Constructor -> True + _ -> False + (==) (CK_Selector globDefinedSymb1) + c = case c of CK_Selector globDefinedSymb2 -> globDefinedSymb1==globDefinedSymb2 + _ -> False + (==) CK_Class c = case c of CK_Class-> True + _ -> False + (==) (CK_Function globIndex1) + c = case c of (CK_Function globIndex2) -> globIndex1==globIndex2 + _ -> False + (==) CK_Macro c = case c of CK_Macro-> True + _ -> False + +filter_decl [] akku unimported _ modules cs + = ((akku, unimported), modules, cs) +filter_decl [decl:decls] akku unimported index modules cs + # ((appears,unimported), modules, cs) = decl_appears decl unimported index modules cs + = filter_decl decls (if appears [decl:akku] akku) unimported index modules cs + +decl_appears :: !Declaration !ExplicitImports !Index !*{#DclModule} !*CheckState + -> (!(!Bool, !ExplicitImports), !*{#DclModule}, !*CheckState) +decl_appears dec=:{dcl_kind=STE_Imported ste_Kind def_index} unimported _ modules cs + = decl_appears {dec & dcl_kind=ste_Kind} unimported def_index modules cs +/* MW2 was: +decl_appears {dcl_ident,dcl_kind=STE_Constructor,dcl_index} unimported index modules cs + = elementAppears ST_AlgType dcl_ident dcl_index unimported index modules cs +*/ +decl_appears {dcl_ident,dcl_kind=STE_Constructor,dcl_index} unimported index modules cs + # (result=:((appears, unimported), modules, cs)) + = elementAppears ST_AlgType dcl_ident dcl_index unimported index modules cs + | appears || not do_temporary_import_solution_XXX + = result + = atomAppears dcl_ident dcl_index unimported index modules cs +/* MW2 was +decl_appears { dcl_ident,dcl_kind=(STE_Field _),dcl_index} unimported index modules cs + = elementAppears ST_RecordType dcl_ident dcl_index unimported index modules cs +*/ +decl_appears { dcl_ident,dcl_kind=(STE_Field _),dcl_index} unimported index modules cs + # (result=:((appears, unimported), modules, cs)) + = elementAppears ST_RecordType dcl_ident dcl_index unimported index modules cs + | appears || not do_temporary_import_solution_XXX + = result + = atomAppears dcl_ident dcl_index unimported index modules cs +/* MW2 was +decl_appears { dcl_ident,dcl_kind=STE_Member,dcl_index} unimported index modules cs + = elementAppears ST_Class dcl_ident dcl_index unimported index modules cs +*/ +decl_appears { dcl_ident,dcl_kind=STE_Member,dcl_index} unimported index modules cs + # (result=:((appears, unimported), modules, cs)) + = elementAppears ST_Class dcl_ident dcl_index unimported index modules cs + | appears || not do_temporary_import_solution_XXX + = result + = atomAppears dcl_ident dcl_index unimported index modules cs +decl_appears {dcl_ident, dcl_kind, dcl_index} unimported index modules cs + | isAtom dcl_kind + = atomAppears dcl_ident dcl_index unimported index modules cs + where + isAtom STE_DclFunction = True + isAtom (STE_FunctionOrMacro _) = True + isAtom STE_Class = True + isAtom STE_Type = True + isAtom STE_Instance = True + + +// CommonDefs CollectedDefinitions + +elementAppears imported_st dcl_ident dcl_index (atomicImports, structureImports) index modules cs + # ((result, structureImports), modules, cs) + = element_appears imported_st dcl_ident dcl_index structureImports [] index modules cs + = ((result, (atomicImports, structureImports)), modules, cs) + +atomAppears dcl_ident dcl_index (atomicImports, structureImports) index modules cs + # ((result, atomicImports), modules, cs) + = atom_appears dcl_ident dcl_index atomicImports [] index modules cs + = ((result, (atomicImports, structureImports)), modules, cs) + + +atom_appears _ _ [] akku _ modules cs + = ((False, akku), modules, cs) +atom_appears ident dcl_index [h=:(import_ident, atomType):t] akku index modules cs +// MW2.. + | do_temporary_import_solution_XXX + && ident.id_name==import_ident.id_name + && atomType==(AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen True) // True or False doesn't matter in this line + # new_h = (import_ident, AT_stomme_funktion_die_alle_symbolen_kann_importeren_omdat_niemand_zin_heft_oude_pragrammen_naar_de_nieuwe_syntax_te_vertalen True) + = ((True, [new_h:t]++akku), modules, cs) +// ..MW2 + | ident==import_ident + # (modules, cs) = checkRecordError atomType import_ident dcl_index index modules cs + = ((True, t++akku), modules, cs) + // goes further with next alternative + where + checkRecordError atomType import_ident dcl_index index modules cs + # (td_rhs, modules, cs) = lookup_type dcl_index index modules cs + cs_error = cs.cs_error + cs_error = case atomType of + AT_RecordType + -> case td_rhs of + RecordType _ -> cs_error + _ -> checkError import_ident "imported as a record type" cs_error + AT_AlgType + -> case td_rhs of + AlgType _ -> cs_error + _ -> checkError import_ident "imported as an algebraic type" cs_error + _ -> cs_error + = (modules, { cs & cs_error=cs_error }) +atom_appears ident dcl_index [h:t] akku index modules cs + = atom_appears ident dcl_index t [h:akku] index modules cs + +instance == StructureType + where + (==) ST_AlgType ST_AlgType = True + (==) ST_RecordType ST_RecordType = True + (==) ST_Class ST_Class = True + (==) _ _ = False + +element_appears _ _ _ [] akku _ modules cs + = ((False, akku), modules, cs) +// MW remove this later .. +element_appears imported_st element_ident dcl_index + [h=:(_, SI_DotDot, ST_stomm_stomm_stomm type_name_string, optInfo):t] akku + index modules cs + | do_temporary_import_solution_XXX + # (appears, modules, cs) + = element_appears_in_stomm_struct imported_st element_ident dcl_index index type_name_string modules cs + | appears + = ((appears,[h:t]++akku), modules, cs) + = element_appears imported_st element_ident dcl_index t [h:akku] index modules cs + // otherwise go further with next alternative +// ..MW +element_appears imported_st element_ident dcl_index + [h=:(_, _, st, _):t] akku + index modules cs + | imported_st<>st + = element_appears imported_st element_ident dcl_index t [h:akku] index modules cs + // goes further with next alternative +element_appears imported_st element_ident dcl_index + [h=:(_, _, _, (Yes notDefinedHere)):t] akku + index modules cs + | notDefinedHere==dcl_index + = element_appears imported_st element_ident dcl_index t [h:akku] index modules cs + // goes further with next alternative +element_appears imported_st element_ident dcl_index + [h=:(struct_id, (SI_Elements elements explicit), st, optInfo):t] akku + index modules cs + # (l,r) = span ((<>) element_ident) elements + | isEmpty r + = element_appears imported_st element_ident dcl_index t [h:akku] index modules cs + # oneLess = l++(tl r) + newStructure = (struct_id, (SI_Elements oneLess explicit), st, optInfo) + | not explicit + = ((True, [newStructure: t]++akku), modules, cs) + // the found element was explicitly specified by the programmer: check it + # (appears, _, _, modules, cs) + = element_appears_in_struct imported_st element_ident dcl_index struct_id index modules cs + | appears + = ((True, [newStructure: t]++akku), modules, cs) + # message = "does not belong to specified "+++(case st of + ST_Class -> "class." + _ -> "type.") + cs = { cs & cs_error= checkError element_ident message cs.cs_error} + = ((False, t++akku), modules, cs) +element_appears imported_st element_ident dcl_index + [h=:(struct_id, SI_DotDot, st, optInfo):t] akku + index modules cs + # (appears, defined, opt_element_idents, modules, cs) + = element_appears_in_struct imported_st element_ident dcl_index struct_id index modules cs + | not appears + # structureInfo = case opt_element_idents of + No -> SI_DotDot + Yes element_idents -> (SI_Elements element_idents False) + newStructure = (struct_id, SI_DotDot, st, (if defined No (Yes dcl_index))) + = element_appears imported_st element_ident dcl_index t [newStructure:akku] index modules cs + # (Yes element_idents) = opt_element_idents + oneLess = filter ((<>) element_ident) element_idents + newStructure = (struct_id, (SI_Elements oneLess False), st, No) + = ((True,[newStructure:t]++akku), modules, cs) +element_appears imported_st element_ident dcl_index [h:t] akku index modules cs + = element_appears imported_st element_ident dcl_index t [h:akku] index modules cs + +lookup_type dcl_index index modules cs + # (dcl_module=:{dcl_name=dcl_name=:{id_info}}, modules) = modules ! [index] + (module_entry, cs_symbol_table) = readPtr id_info cs.cs_symbol_table + cs = { cs & cs_symbol_table=cs_symbol_table } + = continuation module_entry.ste_kind dcl_module modules cs + where + continuation (STE_OpenModule _ modul) _ modules cs + # allTypes = modul.mod_defs.def_types + = ((allTypes !! dcl_index).td_rhs, modules, cs) + continuation STE_ClosedModule dcl_module modules cs + # com_type_def = dcl_module.dcl_common.com_type_defs.[dcl_index] + = (com_type_def.td_rhs, modules, cs) + +// MW remove this later CCC +element_appears_in_stomm_struct imported_st element_ident dcl_index index type_name_string modules cs + | not do_temporary_import_solution_XXX + = abort "element_appears_in_stomm_struct will be never called, when the above guard holds. This statement is only to remind people to remove this function." + # (dcl_module=:{dcl_name=dcl_name=:{id_info}}, modules) = modules ! [index] + (module_entry, cs_symbol_table) = readPtr id_info cs.cs_symbol_table + cs = { cs & cs_symbol_table=cs_symbol_table } + = continuation imported_st module_entry.ste_kind dcl_module modules cs + where + continuation ST_RecordType (STE_OpenModule _ modul) _ modules cs + // lookup the constructors/fields for the algebraic type/record + # allTypes = modul.mod_defs.def_types + search = dropWhile (\{td_name} -> td_name.id_name<>type_name_string) allTypes + | isEmpty search + = (False, modules, cs) + # {td_rhs} = hd search + | not (isRecordType td_rhs) + = (False, modules, cs) + # element_idents = getElements td_rhs + = (isMember element_ident element_idents, modules, cs) + continuation ST_RecordType STE_ClosedModule dcl_module modules cs + // lookup the type of the constructor and compare + # type_index = dcl_module.dcl_common.com_selector_defs.[dcl_index].sd_type_index + com_type_def = dcl_module.dcl_common.com_type_defs.[type_index] + appears = com_type_def.td_name.id_name==type_name_string + = (appears, modules, cs) + continuation ST_Class (STE_OpenModule _ modul) _ modules cs + // lookup the members for the class + # allClasses = modul.mod_defs.def_classes + search = dropWhile (\{class_name} -> class_name.id_name<>type_name_string) allClasses + | isEmpty search + = (False, modules, cs) + # {class_members} = hd search + element_idents = [ ds_ident \\ {ds_ident} <-:class_members ] + = (isMember element_ident element_idents, modules, cs) + continuation ST_Class STE_ClosedModule dcl_module modules cs + // lookup the class and compare + # com_member_def = dcl_module.dcl_common.com_member_defs.[dcl_index] + {glob_object} = com_member_def.me_class + com_class_def = dcl_module.dcl_common.com_class_defs.[glob_object] + allMembers = com_class_def.class_members + member_idents = [ ds_ident \\ {ds_ident} <-: allMembers] + appears = com_class_def.class_name.id_name==type_name_string + = (appears, modules, cs) + continuation _ _ _ modules cs + = (False, modules, cs) + getElements (RecordType {rt_fields}) + = [ fs_name \\ {fs_name}<-:rt_fields ] + getElements _ + = [] + isRecordType (RecordType _) = True + isRecordType _ = False +// ..MW + +/* 1st result: whether the element appears in the structure + 2nd result: whether the structure is defined at all in the module + 3rd result: Yes: a list of all idents of the elements of the structure +the first bool implies the second +*/ +element_appears_in_struct imported_st element_ident dcl_index struct_ident index modules cs + # (dcl_module=:{dcl_name=dcl_name=:{id_info}}, modules) = modules ! [index] + (module_entry, cs_symbol_table) = readPtr id_info cs.cs_symbol_table + cs = { cs & cs_symbol_table=cs_symbol_table } + = continuation imported_st module_entry.ste_kind dcl_module modules cs + where + continuation ST_Class (STE_OpenModule _ modul) _ modules cs + // lookup the members for the class + # allClasses = modul.mod_defs.def_classes + search = dropWhile (\{class_name} -> class_name<>struct_ident) allClasses + | isEmpty search + = (False, False, No, modules, cs) + # {class_members} = hd search + element_idents = [ ds_ident \\ {ds_ident} <-:class_members ] + = (isMember element_ident element_idents, True, Yes element_idents, modules, cs) + continuation imported_st (STE_OpenModule _ modul) _ modules cs + // lookup the constructors/fields for the algebraic type/record + # allTypes = modul.mod_defs.def_types + search = dropWhile (\{td_name} -> td_name<>struct_ident) allTypes + | isEmpty search + = (False, False, No, modules, cs) + # {td_rhs} = hd search + | not (isAlgOrRecordType td_rhs) + = (False, True, No, modules, cs) + # element_idents = getElements td_rhs + = (isMember element_ident element_idents, True, Yes element_idents, modules, cs) + continuation ST_Class STE_ClosedModule dcl_module modules cs + // lookup the class and compare + # com_member_def = dcl_module.dcl_common.com_member_defs.[dcl_index] + {glob_object} = com_member_def.me_class + com_class_def = dcl_module.dcl_common.com_class_defs.[glob_object] + allMembers = com_class_def.class_members + member_idents = [ ds_ident \\ {ds_ident} <-: allMembers] + appears = com_class_def.class_name==struct_ident + = (appears, True, if appears (Yes member_idents) No, modules, cs) + continuation imported_st STE_ClosedModule dcl_module modules cs + // lookup the type of the constructor and compare + # type_index = if (imported_st==ST_AlgType) + dcl_module.dcl_common.com_cons_defs.[dcl_index].cons_type_index + dcl_module.dcl_common.com_selector_defs.[dcl_index].sd_type_index + com_type_def = dcl_module.dcl_common.com_type_defs.[type_index] + element_idents = getElements com_type_def.td_rhs + appears = com_type_def.td_name==struct_ident + = (appears, True, if appears (Yes element_idents) No, modules, cs) + isAlgOrRecordType (AlgType _) = True + isAlgOrRecordType (RecordType _) = True + isAlgOrRecordType _ = False + getElements (AlgType constructor_symbols) + = [ds_ident \\ {ds_ident} <- constructor_symbols] + getElements (RecordType {rt_fields}) + = [ fs_name \\ {fs_name}<-:rt_fields ] + getElements _ + = [] + +check_completeness_of_module :: .Index [(.Declaration,.Int)] .String *(*{!.FunctionConsequence},*{#.DclModule},*{#FunDef},*ExpressionHeap,*CheckState) -> (.{!FunctionConsequence},.{#DclModule},.{#FunDef},.ExpressionHeap,.CheckState); +check_completeness_of_module mod_index dcls_explicit file_name (f_consequences, modules, icl_functions, expr_heap, cs) + # dcls_imp = [((dcl_ident, kind), (dcl_index, mod_index), (file_name, line_nr)) + \\ ({dcl_ident, dcl_index, dcl_kind=STE_Imported kind mod_index}, line_nr) <- dcls_explicit] + (conseqs, (f_consequences, modules, icl_functions, expr_heap)) + = seqList (map (consequences_of mod_index) dcls_imp) (f_consequences, modules, icl_functions, expr_heap) + conseqs = flatten conseqs + #! (modules, cs) = seq (map checkConsequenceError conseqs) (modules, cs) + = (f_consequences, modules, icl_functions, expr_heap, cs) + +consequences_of :: !Index + (!IdentWithKind, !(!Index,!Index), !(!String, !Int)) !(!*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap) + -> (![(!IdentWithKind, !IdentWithCKind, !(!String, !Int))], !(*{!FunctionConsequence}, !*{#DclModule}, !*{#FunDef}, !*ExpressionHeap)) +consequences_of count (expl_imp_ident_kind=:(_,expl_imp_kind), (dcl_index, mod_index), errMsgInfo) + (f_consequences, modules, icl_functions, expr_heap) + # (modul, modules) = modules![mod_index] + (consequences, (f_consequences, icl_functions, expr_heap)) + = case expl_imp_kind of + STE_FunctionOrMacro _ + -> consequences_of_macro count dcl_index f_consequences icl_functions expr_heap + _ + -> (consequences_of_simple_symbol expl_imp_kind modul dcl_index, (f_consequences, icl_functions,expr_heap)) + conseqs = removeDup consequences + = ([(expl_imp_ident_kind, conseq, errMsgInfo) \\ conseq<-conseqs], (f_consequences, modules, icl_functions, expr_heap)) + +consequences_of_macro count dcl_index f_consequences icl_functions expr_heap + # (icl_function, icl_functions) = icl_functions![dcl_index] + {fun_symb, fun_type, fun_body} = icl_function + result = consequences fun_body + = expand_functions_and_dynamics result [] (f_consequences, icl_functions, expr_heap) + where + expand_functions_and_dynamics [] akku unique_stuff + = (akku, unique_stuff) + expand_functions_and_dynamics [(_,CK_DynamicPatternType exprInfoPtr):t] akku (f_consequences, icl_functions, expr_heap) + # (conseqs, expr_heap) = expand_dynamic exprInfoPtr expr_heap + = expand_functions_and_dynamics t (conseqs++akku) (f_consequences, icl_functions, expr_heap) + expand_functions_and_dynamics [(ident,(CK_Function globIndex)):t] akku unique_stuff + # (conseqs, unique_stuff) = expand_function ident globIndex unique_stuff + = expand_functions_and_dynamics t (conseqs++akku) unique_stuff + expand_functions_and_dynamics [h:t] akku unique_stuff + = expand_functions_and_dynamics t [h:akku] unique_stuff + + expand_dynamic :: ExprInfoPtr *ExpressionHeap -> ([IdentWithCKind], *ExpressionHeap) + expand_dynamic exprInfoPtr expr_heap + // it is assumed, that the pointer structure from the fi_dynamics field (of record FunInfo) + // is a tree + # (exprInfo, expr_heap) = readPtr exprInfoPtr expr_heap + (conseqs, expr_heap) + = case exprInfo of + (EI_Dynamic No) + -> ([], expr_heap) + (EI_Dynamic (Yes dynamicType)) + -> (consequences dynamicType, expr_heap) + (EI_Dynamic (Yes dynamicType)) + -> (consequences dynamicType, expr_heap) + (EI_DynamicType dynamicType further_dynamic_ptrs) + # (further_conseqs, expr_heap) = expand_dynamics further_dynamic_ptrs [] expr_heap + -> (further_conseqs++consequences dynamicType, expr_heap) + (EI_DynamicTypeWithVars _ dynamicType further_dynamic_ptrs) + # (further_conseqs, expr_heap) = expand_dynamics further_dynamic_ptrs [] expr_heap + -> (further_conseqs++consequences dynamicType, expr_heap) + = (conseqs, expr_heap) + + expand_dynamics [] akku expr_heap + = (akku, expr_heap) + expand_dynamics [h:t] akku expr_heap + # (dyn, expr_heap) = expand_dynamic h expr_heap + = expand_dynamics t (dyn++akku) expr_heap + + + expand_function ident globIndex=:{glob_object,glob_module} (f_consequences, icl_functions, expr_heap) + | glob_module<>cIclModIndex // the function that is referred from within a macro is a DclFunction + // -> must be global -> is a consequence + = ([(ident, CK_Function globIndex)], (f_consequences, icl_functions, expr_heap)) + # (fun_def, icl_functions) = icl_functions![glob_object] + | fun_def.fun_info.fi_def_level==cGlobalScope // the function is defined in the icl module in the global scope + // -> it's not a consequence + = ([], (f_consequences, icl_functions, expr_heap)) + // otherwise the function was defined locally in a macro and stored in the IclModule object. + // it is not a consequence, but it's type and body are consequences ! + # (opt_f_consequences, f_consequences) = f_consequences![glob_object] + = case opt_f_consequences of + No # type_consequences = consequences fun_def.fun_type + body_consequences = consequences fun_def.fun_body + dynamic_pointers = fun_def.fun_info.fi_dynamics + # (dynamic_consequences, expr_heap) + = expand_dynamics dynamic_pointers [] expr_heap + f_consequences = { f_consequences & [glob_object]=Yes (count, No) } + (cons, (f_consequences, icl_functions, expr_heap)) + = expand_functions_and_dynamics body_consequences [] (f_consequences, icl_functions,expr_heap) + cons_of_function = type_consequences++cons++dynamic_consequences + f_consequences = { f_consequences & [glob_object]=Yes (count, Yes cons_of_function) } + -> (cons_of_function, (f_consequences, icl_functions, expr_heap)) + Yes (j, opt_consequences) + | j==count // the consequences of the function are already considered + -> ([], (f_consequences, icl_functions, expr_heap)) + Yes (j, Yes cons) + | j<count // always True + -> (cons, (f_consequences, icl_functions, expr_heap)) + +consequences_of_simple_symbol STE_Type {dcl_common} dcl_index + = consequences dcl_common.com_type_defs.[dcl_index] +consequences_of_simple_symbol STE_Constructor {dcl_common} dcl_index + = consequences dcl_common.com_cons_defs.[dcl_index] +consequences_of_simple_symbol STE_DclFunction {dcl_functions} dcl_index + = consequences dcl_functions.[dcl_index] +consequences_of_simple_symbol (STE_Field _) {dcl_common} dcl_index + = consequences dcl_common.com_selector_defs.[dcl_index] +consequences_of_simple_symbol STE_Class {dcl_common} dcl_index + = consequences dcl_common.com_class_defs.[dcl_index] +consequences_of_simple_symbol STE_Member {dcl_common} dcl_index + = consequences dcl_common.com_member_defs.[dcl_index] +consequences_of_simple_symbol STE_Instance {dcl_common} dcl_index + = consequences dcl_common.com_instance_defs.[dcl_index] + +checkConsequenceError (expl_imp_ident_kind, conseq_ident_kind=:(conseq_ident, conseq_kind), (file_name, line_nr)) + (modules, cs=:{cs_symbol_table, cs_error}) + # (c_ident, modules) + = case conseq_kind of + CK_Selector {glob_object,glob_module} // if a selector is a consequence of an imported macro the + # (modul, modules) = modules![glob_module] // it's FIELD has to be looked up + com_selector_def = modul.dcl_common.com_selector_defs.[glob_object.ds_index] + -> (com_selector_def.sd_field, modules) + _ -> (conseq_ident, modules) + ({ste_kind}, cs_symbol_table) = readPtr c_ident.id_info cs_symbol_table + cs_error + = case ste_kind of + STE_Empty + -> cError expl_imp_ident_kind + ( "explicitly imported without importing " + +++cIdent_kind_to_string conseq_ident_kind) + cs_error + _ -> cs_error + = (modules, { cs & cs_symbol_table=cs_symbol_table, cs_error=cs_error }) + where + ident_kind_to_string ({id_name}, kind) + = kind_to_string kind+++" "+++id_name + cIdent_kind_to_string ({id_name}, cKind) + = cKind_to_string cKind+++" "+++id_name + cError expl_imp_ident_kind=:(expl_ident,_) s2 cs_error + # identPos = { ip_ident = expl_ident, ip_line = line_nr, ip_file = file_name } + cs_error = pushErrorAdmin identPos cs_error + cs_error = checkError (ident_kind_to_string expl_imp_ident_kind) s2 cs_error + cs_error = popErrorAdmin cs_error + = cs_error + +kind_to_string (STE_FunctionOrMacro _) = "function" +kind_to_string STE_Type = "type" +kind_to_string STE_Constructor = "constructor" +kind_to_string (STE_Field _) = "field" +kind_to_string STE_Class = "class" +kind_to_string STE_Member = "member" +kind_to_string STE_Instance = "instance" +kind_to_string STE_DclFunction = "function" + +cKind_to_string (CK_Function _) = "function" +cKind_to_string CK_Macro = "macro" +cKind_to_string CK_Type = "type" +cKind_to_string CK_Constructor = "constructor" +cKind_to_string (CK_Selector _) = "appropriate record field" +cKind_to_string CK_Class = "class" + +class consequences x :: x -> [IdentWithCKind] + +instance consequences App + where consequences {app_symb, app_args} = consequences app_symb++consequences app_args + +instance consequences AlgebraicPattern + where consequences {ap_symbol, ap_expr} = [ (ap_symbol.glob_object.ds_ident, CK_Constructor) : consequences ap_expr] + +instance consequences AType + where + consequences {at_type} = consequences at_type + +instance consequences BasicPattern + where consequences {bp_expr} = consequences bp_expr + +instance consequences Case + where consequences { case_expr, case_guards, case_default, case_ident } + = consequences case_expr++consequences case_guards++consequences case_default + +instance consequences CasePatterns + where + consequences (AlgebraicPatterns _ algebraicPatterns) = consequences algebraicPatterns + consequences (BasicPatterns _ basicPatterns) = consequences basicPatterns + consequences (DynamicPatterns dynamicPatterns) = consequences dynamicPatterns + consequences NoPattern = [] + +instance consequences CheckedBody + where consequences {cb_rhs} = consequences cb_rhs + +instance consequences ClassDef + where + consequences {class_context} = consequences class_context + +instance consequences ClassInstance + where + consequences {ins_type} = consequences ins_type + +instance consequences ConsDef + where + consequences {cons_type} = consequences cons_type + +instance consequences DynamicPattern // the types, that are found via dp_type are checked later + where consequences { dp_rhs, dp_type } = [({ id_name="", id_info=nilPtr}, CK_DynamicPatternType dp_type): consequences dp_rhs] + +instance consequences DynamicExpr + where consequences { dyn_expr, dyn_opt_type } = consequences dyn_expr++consequences dyn_opt_type + +instance consequences DynamicType + where consequences { dt_type } = consequences dt_type + +instance consequences Expression + where + consequences (Var _) = [] + consequences (App app) = consequences app + consequences (expression @ expressions) = consequences expression++consequences expressions + consequences (Let let_) = consequences let_ + consequences (Case case_) = consequences case_ + consequences (Selection _ expression selections) = consequences expression++consequences selections + consequences (TupleSelect _ _ expression) = consequences expression + consequences (BasicExpr _ _) = [] + consequences (AnyCodeExpr _ _ _) = [] + consequences (ABCCodeExpr _ _) = [] + consequences (MatchExpr _ constructor expression) + = [(constructor.glob_object.ds_ident,CK_Constructor):consequences expression] + consequences (FreeVar _) = [] + consequences (DynamicExpr dynamicExpr) = consequences dynamicExpr + consequences EE = [] + +instance consequences FunctionBody + where consequences (CheckedBody body) = consequences body + consequences (TransformedBody body) = consequences body + // other alternatives should not occur + +instance consequences FunType + where + consequences {ft_type} = consequences ft_type + +instance consequences (Global x) | consequences x + where consequences { glob_object } = consequences glob_object + +instance consequences InstanceType + where + consequences {it_types, it_context} = consequences it_types++consequences it_context + +instance consequences Let + where consequences { let_binds, let_expr } + = consequences let_expr++(flatten [consequences bind_src \\ {bind_src}<-let_binds] ) + +instance consequences MemberDef + where + consequences {me_type} = consequences me_type + +instance consequences (Optional x) | consequences x + where consequences (Yes x) = consequences x + consequences No = [] + +instance consequences Selection + where consequences (RecordSelection globDefinedSymbol=:{glob_object={ds_ident}} _) + = [(ds_ident, CK_Selector globDefinedSymbol)] + consequences (ArraySelection {glob_object={ds_ident={id_name}}} _ _) + = [] + +instance consequences SelectorDef + where consequences {sd_type} = consequences sd_type + +instance consequences SymbIdent + where consequences {symb_name, symb_kind} + = case symb_kind of + SK_Constructor _ -> [(symb_name, CK_Constructor)] + SK_Function globalIndex -> [(symb_name, CK_Function globalIndex)] + SK_OverloadedFunction globalIndex + -> [(symb_name, CK_Function globalIndex)] + SK_Macro globalIndex -> [(symb_name, CK_Macro)] + _ -> [] + +instance consequences SymbolType + where + consequences {st_args, st_result, st_context} + = consequences st_args++consequences st_result++consequences st_context + +instance consequences TransformedBody + where consequences {tb_rhs} = consequences tb_rhs + +instance consequences Type + where + consequences (TA {type_name} arguments) + = [(type_name, CK_Type):consequences arguments] + consequences (l --> r) + = consequences l++consequences r + consequences (_ :@: arguments) + = consequences arguments + consequences _ + = [] + + +instance consequences TypeContext + where + consequences {tc_class= {glob_object={ds_ident}}, tc_types} + = [(ds_ident,CK_Class):consequences tc_types] + +instance consequences (TypeDef TypeRhs) // ==CheckedTypeDef + where + consequences {td_rhs, td_context} = consequences td_rhs++consequences td_context + +instance consequences TypeRhs + where + consequences (SynType aType) = consequences aType + consequences _ = [] + +instance consequences [a] | consequences a + where + consequences l = flatten (map consequences l) + |