Commit e6ded727 authored by John van Groningen's avatar John van Groningen
Browse files

refactor check error function calls, add checkErrorIdentWithIdentPos and...

refactor check error function calls, add checkErrorIdentWithIdentPos and checkErrorIdentWithPosition, use these instead of a check error function and newPosition, pushErrorAdmin + popErrorAdmin or setErrorAdmin
parent 4f596a2c
......@@ -1275,8 +1275,7 @@ checkLeftRootAttributionOfTypeDef common_defs {gi_module,gi_index} (td_infos, th
# (is_unique, (td_infos, th_vars))
= isUniqueTypeRhs common_defs gi_module td_rhs (td_infos, th_vars)
| is_unique
= (td_infos, th_vars, checkErrorWithIdentPos (newPosition td_ident td_pos)
" left root * attribute expected" error)
= (td_infos, th_vars, checkErrorWithPosition td_ident td_pos " left root * attribute expected" error)
= (td_infos, th_vars, error)
isUniqueTypeRhs common_defs mod_index (AlgType constructors) state
......
......@@ -374,7 +374,7 @@ where
# {ins_pos,ins_class_index,ins_members,ins_type,ins_member_types_and_functions} = instance_def
# ({class_members,class_ident}, class_defs, modules) = getClassDef ins_class_index x_main_dcl_module_n class_defs modules
| size class_members==0
# cs & cs_error = checkErrorWithIdentPos (newPosition class_ident ins_pos) "instance for class without members specified" cs.cs_error
# cs & cs_error = checkErrorWithPosition class_ident ins_pos "instance for class without members specified" cs.cs_error
= check_icl_instances (inc inst_index) instance_types n_icl_functions new_instance_members instance_defs class_defs member_defs generic_defs type_defs icl_functions modules var_heap type_heaps cs
# (ins_members,ins_member_types_and_functions,instance_types,n_icl_functions,new_instance_members,member_defs,type_defs,icl_functions,modules,var_heap,type_heaps,cs)
= check_icl_instance_members 0 0 ins_class_index.gi_module ins_members ins_member_types_and_functions class_members class_ident ins_pos ins_type
......@@ -931,7 +931,7 @@ where
ins_type ins_specials class_ident ins_pos member_defs modules type_heaps var_heap cs_error
| mem_offset == class_size
| class_size==0
# cs_error = checkErrorWithIdentPos (newPosition class_ident ins_pos) "instance for class without members specified" cs_error
# cs_error = checkErrorWithPosition class_ident ins_pos "instance for class without members specified" cs_error
= ([], [], member_defs, modules, type_heaps, var_heap, cs_error)
= ([], [], member_defs, modules, type_heaps, var_heap, cs_error)
# class_member = class_members.[mem_offset]
......@@ -1624,7 +1624,7 @@ reorder_array array index_array
= {new_array & [index_array.[i]]=e \\ e<-:array & i<-[0..]}
add_conflicting_definition_error decl_ident decl_pos error_admin
= checkError "conflicting definition in implementation module" "" (setErrorAdmin (newPosition decl_ident decl_pos) error_admin)
= checkErrorWithPosition decl_ident decl_pos "conflicting definition in implementation module" error_admin
combineDclAndIclModule :: ModuleKind *{#DclModule} [Declaration] (CollectedDefinitions a) *{#Int} *CheckState
-> (!CopiedDefinitions,!*Optional *{#*{#Int}},!*{#DclModule},![Declaration],!CollectedDefinitions a, !*{#Int}, !*CheckState);
......@@ -1715,7 +1715,7 @@ where
# (conversion_table, icl_sizes, icl_defs, cs_symbol_table)
= add_dcl_declaration id_info entry decl def_index decl_index (conversion_table, icl_sizes, icl_defs, cs_symbol_table)
= ([ decl : moved_dcl_defs ],dcl_cons_and_member_defs,conversion_table, icl_sizes, icl_defs, { cs & cs_symbol_table = cs_symbol_table })
# cs_error = checkError "undefined in implementation module" "" (setErrorAdmin (newPosition decl_ident decl_pos) cs.cs_error)
# cs_error = checkErrorWithPosition decl_ident decl_pos "undefined in implementation module" cs.cs_error
= (moved_dcl_defs,dcl_cons_and_member_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
......@@ -1785,14 +1785,14 @@ where
({ste_kind,ste_index}, cs_symbol_table) = readPtr field.fs_ident.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 "conflicting definition in implementation module" "" (setErrorAdmin (newPosition field.fs_ident pos) cs.cs_error)
# cs_error = checkErrorWithPosition field.fs_ident pos "conflicting definition in implementation module" cs.cs_error
= (new_fields, { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table })
is_field (STE_Field _) = True
is_field _ = False
abstract_type_error td_ident td_pos error
= checkError "abstract type not defined in implementation module" "" (setErrorAdmin (newPosition td_ident td_pos) error)
= checkErrorWithPosition td_ident td_pos "abstract type not defined in implementation module" error
add_dcl_definition {com_selector_defs} dcl=:(Declaration {decl_kind = STE_Field _, decl_index})
(new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, new_generic_defs, copied_defs, conversion_table, icl_sizes, icl_decl_symbols, cs)
= (new_type_defs, new_class_defs, new_cons_defs, [ com_selector_defs.[decl_index] : new_selector_defs ], new_member_defs, new_generic_defs, copied_defs, conversion_table, icl_sizes, icl_decl_symbols, cs)
......@@ -1859,7 +1859,7 @@ where
# icl_defs = [ Declaration { decl_ident=ds_ident,decl_index=icl_index,decl_kind=req_kind,decl_pos=pos} : icl_defs ]
# cs_symbol_table = NewEntry cs_symbol_table id_info req_kind icl_index cGlobalScope entry
= (ds_index,{ ds & ds_index = icl_index }, (conversion_table,icl_sizes,icl_defs,{ cs & cs_symbol_table = cs_symbol_table }))
# cs_error = checkError "conflicting definition in implementation module" "" (setErrorAdmin (newPosition ds_ident pos) cs.cs_error)
# cs_error = checkErrorWithPosition ds_ident pos "conflicting definition in implementation module" cs.cs_error
= (-1,{ ds & ds_index = ste_index }, (conversion_table,icl_sizes,icl_defs,{ cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table }))
add_all_dcl_cons_and_members_to_conversion_table dcl_common decl=:(Declaration {decl_ident=decl_ident=:{id_info},decl_kind=STE_Constructor,decl_index,decl_pos}) (new_cons_defs,new_member_defs,conversion_table,icl_sizes,icl_defs,symbol_table,errors)
......@@ -1870,7 +1870,7 @@ where
# (conversion_table,icl_sizes,icl_defs,symbol_table)
= add_dcl_declaration id_info entry decl cConstructorDefs decl_index (conversion_table,icl_sizes,icl_defs,symbol_table)
= ([dcl_common.com_cons_defs.[decl_index] : new_cons_defs],new_member_defs,conversion_table,icl_sizes,icl_defs,symbol_table,errors)
# errors = checkErrorWithIdentPos (newPosition decl_ident decl_pos) " constructor already defined" errors
# errors = checkErrorWithPosition decl_ident decl_pos " constructor already defined" errors
= (new_cons_defs,new_member_defs,conversion_table,icl_sizes,icl_defs,symbol_table,errors)
add_all_dcl_cons_and_members_to_conversion_table dcl_common decl=:(Declaration {decl_ident=decl_ident=:{id_info},decl_kind=STE_Member,decl_index,decl_pos}) (new_cons_defs,new_member_defs,conversion_table,icl_sizes,icl_defs,symbol_table,errors)
| conversion_table.[cMemberDefs].[decl_index]>=0
......@@ -1880,7 +1880,7 @@ where
# (conversion_table,icl_sizes,icl_defs,symbol_table)
= add_dcl_declaration id_info entry decl cMemberDefs decl_index (conversion_table,icl_sizes,icl_defs,symbol_table)
= (new_cons_defs,[dcl_common.com_member_defs.[decl_index] : new_member_defs],conversion_table,icl_sizes,icl_defs,symbol_table,errors)
# errors = checkErrorWithIdentPos (newPosition decl_ident decl_pos) " member already defined" errors
# errors = checkErrorWithPosition decl_ident decl_pos " member already defined" errors
= (new_cons_defs,new_member_defs,conversion_table,icl_sizes,icl_defs,symbol_table,errors)
my_append front []
......@@ -1909,7 +1909,7 @@ where
(function_conversion_table,macro_conversion_table,icl_defs,cs)
# (entry=:{ste_kind,ste_index,ste_def_level}, cs_symbol_table) = readPtr id_info cs.cs_symbol_table
| ste_kind == STE_Empty
# cs_error = checkError "undefined in implementation module" "" (setErrorAdmin (newPosition decl_ident decl_pos) cs.cs_error)
# cs_error = checkErrorWithPosition decl_ident decl_pos "undefined in implementation module" cs.cs_error
= (function_conversion_table,macro_conversion_table,icl_defs,{cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table})
| ste_def_level == cGlobalScope && case ste_kind of
STE_FunctionOrMacro _
......@@ -2210,8 +2210,7 @@ checkDclComponent components_importing_module_a expl_imp_indices mod_indices
where
check_that mod_index {ei_module_n=imported_mod_index, ei_position} cs_error
| mod_index==imported_mod_index
= checkErrorWithIdentPos (newPosition import_ident ei_position)
"a dcl module cannot import from itself" cs_error
= checkErrorWithPosition import_ident ei_position "a dcl module cannot import from itself" cs_error
= cs_error
collect_expl_imp_info component_nr mod_indices (expl_imp_infos, dcl_modules, cs)
......@@ -2539,7 +2538,7 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra
| icl_generic_info<>dcl_generic_info
# {gc_gcf=GCF gcf_ident _,gc_type_cons,gc_pos} = icl_gencase
error_message = "different generic info for "+++type_cons_to_string gc_type_cons+++" in implementation and definition module"
error = checkErrorWithIdentPos (newPosition gcf_ident gc_pos) error_message error
error = checkErrorWithPosition gcf_ident gc_pos error_message error
= (icl_gencases, error)
= case (dcl_generic_instance_deps,icl_generic_instance_deps) of
(AllGenericInstanceDependencies,AllGenericInstanceDependencies)
......@@ -2551,7 +2550,7 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra
(_,AllGenericInstanceDependencies)
# {gc_gcf=GCF gcf_ident _,gc_type_cons,gc_pos} = dcl_gencase
error_message = "restricting dependent generic functions not allow for type "+++type_cons_to_string gc_type_cons
error = checkErrorWithIdentPos (newPosition gcf_ident gc_pos) error_message error
error = checkErrorWithPosition gcf_ident gc_pos error_message error
-> (icl_gencases, error)
(GenericInstanceDependencies dcl_n_deps dcl_deps,GenericInstanceUsedArgs icl_n_deps icl_deps)
| icl_n_deps==dcl_n_deps
......@@ -2587,7 +2586,7 @@ renumber_icl_module_functions mod_type icl_global_function_range icl_instance_ra
different_restriction_error icl_gencase error
# {gc_gcf=GCF gcf_ident _,gc_type_cons,gc_pos} = icl_gencase
error_message = "different restriction of dependent generic functions for "+++type_cons_to_string gc_type_cons+++" in implementation and definition module"
= checkErrorWithIdentPos (newPosition gcf_ident gc_pos) error_message error
= checkErrorWithPosition gcf_ident gc_pos error_message error
build_conversion_table_for_generic_superclasses [!{gcf_body=GCB_FunIndex dcl_fun}:dcl_gcfs!] [!{gcf_body=GCB_FunIndex icl_fun}:icl_gcfs!] new_table
# new_table = {new_table & [dcl_fun] = icl_fun}
......@@ -3113,12 +3112,10 @@ check_module2 mod_ident mod_modification_time mod_imported_objects mod_imports m
STE_Imported STE_DclFunction mod_index
-> { cs & cs_predef_symbols.[PD_Start] = { pds_def = ste_index, pds_module = mod_index }}
_
-> case mod_kind of
MK_Main
# pos = newPosition predefined_idents.[PD_Start] (LinePos (mod_ident.id_name+++".icl") 1)
-> { cs & cs_error = checkErrorWithIdentPos pos " has not been declared" cs.cs_error }
_
-> cs
| mod_kind=:MK_Main
-> {cs & cs_error = checkErrorWithPosition predefined_idents.[PD_Start]
(LinePos (mod_ident.id_name+++".icl") 1) " has not been declared" cs.cs_error}
-> cs
check_predefined_module (Yes {mod_ident={id_info}}) support_dynamics modules macro_defs heaps cs=:{cs_symbol_table}
# (entry, cs_symbol_table) = readPtr id_info cs_symbol_table
......@@ -3273,9 +3270,9 @@ checkForeignExports [{pfe_ident=pfe_ident=:{id_name,id_info},pfe_line,pfe_file,p
-> ([],cs)
Yes {st_args,st_args_strictness,st_arity,st_result,st_context}
| not (isEmpty st_context)
-> ([],{cs & cs_error = checkErrorWithIdentPos (newPosition fun_ident fun_pos) "error in type of foreign exported function (context not allowed)" cs.cs_error})
-> ([],{cs & cs_error = checkErrorWithPosition fun_ident fun_pos "error in type of foreign exported function (context not allowed)" cs.cs_error})
| not (first_n_are_strict st_arity st_args_strictness)
-> ([],{cs & cs_error = checkErrorWithIdentPos (newPosition fun_ident fun_pos) "error in type of foreign exported function (strictness annotation missing)" cs.cs_error})
-> ([],{cs & cs_error = checkErrorWithPosition fun_ident fun_pos "error in type of foreign exported function (strictness annotation missing)" cs.cs_error})
-> ([{fe_fd_index=ste_index,fe_stdcall=pfe_stdcall}],cs)
= (foreign_export_fundef_index,fun_defs,cs)
check_foreign_export (STE_FunctionOrMacro _) [_,{ir_from, ir_to}:_] fun_defs cs
......@@ -3295,10 +3292,10 @@ checkForeignExportedFunctionTypes :: ![ForeignExport] !*ErrorAdmin !*{#FunDef}
-> (!*ErrorAdmin,!*{#FunDef})
checkForeignExportedFunctionTypes [{fe_fd_index}:icl_foreign_exports] error_admin fun_defs
| not (check_foreign_export_type st_result.at_type)
# error_admin = checkErrorWithIdentPos (newPosition fun_ident fun_pos) "error in result type for foreign exported function" error_admin
# error_admin = checkErrorWithPosition fun_ident fun_pos "error in result type for foreign exported function" error_admin
= checkForeignExportedFunctionTypes icl_foreign_exports error_admin fun_defs2
| not (check_foreign_export_types st_args)
# error_admin = checkErrorWithIdentPos (newPosition fun_ident fun_pos) "error in argument type for foreign exported function" error_admin
# error_admin = checkErrorWithPosition fun_ident fun_pos "error in argument type for foreign exported function" error_admin
= checkForeignExportedFunctionTypes icl_foreign_exports error_admin fun_defs2
= checkForeignExportedFunctionTypes icl_foreign_exports error_admin fun_defs2
where
......@@ -3334,7 +3331,7 @@ checkForeignExportedFunctionTypes [] error_admin fun_defs
check_dynamics_used_without_support_dynamics support_dynamics mod_ident cs
| not support_dynamics && (cs.cs_x.x_needed_modules bitand cNeedStdDynamic)<>0
# error_location = { ip_ident = {id_name="",id_info=nilPtr}/*mod_ident*/, ip_line = 1, ip_file = mod_ident.id_name+++".icl"}
= {cs & cs_error = popErrorAdmin (checkError "" ("dynamic used but support for dynamics not enabled") (pushErrorAdmin error_location cs.cs_error))}
= {cs & cs_error = checkErrorWithIdentPos error_location "dynamic used but support for dynamics not enabled" cs.cs_error}
= cs
check_needed_modules_are_imported mod_ident extension cs=:{cs_x={x_needed_modules}}
......@@ -3365,9 +3362,7 @@ check_needed_modules_are_imported mod_ident extension cs=:{cs_x={x_needed_module
missing_import_error pd mod_ident explanation extension cs
# pds_ident = predefined_idents.[pd]
error_location = { ip_ident = mod_ident, ip_line = 1, ip_file = mod_ident.id_name+++extension}
cs_error = pushErrorAdmin error_location cs.cs_error
cs_error = checkError pds_ident ("not imported"+++explanation) cs_error
cs_error = popErrorAdmin cs_error
cs_error = checkErrorIdentWithIdentPos error_location pds_ident ("not imported"+++explanation) cs.cs_error
= { cs & cs_error = cs_error }
arrayFunOffsetToPD_IndexTable :: !w:{# MemberDef} !v:{# PredefinedSymbol} -> (!{# Index}, !x:{#MemberDef}, !v:{#PredefinedSymbol}) , [w<=x]
......
......@@ -185,9 +185,9 @@ overlapping_instance_error :: !Int !Int !(Global Int) !{#CommonDefs} !*ErrorAdmi
// almost same function as in module type
overlapping_instance_error new_ins_module new_ins_index instance_index common_defs error
# {ins_ident,ins_pos} = common_defs.[new_ins_module].com_instance_defs.[new_ins_index]
error = checkErrorWithIdentPos (newPosition ins_ident ins_pos) " instance is overlapping with the instance in the next error" error
error = checkErrorWithPosition ins_ident ins_pos " instance is overlapping with the instance in the next error" error
{ins_ident,ins_pos} = common_defs.[instance_index.glob_module].com_instance_defs.[instance_index.glob_object]
= checkErrorWithIdentPos (newPosition ins_ident ins_pos) " instance is overlapping with the instance in the previous error" error
= checkErrorWithPosition ins_ident ins_pos " instance is overlapping with the instance in the previous error" error
unify_instances :: ![Type] ![Type] !{#CommonDefs} [(TypeVarInfoPtr,TypeVarInfo)] !*TypeVarHeap -> (!Bool,[(TypeVarInfoPtr,TypeVarInfo)],!*TypeVarHeap)
unify_instances [t1 : ts1] [t2 : ts2] common_defs subst tvh
......
......@@ -69,8 +69,14 @@ stringPosition :: !String !Position -> StringPos
checkError :: !a !b !*ErrorAdmin -> *ErrorAdmin | <<< a & <<< b
special a={#Char},b={#Char}; a=Ident,b={#Char}
checkWarning :: !a !b !*ErrorAdmin -> *ErrorAdmin | <<< a & <<< b
checkErrorWithIdentPos :: !IdentPos !a !*ErrorAdmin -> .ErrorAdmin | <<< a;
checkErrorWithPosition :: !Ident !Position !a !*ErrorAdmin -> .ErrorAdmin | <<< a;
checkErrorIdentWithIdentPos :: !IdentPos !Ident !a !*ErrorAdmin -> .ErrorAdmin | <<< a
special a={#Char};
checkErrorIdentWithPosition :: !Ident !Position !Ident !a !*ErrorAdmin -> .ErrorAdmin | <<< a
special a={#Char};
checkErrorWithIdentPos :: !IdentPos !a !*ErrorAdmin -> .ErrorAdmin | <<< a
special a={#Char};
checkErrorWithPosition :: !Ident !Position !a !*ErrorAdmin -> .ErrorAdmin | <<< a
special a={#Char};
checkStringErrorWithPosition :: !{#Char} !Position !a !*ErrorAdmin -> *ErrorAdmin | <<< a
special a={#Char};
checkWarningWithPosition :: !Ident !Position !a !*ErrorAdmin -> .ErrorAdmin | <<< a;
......
......@@ -78,6 +78,15 @@ checkWarning id mess error=:{ea_file,ea_loc=[]}
checkWarning id mess error=:{ea_file,ea_loc}
= { error & ea_file = ea_file <<< "Warning " <<< hd ea_loc <<< ": " <<< id <<< " " <<< mess <<< '\n' }
checkErrorIdentWithIdentPos :: !IdentPos !Ident !a !*ErrorAdmin -> .ErrorAdmin | <<< a;
checkErrorIdentWithIdentPos ident_pos id mess error=:{ea_file}
= { error & ea_file = ea_file <<< "Error " <<< ident_pos <<< ": " <<< id <<< ' ' <<< mess <<< '\n', ea_ok = False }
checkErrorIdentWithPosition :: !Ident !Position !Ident !a !*ErrorAdmin -> .ErrorAdmin | <<< a;
checkErrorIdentWithPosition ident pos id mess error=:{ea_file}
# ident_pos = newPosition ident pos
= { error & ea_file = ea_file <<< "Error " <<< ident_pos <<< ": " <<< id <<< ' ' <<< mess <<< '\n', ea_ok = False }
checkErrorWithIdentPos :: !IdentPos !a !*ErrorAdmin -> .ErrorAdmin | <<< a;
checkErrorWithIdentPos ident_pos mess error=:{ea_file}
= { error & ea_file = ea_file <<< "Error " <<< ident_pos <<< ": " <<< mess <<< '\n', ea_ok = False }
......@@ -406,7 +415,7 @@ where
-> addFieldToSelectorDefinition selector_id { glob_module = NoIndex, glob_object = decl_index } cs
_
-> cs
= { cs & cs_symbol_table = cs_symbol_table, cs_error = checkErrorWithIdentPos (newPosition ident decl_pos) "multiply defined" cs.cs_error}
= { cs & cs_symbol_table = cs_symbol_table, cs_error = checkErrorWithPosition ident decl_pos "multiply defined" cs.cs_error}
removeImportedSymbolsFromSymbolTable :: Declaration !*SymbolTable -> .SymbolTable
removeImportedSymbolsFromSymbolTable (Declaration {decl_ident=decl_ident=:{id_info}, decl_index}) symbol_table
......
......@@ -32,10 +32,10 @@ where
# dcl_class = dcl_class_defs.[dcl_class_index]
# icl_class = com_class_defs.[icl_class_index]
| size icl_class.class_members<>size dcl_class.class_members
# cs_error = checkError "different number of members in class definitions in implementation and definition module" "" (setErrorAdmin (newPosition icl_class.class_ident icl_class.class_pos) cs.cs_error)
# cs_error = checkErrorWithPosition icl_class.class_ident icl_class.class_pos "different number of members in class definitions in implementation and definition module" cs.cs_error
= {cs & cs_error=cs_error}
| size icl_class.class_macro_members<>size dcl_class.class_macro_members
# cs_error = checkError "different number of macro members in class definitions in implementation and definition module" "" (setErrorAdmin (newPosition icl_class.class_ident icl_class.class_pos) cs.cs_error)
# cs_error = checkErrorWithPosition icl_class.class_ident icl_class.class_pos "different number of macro members in class definitions in implementation and definition module" cs.cs_error
= {cs & cs_error=cs_error}
= check_member_names_of_exported_class 0 icl_class.class_members dcl_class.class_members icl_class.class_pos n_specified_icl_members member_conversion_table cs
......@@ -48,7 +48,7 @@ where
# converted_dcl_index = member_conversion_table.[dcl_index];
| converted_dcl_index<0 || converted_dcl_index>=n_specified_icl_members
# dcl_ident = dcl_class_members.[member_n].ds_ident
# cs & cs_error = checkError "member of exported class missing in implementation module" "" (setErrorAdmin (newPosition dcl_ident icl_class_pos) cs.cs_error)
# cs & cs_error = checkErrorWithPosition dcl_ident icl_class_pos "member of exported class missing in implementation module" cs.cs_error
= check_member_names_of_exported_class (member_n+1) icl_class_members dcl_class_members icl_class_pos n_specified_icl_members member_conversion_table cs
= check_member_names_of_exported_class (member_n+1) icl_class_members dcl_class_members icl_class_pos n_specified_icl_members member_conversion_table cs
= cs
......@@ -66,8 +66,8 @@ class_def_error = "class definition in the impl module conflicts with the def m
instance_def_error = "instance definition in the impl module conflicts with the def module"
generic_def_error = "generic definition in the impl module conflicts with the def module"
compareError message pos error_admin
= popErrorAdmin (checkError "" message (pushErrorAdmin pos error_admin))
compareError message ident pos error_admin
= checkErrorWithPosition ident pos message error_admin
compareTypeDefs :: !{# Int} !{#Bool} !{# CheckedTypeDef} !{# ConsDef} !u:{# CheckedTypeDef} !v:{# ConsDef} !*CompareState
-> (!u:{# CheckedTypeDef}, !v:{# ConsDef}, !*CompareState)
......@@ -87,7 +87,7 @@ where
(ok, icl_cons_defs, comp_st) = compare_rhs_of_types dcl_type_def.td_rhs icl_type_def.td_rhs dcl_cons_defs icl_cons_defs comp_st
| ok && dcl_type_def.td_arity==icl_type_def.td_arity && dcl_type_def.td_attribute==icl_type_def.td_attribute
= (icl_type_defs, icl_cons_defs, comp_st)
# comp_error = compareError type_def_error (newPosition icl_type_def.td_ident icl_type_def.td_pos) comp_st.comp_error
# comp_error = compareError type_def_error icl_type_def.td_ident icl_type_def.td_pos comp_st.comp_error
= (icl_type_defs, icl_cons_defs, { comp_st & comp_error = comp_error })
= (icl_type_defs, icl_cons_defs, comp_st)
......@@ -194,7 +194,7 @@ where
(ok, icl_member_defs, comp_st) = compare_classes dcl_class_def dcl_member_defs icl_class_def icl_member_defs comp_st
| ok
= (icl_class_defs, icl_member_defs, comp_st)
# comp_error = compareError class_def_error (newPosition icl_class_def.class_ident icl_class_def.class_pos) comp_st.comp_error
# comp_error = compareError class_def_error icl_class_def.class_ident icl_class_def.class_pos comp_st.comp_error
= (icl_class_defs, icl_member_defs, { comp_st & comp_error = comp_error })
= (icl_class_defs, icl_member_defs, comp_st)
......@@ -311,7 +311,7 @@ where
= member_types_equal instance_member_types icl_instance_members icl_member_n icl_functions comp_st
instance_def_conflicts_error ident pos comp_st
= {comp_st & comp_error = compareError instance_def_error (newPosition ident pos) comp_st.comp_error }
= {comp_st & comp_error = compareError instance_def_error ident pos comp_st.comp_error }
compareGenericDefs :: !{# Int} !{#Bool} !{# GenericDef} !u:{# GenericDef} !*CompareState -> (!u:{# GenericDef}, !*CompareState)
compareGenericDefs dcl_sizes copied_from_dcl dcl_generic_defs icl_generic_defs comp_st
......@@ -329,7 +329,7 @@ where
# (ok3, comp_st) = compare dcl_generic_def.gen_deps icl_generic_def.gen_deps comp_st
| ok1 && ok2 && ok3
= (icl_generic_defs, comp_st)
# comp_error = compareError generic_def_error (newPosition icl_generic_def.gen_ident icl_generic_def.gen_pos) comp_st.comp_error
# comp_error = compareError generic_def_error icl_generic_def.gen_ident icl_generic_def.gen_pos comp_st.comp_error
= (icl_generic_defs, { comp_st & comp_error = comp_error })
| otherwise
= (icl_generic_defs, comp_st)
......@@ -628,8 +628,6 @@ class t_corresponds a :: !a !a -> *TypesCorrespondMonad
class e_corresponds a :: !a !a -> ExpressionsCorrespondMonad
// check for correspondence of expressions
class getIdentPos a :: a -> IdentPos
class CorrespondenceNumber a where
toCorrespondenceNumber :: .a -> OptionalCorrespondenceNumber
fromCorrespondenceNumber :: Int -> .a
......@@ -784,10 +782,8 @@ init_class_args type_vars1 type_vars2 tc_state=:{tc_type_vars=tc_type_vars=:{hwn
= writePtr tv_info_ptr TVI_Empty heap
generate_error message iclDef iclDefs tc_state error_admin
# ident_pos = getIdentPos iclDef
error_admin = pushErrorAdmin ident_pos error_admin
error_admin = checkError ident_pos.ip_ident message error_admin
= (iclDefs, tc_state, popErrorAdmin error_admin)
# error_admin = checkErrorIdentWithPosition iclDef.fun_ident iclDef.fun_pos iclDef.fun_ident message error_admin
= (iclDefs, tc_state, error_admin)
compareMacrosWithConversion main_dcl_module_n conversions macro_range generic_case_def_macros icl_functions macro_defs var_heap expr_heap tc_state error_admin
#! n_icl_functions = size icl_functions
......@@ -816,7 +812,7 @@ compareTwoMacroFuns :: !Int !Int !Int !*ExpressionsCorrespondState -> .Expressio
compareTwoMacroFuns macro_module_index dclIndex iclIndex ec_state=:{ec_icl_functions,ec_macro_defs,ec_main_dcl_module_n}
| macro_module_index<>ec_main_dcl_module_n
# (dcl_function,ec_macro_defs) = ec_macro_defs![macro_module_index,dclIndex]
= { ec_state & ec_macro_defs=ec_macro_defs,ec_error_admin = checkErrorWithIdentPos (getIdentPos dcl_function) ErrorMessage ec_state.ec_error_admin }
= {ec_state & ec_macro_defs=ec_macro_defs,ec_error_admin = checkErrorWithPosition dcl_function.fun_ident dcl_function.fun_pos ErrorMessage ec_state.ec_error_admin}
| iclIndex==NoIndex
= ec_state
# (dcl_function, ec_macro_defs) = ec_macro_defs![macro_module_index,dclIndex]
......@@ -831,7 +827,7 @@ compareTwoMacroFuns macro_module_index dclIndex iclIndex ec_state=:{ec_icl_funct
_ -> True
| not need_to_be_compared
= ec_state
# ident_pos = getIdentPos dcl_function
# ident_pos = newPosition dcl_function.fun_ident dcl_function.fun_pos
ec_error_admin = pushErrorAdmin ident_pos ec_state.ec_error_admin
ec_state = { ec_state & ec_error_admin = ec_error_admin }
| (dcl_function.fun_info.fi_properties bitand FI_IsMacroFun <> icl_function.fun_info.fi_properties bitand FI_IsMacroFun
......@@ -850,7 +846,7 @@ compare_generic_case_def_macro_and_function dclIndex iclIndex generic_info ec_st
(icl_function, ec_icl_functions) = ec_icl_functions![iclIndex]
ec_state & ec_icl_correspondences.[iclIndex]=dclIndex, ec_dcl_correspondences.[dclIndex]=iclIndex,
ec_icl_functions = ec_icl_functions,ec_macro_defs=ec_macro_defs
ident_pos = getIdentPos dcl_function
ident_pos = newPosition dcl_function.fun_ident dcl_function.fun_pos
ec_state & ec_error_admin = pushErrorAdmin ident_pos ec_state.ec_error_admin
dcl_args_and_rhs = from_body dcl_function.fun_body
......@@ -872,34 +868,6 @@ where
remove_generic_info_arg args_and_rhs
= args_and_rhs
instance getIdentPos (TypeDef a) where
getIdentPos {td_ident, td_pos}
= newPosition td_ident td_pos
instance getIdentPos ConsDef where
getIdentPos {cons_ident, cons_pos}
= newPosition cons_ident cons_pos
instance getIdentPos SelectorDef where
getIdentPos {sd_ident, sd_pos}
= newPosition sd_ident sd_pos
instance getIdentPos ClassDef where
getIdentPos {class_ident, class_pos}
= newPosition class_ident class_pos
instance getIdentPos MemberDef where
getIdentPos {me_ident, me_pos}
= newPosition me_ident me_pos
instance getIdentPos ClassInstance where
getIdentPos {ins_ident, ins_pos}
= newPosition ins_ident ins_pos
instance getIdentPos FunDef where
getIdentPos {fun_ident, fun_pos}
= newPosition fun_ident fun_pos
instance CorrespondenceNumber VarInfo where
toCorrespondenceNumber (VI_CorrespondenceNumber number)
= CorrespondenceNumber number
......
......@@ -259,9 +259,7 @@ solveExplicitImports expl_imp_indices_ikh modules_in_component_set importing_mod
= (decls_accu, dcl_modules, eii_declaring_modules, visited_modules, cs_error)
| need_all
# (module_name,dcl_modules)=dcl_modules![imported_mod].dcl_name.id_name
cs_error = pushErrorAdmin (newPosition import_ident position) cs_error
cs_error = checkError belong_ident ("of "+++eii_ident.id_name+++" not exported by module "+++module_name) cs_error
cs_error = popErrorAdmin cs_error
cs_error = checkErrorIdentWithPosition import_ident position belong_ident ("of "+++eii_ident.id_name+++" not exported by module "+++module_name) cs_error
= (decls_accu, dcl_modules, eii_declaring_modules, visited_modules, cs_error)
= (decls_accu, dcl_modules, eii_declaring_modules, visited_modules, cs_error)
......@@ -345,9 +343,7 @@ solveExplicitImports expl_imp_indices_ikh modules_in_component_set importing_mod
# opt_nr_and_idents = [(i, ii_ident):opt_nr_and_idents]
-> (opt_nr_and_idents,cs_error,cs_symbol_table)
_
# cs_error = pushErrorAdmin (newPosition import_ident position) cs_error
cs_error = checkError ii_ident ("does not belong to "+++eii_ident.id_name) cs_error
cs_error = popErrorAdmin cs_error
# cs_error = checkErrorIdentWithPosition import_ident position ii_ident ("does not belong to "+++eii_ident.id_name) cs_error
-> get_opt_nr_and_idents idents position eii_ident opt_nr_and_idents cs_error cs_symbol_table
get_opt_nr_and_idents [] position eii_ident opt_nr_and_idents cs_error cs_symbol_table
= (opt_nr_and_idents,cs_error,cs_symbol_table)
......@@ -537,9 +533,8 @@ solveExplicitImports expl_imp_indices_ikh modules_in_component_set importing_mod
(eii_ident, eii) = get_eei_ident eii
expl_imp_info = {expl_imp_info & [ini_symbol_nr] = eii}
(module_name,dcl_modules)=dcl_modules![imported_mod].dcl_name.id_name
cs_error = popErrorAdmin (checkError eii_ident
("not exported as a "+++impDeclToNameSpaceString ini_imp_decl +++" by module "+++module_name)
(pushErrorAdmin (newPosition import_ident position) cs_error))
cs_error = checkErrorIdentWithPosition import_ident position eii_ident
("not exported as a "+++impDeclToNameSpaceString ini_imp_decl +++" by module "+++module_name) cs_error
= report_not_exported_symbol_errors not_exported_symbols position expl_imp_info imported_mod dcl_modules cs_error
report_not_exported_symbol_errors [] position expl_imp_info imported_mod dcl_modules cs_error
= (expl_imp_info,dcl_modules,cs_error)
......@@ -645,7 +640,7 @@ check_whether_ident_is_imported ident module_n symbol_index wanted_ste_kind cci
= ccs
#! (ccs=:{box_ccs=box_ccs=:{ccs_symbol_table, ccs_error, ccs_heap_changes_accu}}) = ccs
# {box_cci={cci_import_position}} = cci
ccs_error = checkErrorWithIdentPos (newPosition { id_name="import", id_info=nilPtr } cci_import_position)
ccs_error = checkErrorWithPosition {id_name="import", id_info=nilPtr} cci_import_position
(" "+++toString wanted_ste_kind+++" "+++toString ident.id_name+++" not imported") ccs_error
// pretend that the unimported symbol was imported to prevent doubling error mesages
ccs_symbol_table = writePtr ident.id_info { ste & ste_kind = STE_ExplImpSymbolNotImported module_n ste_kind } ccs_symbol_table
......
......@@ -1340,10 +1340,10 @@ where
build_expr_for_type_rhs type_def_mod type_def_index (AbstractNewType _ cons) arg_expr heaps error
= build_expr_for_newtype type_def_mod type_def_index cons arg_expr heaps error
build_expr_for_type_rhs type_def_mod type_def_index (AbstractType _) arg_expr heaps error
#! error = checkErrorWithIdentPos (newPosition td_ident td_pos) "cannot build isomorphisms for an abstract type" error
#! error = checkErrorWithPosition td_ident td_pos "cannot build isomorphisms for an abstract type" error
= (EE, heaps, error)
build_expr_for_type_rhs type_def_mod type_def_index (SynType _) arg_expr heaps error
#! error = checkErrorWithIdentPos (newPosition td_ident td_pos) "cannot build isomorphisms for a synonym type" error
#! error = checkErrorWithPosition td_ident td_pos "cannot build isomorphisms for a synonym type" error
= (EE, heaps, error)
// build conversion for constructors of a type def
......
......@@ -1028,8 +1028,7 @@ partitionate_dcl_macro mod_index predef_symbols_for_transform macro_index ps
# macros_pi = foldSt (visit_macro mod_index predef_symbols_for_transform) macro_def.fun_info.fi_calls ps
-> expand_dcl_macro_if_simple mod_index macro_index macro_def predef_symbols_for_transform macros_pi
PartitioningMacro
# identPos = newPosition macro_def.fun_ident macro_def.fun_pos
-> { ps & ps_error = checkError macro_def.fun_ident "recursive macro definition" (setErrorAdmin identPos ps.ps_error) }
-> {ps & ps_error = checkErrorIdentWithPosition macro_def.fun_ident macro_def.fun_pos macro_def.fun_ident "recursive macro definition" ps.ps_error}
_
-> ps
= ps
......@@ -1043,8 +1042,7 @@ partitionate_icl_macro mod_index predef_symbols_for_transform macro_index ps
# macros_pi = foldSt (visit_macro mod_index predef_symbols_for_transform) macro_def.fun_info.fi_calls ps
-> expand_icl_macro_if_simple mod_index macro_index macro_def predef_symbols_for_transform macros_pi
PartitioningMacro
# identPos = newPosition macro_def.fun_ident macro_def.fun_pos
-> { ps & ps_error = checkError macro_def.fun_ident "recursive macro definition" (setErrorAdmin identPos ps.ps_error) }
-> {ps & ps_error = checkErrorIdentWithPosition macro_def.fun_ident macro_def.fun_pos macro_def.fun_ident "recursive macro definition" ps.ps_error}
_
-> ps
= ps
......
......@@ -2651,7 +2651,7 @@ where
# (clean_fun_type, ambiguous_or_missing_contexts, type_var_env, attr_var_env, ts_type_heaps, ts_var_heap, ts_expr_heap, ts_error)
= cleanUpSymbolType is_start_rule cSpecifiedType exp_fun_type type_contexts type_ptrs coercion_env attr_partition
defs type_var_env attr_var_env ts.ts_type_heaps ts.ts_var_heap ts.ts_expr_heap ts.ts_error
ts_error = check_caf_context (newPosition fun_ident fun_pos) fun_kind clean_fun_type ts_error
ts_error = check_caf_context fun_ident fun_pos fun_kind clean_fun_type ts_error
| ts_error.ea_ok
# (ts_fun_env, attr_var_env, ts_type_heaps, ts_expr_heap, ts_error)
= check_function_type fun_type tmp_fun_type clean_fun_type type_ptrs defs ts.ts_fun_env attr_var_env ts_type_heaps ts_expr_heap ts_error
......@@ -2663,7 +2663,7 @@ where
# (clean_fun_type, ambiguous_or_missing_contexts, type_var_env, attr_var_env, ts_type_heaps, ts_var_heap, ts_expr_heap, ts_error)
= cleanUpSymbolType is_start_rule cDerivedType exp_fun_type type_contexts type_ptrs coercion_env attr_partition
defs type_var_env attr_var_env ts.ts_type_heaps ts.ts_var_heap ts.ts_expr_heap ts.ts_error
ts_error = check_caf_context (newPosition fun_ident fun_pos) fun_kind clean_fun_type ts_error
ts_error = check_caf_context fun_ident fun_pos fun_kind clean_fun_type ts_error
th_attrs = ts_type_heaps.th_attrs
(out, th_attrs)
= case list_inferred_types of
......@@ -2700,9 +2700,9 @@ where
= take arity_diff args2 ++ args1
= args1
check_caf_context position FK_Caf {st_context=[_:_]} error
= checkErrorWithIdentPos position "CAF cannot be overloaded" error
check_caf_context _ _ _ error
check_caf_context fun_ident fun_pos FK_Caf {st_context=[_:_]} error
= checkErrorWithPosition fun_ident fun_pos "CAF cannot be overloaded" error
check_caf_context _ _ _ _ error
= error
addLiftedArgumentsToSymbolType st=:{st_arity,st_args,st_args_strictness,st_vars,st_attr_vars,st_context} nr_of_lifted_arguments new_args new_vars new_attrs new_context
......@@ -2919,21 +2919,21 @@ where
check_type_of_constructor_variable ins_pos common_defs type=:(TAS {type_index={glob_module,glob_object},type_arity} types _) (error, type_var_heap, td_infos)
= check_type_of_constructor_variable_for_TA glob_module glob_object type_arity types ins_pos common_defs type error type_var_heap td_infos
check_type_of_constructor_variable ins_pos common_defs type=:(arg_type --> result_type) (error, type_var_heap, td_infos)
= (checkErrorWithIdentPos (newPosition empty_id ins_pos) " instance type should be coercible" error,
= (checkErrorWithPosition empty_id ins_pos " instance type should be coercible" error,
type_var_heap, td_infos)
//AA..
/*
// ??? not sure if it is correct
check_type_of_constructor_variable ins_pos common_defs TArrow (error, type_var_heap, td_infos)
= (checkErrorWithIdentPos (newPosition empty_id ins_pos) " instance type should be coercible" error,
type_var_heap, td_infos)
= (checkErrorWithPosition empty_id ins_pos " instance type should be coercible" error,
type_var_heap, td_infos)
check_type_of_constructor_variable ins_pos common_defs type=:(TArrow1 arg_type) (error, type_var_heap, td_infos)
= (checkErrorWithIdentPos (newPosition empty_id ins_pos) " instance type should be coercible" error,
= (checkErrorWithPosition empty_id ins_pos " instance type should be coercible" error,
type_var_heap, td_infos)
*/
//..AA
check_type_of_constructor_variable ins_pos common_defs type=:(cv :@: types) (error, type_var_heap, td_infos)
= (checkError (newPosition empty_id ins_pos) " instance type should be coercible" error,
= (checkErrorWithPosition empty_id ins_pos " instance type should be coercible" error,
type_var_heap, td_infos)
check_type_of_constructor_variable ins_pos common_defs type state
= state
......@@ -2945,8 +2945,7 @@ where
# ({sc_neg_vect}, type_var_heap, td_infos)
= signClassification glob_object glob_module [TopSignClass \\ cv <- tdi_cons_vars ] common_defs type_var_heap td_infos