bug fixes

git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@46 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d

4 files changed, 47 insertions, 65 deletions

diff --git a/frontend/check.icl b/frontend/check.icl
index e6bfd62..8505bfc 100644
--- a/frontend/check.icl
+++ b/frontend/check.icl
@@ -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
diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl
index 437ac46..a54c1e6 100644
--- a/frontend/checksupport.icl
+++ b/frontend/checksupport.icl
@@ -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
diff --git a/frontend/postparse.icl b/frontend/postparse.icl
index 7a64f49..8863268 100644
--- a/frontend/postparse.icl
+++ b/frontend/postparse.icl
@@ -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],
diff --git a/frontend/trans.icl b/frontend/trans.icl
index 37ae8a9..6f91711 100644
--- a/frontend/trans.icl
+++ b/frontend/trans.icl
@@ -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