From 835130322209d09169b55eefefbba6fde15c5bda Mon Sep 17 00:00:00 2001 From: martinw Date: Wed, 16 Aug 2000 09:40:52 +0000 Subject: ConsVariables were not handled correctly within improved type error messages git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@204 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d --- frontend/StdCompare.dcl | 2 +- frontend/StdCompare.icl | 4 +- frontend/trans.icl | 190 ++++++++++++++++++++++++++++++++++++++++++++++- frontend/typesupport.icl | 57 ++++++++++---- 4 files changed, 233 insertions(+), 20 deletions(-) (limited to 'frontend') diff --git a/frontend/StdCompare.dcl b/frontend/StdCompare.dcl index 72491e3..4dc74d5 100644 --- a/frontend/StdCompare.dcl +++ b/frontend/StdCompare.dcl @@ -14,7 +14,7 @@ instance =< Int, Expression, {# Char}, Ident, [a] | =< a, BasicType //, (Global instance =< Type, SymbIdent instance == BasicType, TypeVar, TypeSymbIdent, DefinedSymbol, TypeContext , BasicValue, - FunKind, (Global a) | == a, Priority, Assoc, Type + FunKind, (Global a) | == a, Priority, Assoc, Type, ConsVariable instance < MemberDef diff --git a/frontend/StdCompare.icl b/frontend/StdCompare.icl index 4dc82c4..adb6e99 100644 --- a/frontend/StdCompare.icl +++ b/frontend/StdCompare.icl @@ -31,8 +31,8 @@ instance == ConsVariable where (==) (CV tv1) (CV tv2) = tv1 == tv2 (==) (TempCV tv1) (TempCV tv2) = tv1 == tv2 - (==) cv1 cv2 = False - + (==) (TempQCV tv1) (TempQCV tv2) = tv1 == tv2 // MW4++ +// MW4 removed: (==) cv1 cv2 = False instance == TypeContext where diff --git a/frontend/trans.icl b/frontend/trans.icl index 3ba0218..390906d 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -1540,6 +1540,194 @@ bind_to_fresh_type_variable {tv_name, tv_info_ptr} th_vars appTypeVarHeap f type_heaps :== let th_vars = f type_heaps.th_vars in { type_heaps & th_vars = th_vars } accTypeVarHeap f type_heaps :== let (r, th_vars) = f type_heaps.th_vars in (r, { type_heaps & th_vars = th_vars }) +createBindingsForUnifiedTypes :: !AType !AType ![TypeVar] !{#CommonDefs} !*TypeHeaps -> (![TypeVar], !.TypeHeaps) +createBindingsForUnifiedTypes type_1 type_2 all_type_vars common_defs type_heaps=:{th_vars} + = undef + +createBindingsForUnifiedTypes2 :: !AType !AType ![TypeVar] !{#CommonDefs} !*TypeHeaps -> (![TypeVar], !.TypeHeaps) +createBindingsForUnifiedTypes2 sub_type type all_type_vars common_defs type_heaps=:{th_vars} +/* unify the two type arguments and generate new bindings. The resulting list of type variables should only + contain variables that occur in the second type argument (the "demanded" type). +*/ + # th_vars = foldSt (\tv th_vars -> th_vars <:= (tv.tv_info_ptr, TVI_Empty)) all_type_vars th_vars + (type_heaps=:{th_vars}) = bind_and_unify_atypes sub_type type False [] common_defs { type_heaps & th_vars = th_vars } +// th_vars = th_vars -!-> "" +// th_vars = foldSt trace_type_var all_type_vars th_vars + th_vars = foldSt (\ a b -> snd (bind_to_root a b)) all_type_vars th_vars +// th_vars = th_vars -!-> "" +// th_vars = foldSt trace_type_var all_type_vars th_vars + (unbound_type_vars, th_vars) = foldSt get_unbound_var all_type_vars ([], th_vars) +// th_vars = th_vars -!-> "" +// th_vars = foldSt trace_type_var all_type_vars th_vars + = (unbound_type_vars, { type_heaps & th_vars = th_vars }) + where + bind_and_unify_types (TV tv_1) (TV tv_2) common_defs type_heaps=:{th_vars} + # (root_1, th_vars) = get_root tv_1 th_vars + (root_2, th_vars) = get_root tv_2 th_vars + maybe_root_tv_1 = only_tv root_1 + maybe_root_tv_2 = only_tv root_2 + type_heaps = { type_heaps & th_vars = th_vars } + = case (maybe_root_tv_1, maybe_root_tv_2) of + (Yes root_tv_1, No) + -> appTypeVarHeap (bind_root_variable_to_type root_tv_1 root_2) type_heaps + (No, Yes root_tv_2) + -> appTypeVarHeap (bind_root_variable_to_type root_tv_2 root_1) type_heaps + (Yes root_tv_1, Yes root_tv_2) + | root_tv_1.tv_info_ptr==root_tv_2.tv_info_ptr + -> type_heaps + -> appTypeVarHeap (bind_roots_together root_tv_1 root_2) type_heaps + (No, No) + -> bind_and_unify_types root_1 root_2 common_defs type_heaps + bind_and_unify_types (TV tv_1) type common_defs type_heaps=:{th_vars} + | not (is_non_variable_type type) + = abort ("compiler error in trans.icl: assertion failed (1) XXX"--->type) + # th_vars = bind_variable_to_type tv_1 type th_vars + = { type_heaps & th_vars = th_vars } + bind_and_unify_types type (TV tv_1) common_defs type_heaps=:{th_vars} + | not (is_non_variable_type type) + = abort ("compiler error in trans.icl: assertion failed (2) XXX"--->type) + # th_vars = bind_variable_to_type tv_1 type th_vars + = { type_heaps & th_vars = th_vars } + bind_and_unify_types (TA _ arg_types1) (TA _ arg_types2) common_defs type_heaps + = bind_and_unify_atype_lists arg_types1 arg_types2 common_defs type_heaps + bind_and_unify_types (l1 --> r1) (l2 --> r2) common_defs type_heaps + = bind_and_unify_atypes r1 r2 common_defs (bind_and_unify_atypes l1 l2 common_defs type_heaps) + bind_and_unify_types (TB _) (TB _) common_defs type_heaps + = type_heaps + bind_and_unify_types ((CV l1) :@: r1) ((CV l2) :@: r2) common_defs type_heaps + = bind_and_unify_atype_lists r1 r2 common_defs (bind_and_unify_types (TV l1) (TV l2) common_defs type_heaps) + bind_and_unify_types (TA type_symb r1) ((CV l2) :@: r2) common_defs type_heaps + = bind_and_unify_atype_lists r1 r2 common_defs (bind_and_unify_types (TA type_symb []) (TV l2) common_defs type_heaps) + bind_and_unify_types ((CV l1) :@: r1) (TA type_symb r2) common_defs type_heaps + = bind_and_unify_atype_lists r1 r2 common_defs (bind_and_unify_types (TV l1) (TA type_symb []) common_defs type_heaps) + bind_and_unify_types TE y common_defs type_heaps + = type_heaps + bind_and_unify_types x TE common_defs type_heaps + = type_heaps + bind_and_unify_types x y _ _ + = abort ("bind_and_unify_types"--->(x,y)) + + bind_and_unify_atype_lists [] [] common_defs type_heaps + = type_heaps + bind_and_unify_atype_lists [x:xs] [y:ys] common_defs type_heaps + = bind_and_unify_atype_lists xs ys common_defs (bind_and_unify_atypes x y common_defs type_heaps) + + bind_and_unify_atypes {at_type=TA type_symb_1 type_args_1, at_attribute = sub_attr} + {at_type=TA type_symb_2 type_args_2} at_attribute = attr} + is_plusmin_sign inequalities_accu common_defs type_heaps + | type_symb_1==type_symb_2 + = bind_and_unify_atype_lists type_args_1 type_args_2 is_plusmin_sign + (add_inequality is_plusmin_sign sub_attr attr inequalities_accu) + common_defs type_heaps + // otherwise further with next alternative ("functional GOTO") +/* XXX + bind_and_unify_atypes atype_1 atype_2 common_defs type_heaps + # (mb_expanded_1, type_heaps) = try_to_expand atype_1 common_defs type_heaps + (mb_expanded_2, type_heaps) = try_to_expand atype_2 common_defs type_heaps + = bind_and_unify_types mb_expanded_1 mb_expanded_2 common_defs type_heaps + where + try_to_expand {at_type=actual_type=:TA {type_index={glob_object,glob_module}} actual_args, at_attribute=actual_type_attr} + common_defs type_heaps + #! type_def = common_defs.[glob_module].com_type_defs.[glob_object] + = case type_def.td_rhs of + SynType {at_type=rhs_type} + -> expandTypeApplication type_def.td_args type_def.td_attribute rhs_type actual_args actual_type_attr type_heaps + _ + -> (actual_type, type_heaps) + try_to_expand {at_type} _ type_heaps + = (at_type, type_heaps) +*/ +:: TypeSymbIdent = + { type_name :: !Ident + , type_arity :: !Int + , type_index :: !Global Index + , type_prop :: !TypeSymbProperties + } + +:: TypeSymbProperties = + { tsp_sign :: !SignClassification + , tsp_propagation :: !PropClassification + , tsp_coercible :: !Bool + } + + + bind_to_root :: !TypeVar !*TypeVarHeap -> (!TypeVarInfo,!.TypeVarHeap); + bind_to_root this_tv th_vars + # (tv_info, th_vars) = readPtr this_tv.tv_info_ptr th_vars + = case tv_info of + TVI_Empty + -> (tv_info, th_vars) + (TVI_Type type) + | is_non_variable_type type + -> (tv_info, th_vars) + -> case type of + (TV next_tv) + # (root_tvi, th_vars) = bind_to_root next_tv th_vars + th_vars = th_vars <:= (this_tv.tv_info_ptr, root_tvi) + -> (root_tvi, th_vars) + + get_unbound_var tv=:{tv_info_ptr} (unbound_type_vars_accu, th_vars) + # (tv_info, th_vars) = readPtr tv_info_ptr th_vars + = case tv_info of + TVI_Empty + -> ([tv:unbound_type_vars_accu], th_vars) + (TVI_Type type) + -> (unbound_type_vars_accu, th_vars) + + only_tv :: Type -> Optional TypeVar + only_tv (TV tv) = Yes tv + only_tv _ = No + + is_non_variable_type (TA _ _) = True + is_non_variable_type (_ --> _) = True + is_non_variable_type (_ :@: _) = True + is_non_variable_type (TB _) = True + is_non_variable_type _ = False + + bind_variable_to_type tv type th_vars + # (root, th_vars) = get_root tv th_vars + = case (only_tv root) of + (Yes tv) -> bind_root_variable_to_type tv type th_vars + No -> th_vars + + bind_root_variable_to_type {tv_info_ptr} type th_vars + = th_vars <:= (tv_info_ptr, TVI_Type type) + + bind_roots_together :: TypeVar Type *(Heap TypeVarInfo) -> .Heap TypeVarInfo; + bind_roots_together root_tv_1 root_type_2 th_vars + = th_vars <:= (root_tv_1.tv_info_ptr, TVI_Type root_type_2) + + get_root :: TypeVar *(Heap TypeVarInfo) -> (Type,.Heap TypeVarInfo); + get_root this_tv th_vars + # (tv_info, th_vars) = readPtr this_tv.tv_info_ptr th_vars + = case tv_info of + TVI_Empty + -> (TV this_tv, th_vars) + (TVI_Type type) + | is_non_variable_type type + -> (type, th_vars) + -> case type of + (TV next_tv) -> get_root next_tv th_vars + // XXX for tracing + trace_type_var tv th_vars + = trace_type_vars tv (th_vars -!-> "TYPE VARIABLE") + + trace_type_vars this_tv th_vars + # th_vars = th_vars -!-> this_tv + # (tv_info, th_vars) = readPtr this_tv.tv_info_ptr th_vars + = case tv_info of + TVI_Empty + -> th_vars + (TVI_Type type) + | is_non_variable_type type + -> (th_vars -!-> ("TVI_Type", type)) + -> case type of + (TV next_tv) -> trace_type_vars next_tv th_vars +// (TVI_FreshTypeVar root_type_var) +// -> th_vars -!-> ("TVI_FreshTypeVar",root_type_var) + + +/* createBindingsForUnifiedTypes :: !AType !AType ![TypeVar] !{#CommonDefs} !*TypeHeaps -> (![TypeVar], !.TypeHeaps) createBindingsForUnifiedTypes type_1 type_2 all_type_vars common_defs type_heaps=:{th_vars} /* unify the two type arguments and generate new bindings. The resulting list of type variables should only @@ -1702,7 +1890,7 @@ createBindingsForUnifiedTypes type_1 type_2 all_type_vars common_defs type_heaps (TV next_tv) -> trace_type_vars next_tv th_vars // (TVI_FreshTypeVar root_type_var) // -> th_vars -!-> ("TVI_FreshTypeVar",root_type_var) - +*/ transformFunctionApplication fun_def instances cc=:{cc_size, cc_args, cc_linear_bits} app=:{app_symb,app_args} extra_args ro ti # (app_symb, app_args, extra_args) = complete_application app_symb fun_def.fun_arity app_args extra_args diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index fc84b32..8898a83 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -962,9 +962,15 @@ where writeType file opt_beautifulizer (form, type :@: types) | checkProperty form cBrackets # (file, opt_beautifulizer) - = writeType (file <<< '(' <<< type <<< ' ') opt_beautifulizer (form, types) + = writeType (file <<< '(') opt_beautifulizer (form, type) + (file, opt_beautifulizer) + = writeType (file <<< ' ') opt_beautifulizer (form, types) = (file <<< ')', opt_beautifulizer) - = writeType (file <<< type <<< ' ') opt_beautifulizer (setProperty form cBrackets, types) + # (file, opt_beautifulizer) + = writeType file opt_beautifulizer (form, type) + (file, opt_beautifulizer) + = writeType (file <<< ' ') opt_beautifulizer (setProperty form cBrackets, types) + = (file, opt_beautifulizer) writeType file opt_beautifulizer (form, TB tb) = (file <<< tb, opt_beautifulizer) writeType file No (form, TQV varid) @@ -983,22 +989,18 @@ writeWithinBrackets br_open br_close file opt_beautifulizer (form, types) = writeType (file <<< br_open) opt_beautifulizer (form, types) = (file <<< br_close, opt_beautifulizer) -writeBeautifulTypeVar file beautifulizer=:{tvb_visited, tvb_fresh_vars} type_variable +writeBeautifulTypeVar file beautifulizer=:{tvb_visited_typevars, tvb_fresh_vars} type_variable | sanity_check_failed type_variable = abort "bug nr 12345 in module typesupport" - = case lookup type_variable tvb_visited of + = case assoc_list_lookup type_variable tvb_visited_typevars of No - -> (file <<< hd tvb_fresh_vars, Yes { tvb_visited = [(type_variable, hd tvb_fresh_vars):tvb_visited], - tvb_fresh_vars = tl tvb_fresh_vars }) + -> (file <<< hd tvb_fresh_vars, + Yes { beautifulizer & + tvb_visited_typevars = [(type_variable, hd tvb_fresh_vars):tvb_visited_typevars], + tvb_fresh_vars = tl tvb_fresh_vars }) Yes (_, beautiful_var_name) -> (file <<< beautiful_var_name, Yes beautifulizer) where - lookup _ [] = No - lookup t1 [hd=:(t2, _):tl] - | t1==t2 - = Yes hd - = lookup t1 tl - sanity_check_failed (GTV _) = False sanity_check_failed (TV _) = False sanity_check_failed (TempV _) = False @@ -1007,6 +1009,27 @@ writeBeautifulTypeVar file beautifulizer=:{tvb_visited, tvb_fresh_vars} type_var sanity_check_failed (TLifted _) = False sanity_check_failed _ = True +instance writeType ConsVariable where + writeType file No (_, cons_variable) + = (file <<< cons_variable, No) + writeType file yes_beautifulizer=:(Yes beautifulizer=:{tvb_visited_consvars, tvb_fresh_vars}) + (_, cons_variable) + = case assoc_list_lookup cons_variable tvb_visited_consvars of + No + -> (file <<< hd tvb_fresh_vars, + Yes { beautifulizer & + tvb_visited_consvars = [(cons_variable, hd tvb_fresh_vars):tvb_visited_consvars], + tvb_fresh_vars = tl tvb_fresh_vars }) + Yes (_, beautiful_var_name) + -> (file <<< beautiful_var_name, yes_beautifulizer) + +assoc_list_lookup _ [] = No +assoc_list_lookup t1 [hd=:(t2, _):tl] + | t1==t2 + = Yes hd + = assoc_list_lookup t1 tl + + cNoPosition :== -1 instance writeType [a] | writeType a @@ -1066,15 +1089,17 @@ where // MW4.. :: TypeVarBeautifulizer = - { tvb_visited :: ![(Type, String)] - // associates type variables with strings, the type should be only GTV, TV, TempV, TQV, TempQV, TLifted. + { tvb_visited_typevars :: ![(Type, String)] + , tvb_visited_consvars :: ![(ConsVariable, String)] + // tvb_visited_typevars and tvb_visited_consvars associate type (constructor) variables with + // strings, the type in tvb_visited_typevars should be only GTV, TV, TempV, TQV, TempQV, TLifted. // (associations lists are slow but cool) - , tvb_fresh_vars :: ![String] + , tvb_fresh_vars :: ![String] } initialTypeVarBeautifulizer :: TypeVarBeautifulizer initialTypeVarBeautifulizer - = { tvb_visited = [], tvb_fresh_vars = fresh_vars 'a' (-1) } + = { tvb_visited_typevars = [], tvb_visited_consvars = [], tvb_fresh_vars = fresh_vars 'a' (-1) } where fresh_vars 'i' i = fresh_vars 'a' (i+1) -- cgit v1.2.3