diff options
-rw-r--r-- | frontend/check.icl | 54 | ||||
-rw-r--r-- | frontend/checksupport.icl | 12 | ||||
-rw-r--r-- | frontend/checktypes.icl | 34 |
3 files changed, 65 insertions, 35 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index d5b69e6..de7ede7 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -374,7 +374,7 @@ where = check_member_instances module_index member_mod_index (inc mem_offset) class_size ins_members class_members class_name ins_pos ins_type instance_types member_defs type_defs modules var_heap type_heaps { cs & cs_error = checkError class_member.ds_ident "used with wrong arity" cs.cs_error} - # ({me_type,me_class_vars}, member_defs, modules) = getMemberDef member_mod_index class_member.ds_index module_index member_defs modules + # ({me_type,me_class_vars,me_pos}, member_defs, modules) = getMemberDef member_mod_index class_member.ds_index module_index member_defs modules (instance_type, _, type_heaps, Yes cs_error) = determineTypeOfMemberInstance me_type me_class_vars ins_type SP_None type_heaps (Yes cs.cs_error) (type_defs, modules, cs_error) = checkTopLevelKinds x_main_dcl_module_n True ins_pos class_name instance_type type_defs modules cs_error (st_context, var_heap) = initializeContextVariables instance_type.st_context var_heap @@ -432,7 +432,7 @@ instantiateTypes old_type_vars old_attr_vars types type_contexts attr_env {ss_en _ -> case opt_error of No -> No Yes error_admin - -> Yes (checkError "" "instance type incompatible with class type" + -> Yes (checkError "instance type incompatible with class type" "" error_admin) // e.g.:class c a :: (a Int); instance c Real = (inst_vars, inst_attr_vars, inst_types, inst_contexts ++ new_ss_context, inst_attr_env, special_subst_list, { type_heaps & th_vars = th_vars }, opt_error) @@ -489,7 +489,7 @@ determineTypeOfMemberInstance mem_st class_vars {it_types,it_vars,it_attr_vars,i ss_context = it_context, ss_vars = it_vars, ss_attrs = it_attr_vars} (st, specials, type_heaps, opt_error) = determine_type_of_member_instance mem_st env specials type_heaps opt_error - = (st, specials, type_heaps, opt_error) + = (st, specials, type_heaps, opt_error) where determine_type_of_member_instance mem_st=:{st_context} env (SP_Substitutions substs) type_heaps opt_error # (mem_st, substs, type_heaps, opt_error) @@ -603,7 +603,7 @@ checkTopLevelKinds x_main_dcl_module_n is_icl_module ins_pos class_ident st=:{st # cs_error = pushErrorAdmin (newPosition class_ident ins_pos) cs_error cs_error - = checkError "" "instance types have wrong kind" cs_error + = checkError "instance types have wrong kind" "" cs_error -> popErrorAdmin cs_error = (type_defs, modules, cs_error) where @@ -983,13 +983,13 @@ where = add_macro_declaration id_info entry decl def_index (decl_index - first_macro_index) decl_index (conversion_table, icl_defs, cs_symbol_table) = ([ decl : moved_dcl_defs ], conversion_table, icl_sizes, icl_defs, { cs & cs_symbol_table = cs_symbol_table }) - # cs_error = checkError "definition module" "undefined in implementation module" (setErrorAdmin (newPosition decl_ident decl_pos) cs.cs_error) + # cs_error = checkError "undefined in implementation module" "" (setErrorAdmin (newPosition decl_ident decl_pos) cs.cs_error) = (moved_dcl_defs, conversion_table, icl_sizes, icl_defs, { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table }) | ste_def_level == cGlobalScope && ste_kind == decl_kind # def_index = toInt decl_kind decl_index = if (def_index == cMacroDefs) (decl_index - first_macro_index) decl_index = (moved_dcl_defs, { conversion_table & [def_index].[decl_index] = ste_index }, icl_sizes, icl_defs, { cs & cs_symbol_table = cs_symbol_table }) - # cs_error = checkError "definition module" "conflicting definition in implementation module" + # cs_error = checkError "conflicting definition in implementation module" "" (setErrorAdmin (newPosition decl_ident decl_pos) cs.cs_error) = (moved_dcl_defs, conversion_table, icl_sizes, icl_defs, { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table }) @@ -1030,7 +1030,7 @@ where (rt_fields, cs) = redirect_field_symbols td_pos rt_fields cs = ([ { td & td_rhs = RecordType { rt & rt_constructor = rt_constructor, rt_fields = rt_fields }} : new_type_defs ], cs) add_type_def td=:{td_name, td_pos, td_rhs = AbstractType _} new_type_defs cs - # cs_error = checkError "definition module" "abstract type not defined in implementation module" + # cs_error = checkError "abstract type not defined in implementation module" "" (setErrorAdmin (newPosition td_name td_pos) cs.cs_error) = (new_type_defs, { cs & cs_error = cs_error }) add_type_def td new_type_defs cs @@ -1045,7 +1045,7 @@ where ({ste_kind,ste_index}, cs_symbol_table) = readPtr field.fs_name.id_info cs.cs_symbol_table | is_field ste_kind = ({ new_fields & [field_nr] = { field & fs_index = ste_index }}, { cs & cs_symbol_table = cs_symbol_table }) - # cs_error = checkError "definition module" "conflicting definition in implementation module" + # cs_error = checkError "conflicting definition in implementation module" "" (setErrorAdmin (newPosition field.fs_name pos) cs.cs_error) = (new_fields, { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table }) @@ -1086,7 +1086,7 @@ where # ({ste_kind,ste_index}, cs_symbol_table) = readPtr ds_ident.id_info cs.cs_symbol_table | ste_kind == req_kind = ({ ds & ds_index = ste_index }, { cs & cs_symbol_table = cs_symbol_table }) - # cs_error = checkError "definition module" "conflicting definition in implementation module" + # cs_error = checkError "conflicting definition in implementation module" "" (setErrorAdmin (newPosition ds_ident pos) cs.cs_error) = ({ ds & ds_index = ste_index }, { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table }) @@ -1289,8 +1289,8 @@ checkDclComponent components_array super_components expl_imp_indices mod_indices cs_error = pushErrorAdmin ident_pos cs_error cs_error - = checkError "" - "cyclic module dependencies not allowed in conjunction with Clean 1.3 import syntax" + = checkError + "cyclic module dependencies not allowed in conjunction with Clean 1.3 import syntax" "" cs_error -> popErrorAdmin cs_error _ @@ -1730,7 +1730,14 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func (icl_functions, e_info, heaps, {cs_symbol_table, cs_predef_symbols, cs_error,cs_x }) = checkInstanceBodies icl_instance_range icl_functions e_info heaps cs - + + (icl_functions, hp_type_heaps, cs_error) + = // foldSt checkSpecifiedInstanceType instance_types + (icl_functions, heaps.hp_type_heaps, cs_error) + + heaps + = { heaps & hp_type_heaps = hp_type_heaps } + cs_symbol_table = removeDeclarationsFromSymbolTable local_defs cGlobalScope cs_symbol_table cs_symbol_table @@ -1947,6 +1954,29 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func = memcpy com_type_defs = (com_type_defs`, { icl_common & com_type_defs = com_type_defs }) + checkSpecifiedInstanceType (index_of_member_fun, derived_symbol_type) + (icl_functions, type_heaps, cs_error) + # ({fun_type, fun_pos, fun_symb}, icl_functions) + = icl_functions![index_of_member_fun] + (cs_error, type_heaps) + = case fun_type of + No + -> (cs_error, type_heaps) + Yes specified_symbol_type + # (symbol_types_correspond, type_heaps) + = symbolTypesCorrespond specified_symbol_type derived_symbol_type + type_heaps + | symbol_types_correspond + -> (cs_error, type_heaps) + # cs_error + = pushErrorAdmin (newPosition fun_symb fun_pos) + cs_error + cs_error + = checkError "the specified member type is incorrect" "" cs_error + -> ( popErrorAdmin cs_error, type_heaps) + = (icl_functions, type_heaps, cs_error) + + check_needed_modules_are_imported mod_name extension cs=:{cs_x={x_needed_modules}} //AA.. # cs = case x_needed_modules bitand cNeedStdGeneric of diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl index 2b289c7..fd82387 100644 --- a/frontend/checksupport.icl +++ b/frontend/checksupport.icl @@ -162,15 +162,15 @@ newPosition id NoPos checkError :: !a !b !*ErrorAdmin -> *ErrorAdmin | <<< a & <<< b // PK checkError id mess error=:{ea_file,ea_loc=[]} - = { error & ea_file = ea_file <<< "Error " <<< "\"" <<< id <<< "\" " <<< mess <<< '\n', ea_ok = False } + = { error & ea_file = ea_file <<< "Error " <<< " " <<< id <<< " " <<< mess <<< '\n', ea_ok = False } checkError id mess error=:{ea_file,ea_loc} - = { error & ea_file = ea_file <<< "Error " <<< hd ea_loc <<< ":\"" <<< id <<< "\" " <<< mess <<< '\n', ea_ok = False } + = { error & ea_file = ea_file <<< "Error " <<< hd ea_loc <<< ": " <<< id <<< " " <<< mess <<< '\n', ea_ok = False } checkWarning :: !a !b !*ErrorAdmin -> *ErrorAdmin | <<< a & <<< b // PK checkWarning id mess error=:{ea_file,ea_loc=[]} - = { error & ea_file = ea_file <<< "Warning " <<< "\"" <<< id <<< "\" " <<< mess <<< '\n' } + = { error & ea_file = ea_file <<< "Warning " <<< " " <<< id <<< " " <<< mess <<< '\n' } checkWarning id mess error=:{ea_file,ea_loc} - = { error & ea_file = ea_file <<< "Warning " <<< hd ea_loc <<< ":\"" <<< id <<< "\" " <<< mess <<< '\n' } + = { error & ea_file = ea_file <<< "Warning " <<< hd ea_loc <<< ": " <<< id <<< " " <<< mess <<< '\n' } checkErrorWithIdentPos :: !IdentPos !a !*ErrorAdmin -> .ErrorAdmin | <<< a; @@ -326,7 +326,7 @@ addDefToSymbolTable level def_index def_ident=:{id_info} def_kind symbol_table e | entry.ste_kind == STE_Empty || entry.ste_def_level <> level # entry = {ste_index = def_index, ste_kind = def_kind, ste_def_level = level, ste_previous = entry } = (symbol_table <:= (id_info,entry), error) - = (symbol_table, checkError def_ident " already defined" error) + = (symbol_table, checkError def_ident "already defined" error) addDeclarationsOfDclModToSymbolTable :: .Int !{!Declaration} !{!Declaration} !*CheckState -> .CheckState; addDeclarationsOfDclModToSymbolTable ste_index locals imported cs @@ -437,7 +437,7 @@ where -> addFieldToSelectorDefinition selector_id { glob_module = NoIndex, glob_object = decl_index } cs _ -> cs - = { cs & cs_error = checkErrorWithIdentPos (newPosition ident decl_pos) " multiply defined" cs.cs_error} + = { cs & cs_error = checkErrorWithIdentPos (newPosition ident decl_pos) "multiply defined" cs.cs_error} removeImportedSymbolsFromSymbolTable :: Declaration !*SymbolTable -> .SymbolTable removeImportedSymbolsFromSymbolTable (Declaration {decl_ident=decl_ident=:{id_info}, decl_index}) symbol_table diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index f14273f..a06a466 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -37,11 +37,11 @@ where check_type_attribute TA_Anonymous type_attr root_attr error | try_to_combine_attributes type_attr root_attr = (root_attr, error) - = (TA_Multi, checkError "" "conflicting attribution of type definition" error) + = (TA_Multi, checkError "conflicting attribution of type definition" "" error) check_type_attribute TA_Unique type_attr root_attr error | try_to_combine_attributes TA_Unique type_attr || try_to_combine_attributes TA_Unique root_attr = (TA_Unique, error) - = (TA_Multi, checkError "" "conflicting attribution of type definition" error) + = (TA_Multi, checkError "conflicting attribution of type definition" "" error) check_type_attribute (TA_Var var) _ _ error = (TA_Multi, checkError var "attribute variable not allowed" error) check_type_attribute (TA_RootVar var) _ _ error @@ -109,8 +109,8 @@ where = (TA { type_cons & type_index = { glob_object = type_index, glob_module = type_module}} types, cti_lhs_attribute, ts_ti_cs) = (TA { type_cons & type_index = { glob_object = type_index, glob_module = type_module}} types, determine_type_attribute td_attribute, ts_ti_cs) - = (TE /* JVG was: type */, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_name " used with wrong arity" cs.cs_error })) - = (TE /* JVG was: type */, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_name " undefined" cs.cs_error})) + = (TE /* JVG was: type */, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_name "used with wrong arity" cs.cs_error })) + = (TE /* JVG was: type */, TA_Multi, (ts, ti, { cs & cs_error = checkError type_cons.type_name "undefined" cs.cs_error})) where determine_type_attribute TA_Unique = TA_Unique determine_type_attribute _ = TA_Multi @@ -139,7 +139,7 @@ addToAttributeEnviron (TA_Var attr_var) (TA_Var root_var) attr_env error addToAttributeEnviron (TA_RootVar attr_var) root_attr attr_env error = (attr_env, error) addToAttributeEnviron _ _ attr_env error - = (attr_env, checkError "" "inconsistent attribution of type definition" error) + = (attr_env, checkError "inconsistent attribution of type definition" "" error) bindTypesOfConstructors :: !CurrentTypeInfo !Index ![TypeVar] ![AttributeVar] !AType ![DefinedSymbol] !(!*TypeSymbols,!*TypeInfo,!*CheckState) -> (!*TypeSymbols, !*TypeInfo, !*CheckState) @@ -718,7 +718,7 @@ checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_de where check_fully_polymorphity it_types it_context cs_error | all is_type_var it_types && not (isEmpty it_context) - = checkError "" "context restriction not allowed for fully polymorph instance" cs_error + = checkError "context restriction not allowed for fully polymorph instance" "" cs_error = cs_error where is_type_var (TV _) = True @@ -862,7 +862,7 @@ checkTypeContext mod_index tc=:{tc_class=tc_class=:{glob_object=class_name=:{ds_ = (tc, (class_defs, ots, oti, { cs & cs_error = checkError id_name "undefined" cs.cs_error })) where check_context_types tc_class [] cs=:{cs_error} - = { cs & cs_error = checkError tc_class " type context should contain one or more type variables" cs_error} + = { cs & cs_error = checkError tc_class "type context should contain one or more type variables" cs_error} check_context_types tc_class [TV _ : types] cs = cs check_context_types tc_class [type : types] cs @@ -881,14 +881,14 @@ where where check_class_variable {tv_name} cs=:{cs_symbol_table,cs_error} = { cs & cs_symbol_table = removeDefinitionFromSymbolTable cGlobalScope tv_name cs_symbol_table, - cs_error = checkError tv_name " not defined or defined as class variable" cs_error} + cs_error = checkError tv_name "wrongly used or not used at all" cs_error} check_class_attributes class_attributes cs = foldSt check_class_attribute class_attributes cs where check_class_attribute {av_name} cs=:{cs_symbol_table,cs_error} = { cs & cs_symbol_table = removeDefinitionFromSymbolTable cGlobalScope av_name cs_symbol_table, - cs_error = checkError av_name " undefined" cs_error} + cs_error = checkError av_name "undefined" cs_error} checkDynamicTypes :: !Index ![ExprInfoPtr] !(Optional SymbolType) !u:{# CheckedTypeDef} !u:{# DclModule} !*TypeHeaps !*ExpressionHeap !*CheckState @@ -959,7 +959,7 @@ where | entry.ste_kind == STE_Empty = { cs & cs_symbol_table = cs_symbol_table } = { cs & cs_symbol_table = cs_symbol_table <:= (id_info, entry.ste_previous), - cs_error = checkError tv_name.id_name " global type variable not used in type of the function" cs_error } + cs_error = checkError tv_name.id_name "global type variable not used in type of the function" cs_error } checkDynamics mod_index scope dyn_type_ptrs type_defs modules type_heaps expr_heap cs = foldSt (check_dynamic mod_index scope) dyn_type_ptrs (type_defs, modules, type_heaps, expr_heap, cs) @@ -974,7 +974,7 @@ where | isEmpty loc_type_vars -> (type_defs, modules, type_heaps, expr_heap <:= (dyn_info_ptr, EI_Dynamic (Yes dyn_type)), cs) # cs_symbol_table = removeVariablesFromSymbolTable scope loc_type_vars cs.cs_symbol_table - cs_error = checkError loc_type_vars " type variable(s) not defined" cs.cs_error + cs_error = checkError loc_type_vars "type variable(s) not defined" cs.cs_error -> (type_defs, modules, type_heaps, expr_heap <:= (dyn_info_ptr, EI_Dynamic (Yes dyn_type)), { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table }) No @@ -1004,7 +1004,7 @@ where # cs_symbol_table = removeAttributesFromSymbolTable oti_all_attrs cs_symbol_table = ({ dt & dt_uni_vars = dt_uni_vars, dt_global_vars = oti_global_vars, dt_type = dt_type }, oti_all_vars, ots_type_defs, ots_modules, { oti_heaps & th_vars = th_vars }, - { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError (hd oti_all_attrs).av_name " type attribute variable not allowed" cs.cs_error}) + { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError (hd oti_all_attrs).av_name "type attribute variable not allowed" cs.cs_error}) add_type_variable_to_symbol_table :: !Level !ATypeVar !*(!*TypeVarHeap,!*CheckState) -> (!ATypeVar,!(!*TypeVarHeap, !*CheckState)) add_type_variable_to_symbol_table scope atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute} (type_var_heap, cs=:{cs_symbol_table,cs_error}) @@ -1016,7 +1016,7 @@ where (var_info, {ste_index = NoIndex, ste_kind = STE_TypeVariable new_var_ptr, ste_def_level = scope, ste_previous = var_entry }) = ({atv & atv_attribute = TA_Multi, atv_variable = { atv_variable & tv_info_ptr = new_var_ptr }}, (type_var_heap, { cs & cs_symbol_table = cs_symbol_table, cs_error = check_attribute atv_attribute cs_error})) - = (atv, (type_var_heap, { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError tv_name.id_name " type variable already defined" cs_error })) + = (atv, (type_var_heap, { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError tv_name.id_name "type variable already defined" cs_error })) check_attribute TA_Unique error = error @@ -1025,7 +1025,7 @@ where check_attribute TA_None error = error check_attribute attr error - = checkError attr " attribute not allowed in type of dynamic" error + = checkError attr "attribute not allowed in type of dynamic" error checkSpecialTypeVars :: !Specials !*CheckState -> (!Specials, !*CheckState) @@ -1038,7 +1038,7 @@ where | ste_kind <> STE_Empty && ste_def_level == cGlobalScope # (STE_TypeVariable tv_info_ptr) = ste_kind = ({ bind & bind_dst = { type_var & tv_info_ptr = tv_info_ptr}}, { cs & cs_symbol_table = cs_symbol_table }) - = (bind, { cs & cs_symbol_table= cs_symbol_table, cs_error = checkError id_name " type variable not defined" cs_error }) + = (bind, { cs & cs_symbol_table= cs_symbol_table, cs_error = checkError id_name "type variable not defined" cs_error }) checkSpecialTypeVars SP_None cs = (SP_None, cs) /* @@ -1115,7 +1115,7 @@ where = ({atv & atv_variable = atv_variable, atv_attribute = atv_attribute}, (attr_vars, heaps, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error /* TD ... */, cs_x = {cs.cs_x & x_type_var_position = inc x_type_var_position} /* ... TD */})) = (atv, (attr_vars, { heaps & th_vars = th_vars }, - { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError tv_name.id_name " type variable already defined" cs_error /* TD ... */, cs_x = {cs.cs_x & x_type_var_position = inc x_type_var_position} /* ... TD */})) + { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError tv_name.id_name "type variable already defined" cs_error /* TD ... */, cs_x = {cs.cs_x & x_type_var_position = inc x_type_var_position} /* ... TD */})) check_attribute :: !TypeAttribute !String ![AttributeVar] !*AttrVarHeap !*ErrorAdmin -> (!TypeAttribute, ![AttributeVar], !*AttrVarHeap, !*ErrorAdmin) @@ -1154,7 +1154,7 @@ where = ({atv & atv_variable = atv_variable, atv_attribute = atv_attribute}, (heaps, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error /* TD ... */, cs_x = {cs.cs_x & x_type_var_position = inc x_type_var_position} /* ... TD */ })) = (atv, ({ heaps & th_vars = th_vars }, - { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError tv_name.id_name " type variable already defined" cs_error /* TD ... */, cs_x = {cs.cs_x & x_type_var_position = inc x_type_var_position} /* ... TD */})) + { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError tv_name.id_name "type variable already defined" cs_error /* TD ... */, cs_x = {cs.cs_x & x_type_var_position = inc x_type_var_position} /* ... TD */})) check_attribute :: !TypeAttribute !TypeAttribute !String !*ErrorAdmin -> (!TypeAttribute, !*ErrorAdmin) |