aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--frontend/check.icl54
-rw-r--r--frontend/checksupport.icl12
-rw-r--r--frontend/checktypes.icl34
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)
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-15 01:58:05 +0000