Commit 63a82d26 authored by Martin Wierich's avatar Martin Wierich
Browse files

bug fixes

parent f1b5100f
......@@ -718,9 +718,8 @@ checkPatternConstructor mod_index is_expr_list {ste_index, ste_kind} cons_symb o
where
determine_pattern_symbol mod_index id_index STE_Constructor id_name cons_defs modules error
#! cons_def = cons_defs.[id_index]
# {cons_symb, cons_type={st_arity},cons_priority, cons_type_index} = cons_def
# {cons_type={st_arity},cons_priority, cons_type_index} = cons_def
= (id_index, mod_index, st_arity, cons_priority, cons_type_index, cons_defs, modules, error)
// ---> ("determine_pattern_symbol", id_name, cons_symb)
determine_pattern_symbol mod_index id_index (STE_Imported STE_Constructor import_mod_index) id_name cons_defs modules error
#! {dcl_common,dcl_conversions} = modules.[import_mod_index]
#! cons_def = dcl_common.com_cons_defs.[id_index]
......@@ -2235,7 +2234,7 @@ combineDclAndIclModule _ modules icl_decl_symbols icl_definitions icl_sizes cs
}
, icl_sizes
, { cs & cs_symbol_table = cs_symbol_table }
)
)->>("conversion_table",conversion_table)
where
add_to_conversion_table first_macro_index decl=:{dcl_ident=dcl_ident=:{id_info},dcl_kind,dcl_index,dcl_pos}
......@@ -2266,8 +2265,7 @@ where
can_be_only_in_dcl def_kind
= def_kind == cTypeDefs || def_kind == cConstructorDefs || def_kind == cSelectorDefs
// || def_kind == cClassDefs || def_kind == cMemberDefs
|| def_kind == cClassDefs || def_kind == cMemberDefs
add_dcl_declaration info_ptr entry dcl def_index dcl_index (conversion_table, icl_sizes, icl_defs, symbol_table)
# (icl_index, icl_sizes) = icl_sizes![def_index]
......@@ -2296,21 +2294,14 @@ where
# (rt_constructor, cs) = redirect_defined_symbol STE_Constructor td_pos rt_constructor cs
(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} new_type_defs cs
// MW was add_type_def td=:{td_name, td_pos} 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"
(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
= ([td : new_type_defs], cs)
redirect_defined_symbol req_kind pos ds=:{ds_ident} cs
# ({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"
(setErrorAdmin (newPosition ds_ident pos) cs.cs_error)
= ({ ds & ds_index = ste_index }, { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table })
redirect_field_symbols pos fields cs
# new_fields = { field \\ field <-: fields }
= iFoldSt (redirect_field_symbol pos fields) 0 (size fields) (new_fields, cs)
......@@ -2333,10 +2324,31 @@ where
add_dcl_definition {com_selector_defs} dcl=:{dcl_kind = STE_Field _, dcl_index}
(new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, cs)
= (new_type_defs, new_class_defs, new_cons_defs, [ com_selector_defs.[dcl_index] : new_selector_defs ], new_member_defs, cs)
add_dcl_definition {com_class_defs} dcl=:{dcl_kind = STE_Class, dcl_index, dcl_pos}
(new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, cs)
# class_def = com_class_defs.[dcl_index]
(new_class_defs, cs) = add_class_def dcl_pos class_def new_class_defs cs
= (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, cs)
where
add_class_def dcl_pos cd=:{class_members} new_class_defs cs
# (new_class_members, cs) = mapSt (redirect_defined_symbol STE_Member dcl_pos) [ cm \\ cm<-:class_members ] cs
= ([{cd & class_members={cm \\ cm<-new_class_members}}:new_class_defs], cs)
add_dcl_definition {com_member_defs} dcl=:{dcl_kind = STE_Member, dcl_index, dcl_pos}
(new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, cs)
# member_def = com_member_defs.[dcl_index]
= (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, [member_def:new_member_defs], cs)
add_dcl_definition _ _
(new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, cs)
= (new_type_defs, new_class_defs, new_cons_defs, new_selector_defs, new_member_defs, cs)
redirect_defined_symbol req_kind pos ds=:{ds_ident} cs
# ({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"->>("ste_kind",ste_kind,ptrToInt ds_ident.id_info))
(setErrorAdmin (newPosition ds_ident pos) cs.cs_error)
= ({ ds & ds_index = ste_index }, { cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table })
my_append front []
= front
my_append front back
......
......@@ -327,8 +327,10 @@ retrieveImportsFromSymbolTable [] decls modules symbol_table
removeFieldFromSelectorDefinition :: !Ident .Int .Int !*(Heap SymbolTableEntry) -> .Heap SymbolTableEntry;
removeFieldFromSelectorDefinition {id_info} field_mod field_index symbol_table
# (entry, symbol_table) = readPtr id_info symbol_table
(STE_Selector selector_list) = entry.ste_kind
= symbol_table <:= (id_info, { entry & ste_kind = STE_Selector (remove_field field_mod field_index selector_list) })
= case entry.ste_kind of
STE_Selector selector_list
-> symbol_table <:= (id_info, { entry & ste_kind = STE_Selector (remove_field field_mod field_index selector_list) })
_ -> symbol_table
where
remove_field field_mod field_index [field=:{glob_module, glob_object} : fields]
| field_mod == glob_module && field_index == glob_object
......
......@@ -634,7 +634,8 @@ reorganizeDefinitions icl_module [PD_Type type_def=:{td_name, td_rhs = SelectorL
cons_arity = new_count - sel_count
cons_def = { pc_cons_name = rec_cons_id, pc_cons_prio = NoPrio, pc_cons_arity = cons_arity, pc_cons_pos = td_pos,
pc_arg_types = [ ps_field_type \\ {ps_field_type} <- sel_defs ], pc_exi_vars = exivars }
type_def = { type_def & td_rhs = RecordType {rt_constructor = { ds_ident = td_name, ds_arity = cons_arity, ds_index = cons_count },
// MW was type_def = { type_def & td_rhs = RecordType {rt_constructor = { ds_ident = td_name, ds_arity = cons_arity, ds_index = cons_count },
type_def = { type_def & td_rhs = RecordType {rt_constructor = { ds_ident = rec_cons_id, ds_arity = cons_arity, ds_index = cons_count },
rt_fields = { sel \\ sel <- sel_syms }}}
/* Sjaak ... */
c_defs = { c_defs & def_types = [type_def : c_defs.def_types], def_constructors = [ParsedConstructorToConsDef cons_def : c_defs.def_constructors],
......
......@@ -116,10 +116,10 @@ cNope :== -1
Unification of classifications is done on-the-fly
*/
cPassive :== -1
cActive :== -2
cAccumulating :== -3
cVarOfWeirdCase :== -4
cPassive :== -1
cActive :== -2
cAccumulating :== -3
cVarOfMultimatchCase :== -4
IsAVariable cons_class :== cons_class >= 0
......@@ -320,13 +320,13 @@ instance consumerRequirements Case where
(ccgs, unsafe_bits, ai) = consumer_requirements_of_guards case_guards common_defs ai
has_default = case case_default of { Yes _ -> True; _ -> False }
(ccd, default_is_unsafe, ai) = consumerRequirements case_default common_defs ai
(every_constructor_appears_in_safe_pattern, ambiguity_exists) = inspect_patterns common_defs has_default case_guards unsafe_bits
(every_constructor_appears_in_safe_pattern, is_multimatch) = inspect_patterns common_defs has_default case_guards unsafe_bits
safe = (has_default && not default_is_unsafe) || every_constructor_appears_in_safe_pattern
ai_class_subst = unifyClassifications (if ambiguity_exists cVarOfWeirdCase cActive) cce ai.ai_class_subst
ai_class_subst = unifyClassifications (if is_multimatch cVarOfMultimatchCase cActive) cce ai.ai_class_subst
ai = { ai & ai_class_subst = ai_class_subst }
ai = case case_expr of
(Var {var_info_ptr})
-> case ambiguity_exists of
-> case is_multimatch of
False -> { ai & ai_cases_of_vars_for_function=[kees:ai.ai_cases_of_vars_for_function] }
True -> ai
_ -> ai
......@@ -341,7 +341,7 @@ instance consumerRequirements Case where
pattern_constructors = [ glob_object.ds_index \\ {ap_symbol={glob_object}}<-algebraic_patterns]
sorted_pattern_constructors = sort pattern_constructors unsafe_bits
all_sorted_constructors = if (is_sorted all_constructors) all_constructors (quicksort (<) all_constructors)
= (appearance_loop all_sorted_constructors sorted_pattern_constructors, ambiguity_loop has_default sorted_pattern_constructors)
= (appearance_loop all_sorted_constructors sorted_pattern_constructors, multimatch_loop has_default sorted_pattern_constructors)
where
is_sorted [x]
= True
......@@ -351,7 +351,7 @@ instance consumerRequirements Case where
# bools_indices = [ if bool 1 0 \\ {bp_value=BVB bool}<-basic_patterns ]
sorted_pattern_constructors = sort bools_indices unsafe_bits
= (appearance_loop [0,1] sorted_pattern_constructors,
ambiguity_loop has_default sorted_pattern_constructors)
multimatch_loop has_default sorted_pattern_constructors)
inspect_patterns _ _ _ _
= (False, True)
......@@ -381,9 +381,9 @@ instance consumerRequirements Case where
// the constructor will match safely. Skip over patterns with the same constructor and test the following constructor
= appearance_loop constructors_in_type (dropWhile (\(ds_index,_,_)->ds_index==constructor_in_pattern) constructors_in_pattern)
ambiguity_loop has_default []
multimatch_loop has_default []
= False
ambiguity_loop has_default [(cip, _, iup):t]
multimatch_loop has_default [(cip, _, iup):t]
= a_loop has_default cip iup t
where
a_loop has_default cip iup []
......@@ -395,7 +395,7 @@ instance consumerRequirements Case where
= a_loop has_default constructor_in_pattern is_unsafe_pattern constructors_in_pattern
| iup
= True
= ambiguity_loop has_default (dropWhile (\(ds_index,_,_)->ds_index==cip) constructors_in_pattern)
= multimatch_loop has_default (dropWhile (\(ds_index,_,_)->ds_index==cip) constructors_in_pattern)
instance consumerRequirements DynamicExpr where
consumerRequirements {dyn_expr} common_defs ai
......@@ -519,7 +519,7 @@ where
({cc_size, cc_args, cc_linear_bits},class_env) = class_env![fun_index]
(aci_linearity_of_patterns, var_heap) = get_linearity_info cc_linear_bits case_guards var_heap
| /*XXX*/arg_position<cc_size && (arg_position>=cc_size || cc_args!!arg_position==cActive) && cc_linear_bits!!arg_position
// mark non weird cases whose case_expr is an active linear function argument
// mark non multimatch cases whose case_expr is an active linear function argument
# aci = { aci_params = [], aci_opt_unfolder = No, aci_free_vars=No, aci_linearity_of_patterns = aci_linearity_of_patterns }
= ([case_info_ptr:cleanup_acc], class_env, fun_defs, var_heap,
set_extended_expr_info case_info_ptr (EEI_ActiveCase aci) expr_heap)
......@@ -740,7 +740,7 @@ transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_inf
-> case app_symb.symb_kind of
SK_Constructor cons_index
| not is_active
-> skip_over this_case ro ti // XXX currently only active cases are matched at runtime (ambiguity problem)
-> skip_over this_case ro ti // XXX currently only active cases are matched at runtime (multimatch problem)
# algebraicPatterns = getAlgebraicPatterns case_guards
aci = case opt_aci of { Yes aci -> aci }
(may_be_match_expr, ti) = match_and_instantiate aci.aci_linearity_of_patterns cons_index app_args algebraicPatterns case_default ro ti
......@@ -777,7 +777,7 @@ transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_inf
No -> skip_over this_case ro ti
BasicExpr basic_value _
| not is_active
-> skip_over this_case ro ti // XXX currently only active cases are matched at runtime (ambiguity problem)
-> skip_over this_case ro ti // XXX currently only active cases are matched at runtime (multimatch problem)
# basicPatterns = getBasicPatterns case_guards
may_be_match_pattern = dropWhile (\{bp_value} -> bp_value<>basic_value) basicPatterns
| isEmpty may_be_match_pattern
......@@ -906,39 +906,6 @@ transformCase this_case=:{case_expr,case_guards,case_default,case_ident,case_inf
, ti_symbol_heap
)
/* ExprInfo
| EI_LetType ![AType]
:: CommonDefs =
{ com_type_defs :: !.{# CheckedTypeDef}
, com_cons_defs :: !.{# ConsDef}
, com_selector_defs :: !.{# SelectorDef}
, com_class_defs :: !.{# ClassDef}
, com_member_defs :: !.{# MemberDef}
, com_instance_defs :: !.{# ClassInstance}
// , com_instance_types :: !.{ SymbolType}
}
:: ConsDef =
{ cons_symb :: !Ident
, cons_type :: !SymbolType
, cons_arg_vars :: ![[ATypeVar]]
, cons_priority :: !Priority
, cons_index :: !Index
, cons_type_index :: !Index
, cons_exi_vars :: ![ATypeVar]
// , cons_exi_attrs :: ![AttributeVar]
, cons_type_ptr :: !VarInfoPtr
, cons_pos :: !Position
}
:: SymbolType =
{ st_vars :: ![TypeVar]
, st_args :: ![AType]
, st_arity :: !Int
, st_result :: !AType
, st_context :: ![TypeContext]
, st_attr_vars :: ![AttributeVar]
, st_attr_env :: ![AttrInequality]
}
*/
match_and_instantiate [linearity:linearities] cons_index app_args [guard : guards] case_default ro ti
= match_and_instantiate linearities cons_index app_args guards case_default ro ti
match_and_instantiate _ cons_index app_args [] default_expr ro ti
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment