bug fix: uniqueness error in nested record/array updates

61fc0103 · Ronny Wichers Schreur · d00fe0ec · 61fc0103 · 61fc0103 · 61fc0103
Commit 61fc0103 authored Dec 03, 2001 by Ronny Wichers Schreur
6 changed files
--- a/backend/backendconvert.icl
+++ b/backend/backendconvert.icl
@@ -1796,6 +1796,8 @@ where
 		where
 			addKinds NormalSelector selections
 				=	[(BESelector, selection) \\ selection <- selections]
+			addKinds NormalSelectorUniqueElementResult selections
+				=	[(BESelector, selection) \\ selection <- selections]
 			addKinds _ [selection]
 				=	[(BESelector_U, selection)]
 			addKinds _ [selection : selections]

--- a/frontend/checkFunctionBodies.icl
+++ b/frontend/checkFunctionBodies.icl
@@ -1009,22 +1009,26 @@ where
 	cons_optional No variables
 		= variables

-checkExpression free_vars (PE_Selection is_unique expr [PS_Array index_expr]) e_input e_state e_info cs	
+checkExpression free_vars (PE_Selection selector_kind expr [PS_Array index_expr]) e_input e_state e_info cs	
 	# (expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs
-	| is_unique
-		# (glob_select_symb, cs) = getPredefinedGlobalSymbol PD_UnqArraySelectFun PD_StdArray STE_Member 2 cs
-		  (selector, free_vars, e_state, e_info, cs) = checkArraySelection glob_select_symb free_vars index_expr e_input e_state e_info cs
-		= (Selection NormalSelector expr [selector], free_vars, e_state, e_info, cs)
-		# (glob_select_symb, cs) = getPredefinedGlobalSymbol PD_ArraySelectFun PD_StdArray STE_Member 2 cs
-		  (selector, free_vars, e_state, e_info, cs) = checkArraySelection glob_select_symb free_vars index_expr e_input e_state e_info cs
-		= (Selection NormalSelector expr [selector], free_vars, e_state, e_info, cs)
-checkExpression free_vars (PE_Selection is_unique expr selectors) e_input e_state e_info cs	
+	# (select_fun, selector_kind)
+		= case selector_kind of
+			ParsedNormalSelector
+				-> (PD_ArraySelectFun, NormalSelector)
+			ParsedUniqueSelector _
+				-> (PD_UnqArraySelectFun, NormalSelectorUniqueElementResult)
+	# (glob_select_symb, cs) = getPredefinedGlobalSymbol select_fun PD_StdArray STE_Member 2 cs
+	  (selector, free_vars, e_state, e_info, cs) = checkArraySelection glob_select_symb free_vars index_expr e_input e_state e_info cs
+	= (Selection selector_kind expr [selector], free_vars, e_state, e_info, cs)
+checkExpression free_vars (PE_Selection selector_kind expr selectors) e_input e_state e_info cs	
 	# (selectors, free_vars, e_state, e_info, cs) = checkSelectors cEndWithSelection free_vars selectors e_input e_state e_info cs
 	  (expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input e_state e_info cs
-	| is_unique
-		# (tuple_type, cs) = getPredefinedGlobalSymbol (GetTupleTypeIndex 2) PD_PredefinedModule STE_Type 2 cs
-		= (Selection (UniqueSelector tuple_type False) expr selectors, free_vars, e_state, e_info, cs)
-		= (Selection NormalSelector expr selectors, free_vars, e_state, e_info, cs)
+	= case selector_kind of
+		ParsedNormalSelector
+			-> (Selection NormalSelector expr selectors, free_vars, e_state, e_info, cs)
+		ParsedUniqueSelector unique_element
+			# (tuple_type, cs) = getPredefinedGlobalSymbol (GetTupleTypeIndex 2) PD_PredefinedModule STE_Type 2 cs
+			-> (Selection (UniqueSelector tuple_type) expr selectors, free_vars, e_state, e_info, cs)
 checkExpression free_vars (PE_Update expr1 selectors expr2) e_input e_state e_info cs	
 	# (expr1, free_vars, e_state, e_info, cs) = checkExpression free_vars expr1 e_input e_state e_info cs
 	  (selectors, free_vars, e_state, e_info, cs) = checkSelectors cEndWithUpdate free_vars selectors e_input e_state e_info cs
@@ -2191,7 +2195,7 @@ buildSelections e_input {ap_opt_var, ap_array_var, ap_selections}
 		  				-> (unq_select_symb, NormalSelector, cs)
 		  			_	# (select_symb, cs) = getPredefinedGlobalSymbol PD_ArraySelectFun PD_StdArray STE_Member 2 cs
 						  (tuple_type, cs) = getPredefinedGlobalSymbol (GetTupleTypeIndex 2) PD_PredefinedModule STE_Type 2 cs
-		  				-> (select_symb, UniqueSelector tuple_type False, cs)
+		  				-> (select_symb, UniqueSelector tuple_type, cs)
 		  e_state
 		  		= { e_state & es_var_heap = es_var_heap, es_expr_heap = es_expr_heap }
 		  (index_exprs, (free_vars, e_state, e_info, cs))

--- a/frontend/parse.icl
+++ b/frontend/parse.icl
@@ -2175,7 +2175,7 @@ where
 		| token == DotToken
 			# (token, pState) = nextToken FunctionContext pState
 			  (selectors, pState) = wantSelectors token pState
-			= (PE_Selection cNonUniqueSelection exp selectors, pState)
+			= (PE_Selection ParsedNormalSelector exp selectors, pState)
 		| token == ExclamationToken
 			# (token, pState) = nextToken FunctionContext pState
 // JVG added for strict lists:
@@ -2183,7 +2183,7 @@ where
 				= (exp, tokenBack (tokenBack pState))
 //			
 			#  (selectors, pState) = wantSelectors token pState
-			= (PE_Selection cUniqueSelection exp selectors, pState)
+			= (PE_Selection (ParsedUniqueSelector False) exp selectors, pState)
 		| otherwise
 			= (exp, tokenBack pState)

@@ -2869,7 +2869,7 @@ where
 						# (shareIdent, pState)
 							=	make_ident optionalIdent level pState
 						  select
-						  	=	PE_Selection cNonUniqueSelection (PE_Ident shareIdent) [PS_Record fieldIdent final_record_type]
+						  	=	PE_Selection ParsedNormalSelector (PE_Ident shareIdent) [PS_Record fieldIdent final_record_type]
 						  (update_expr, pState)
 						  	=	transform_record_or_array_update No select (map sub_update updates) (level+1) pState
 						=	({bind_dst = fieldIdent, bind_src = update_expr}, (Yes shareIdent,record_type,pState))
@@ -2941,7 +2941,7 @@ where
 								  select_def
 								  	=	buildNodeDef
 								  			(PE_Tuple [PE_Ident element_id, PE_Ident array_id])
-								  			(PE_Selection cUniqueSelection expr (reverse [PS_Array (PE_Ident index_id) : initial_selectors]))
+								  			(PE_Selection (ParsedUniqueSelector True) expr (reverse [PS_Array (PE_Ident index_id) : initial_selectors]))
 								  (updated_element, pState)
 									= transform_record_update No
 										(PE_Ident element_id)

--- a/frontend/syntax.dcl
+++ b/frontend/syntax.dcl
@@ -1028,8 +1028,10 @@ instance toString 	KindInfo
 	
 :: LocalDef		:== ParsedDefinition

-cUniqueSelection	:== True
-cNonUniqueSelection	:== False
+::	ParsedSelectorKind
+		=	ParsedNormalSelector	// .
+		|	ParsedUniqueSelector	// !
+				!Bool					// 	is result element unique?

 ::	ParsedExpr	= PE_List ![ParsedExpr]
 				| PE_Ident !Ident
@@ -1041,7 +1043,7 @@ cNonUniqueSelection	:== False
 				| PE_ArrayPattern ![ElemAssignment]
 				| PE_UpdateComprehension !ParsedExpr !ParsedExpr !ParsedExpr ![Qualifier]
 				| PE_ArrayDenot ![ParsedExpr]
-				| PE_Selection !Bool !ParsedExpr ![ParsedSelection]
+				| PE_Selection !ParsedSelectorKind !ParsedExpr ![ParsedSelection]
 				| PE_Update !ParsedExpr [ParsedSelection] ParsedExpr
 				| PE_Case !Ident !ParsedExpr [CaseAlt]
 				| PE_If !Ident !ParsedExpr !ParsedExpr !ParsedExpr
@@ -1100,10 +1102,10 @@ cIsStrict		:== True
 cIsNotStrict	:== False

 ::	SelectorKind
-		=	NormalSelector			// .
+		=	NormalSelector
+		|	NormalSelectorUniqueElementResult
 		|	UniqueSelector			// !
 				(Global DefinedSymbol)	// 	tuple type
-				!Bool					// 	is result element unique?

 /*
 ::	SelectorKind	= SEK_Normal | SEK_First | SEK_Next | SEK_Last

--- a/frontend/syntax.icl
+++ b/frontend/syntax.icl
@@ -1020,8 +1020,10 @@ cNotVarNumber :== -1
 	
 :: LocalDef		:== ParsedDefinition

-cUniqueSelection	:== True
-cNonUniqueSelection	:== False
+::	ParsedSelectorKind
+		=	ParsedNormalSelector	// .
+		|	ParsedUniqueSelector	// !
+				!Bool					// 	is result element unique?

 :: ParsedExpr	= PE_List ![ParsedExpr]
 				| PE_Ident !Ident
@@ -1033,7 +1035,7 @@ cNonUniqueSelection	:== False
 				| PE_ArrayPattern ![ElemAssignment]
 				| PE_UpdateComprehension !ParsedExpr !ParsedExpr !ParsedExpr ![Qualifier]
 				| PE_ArrayDenot ![ParsedExpr]
-				| PE_Selection !Bool !ParsedExpr ![ParsedSelection]
+				| PE_Selection !ParsedSelectorKind !ParsedExpr ![ParsedSelection]
 				| PE_Update !ParsedExpr [ParsedSelection] ParsedExpr
 				| PE_Case !Ident !ParsedExpr [CaseAlt]
 				| PE_If !Ident !ParsedExpr !ParsedExpr !ParsedExpr
@@ -1093,10 +1095,10 @@ cIsStrict		:== True
 cIsNotStrict	:== False

 ::	SelectorKind
-		=	NormalSelector			// .
+		=	NormalSelector
+		|	NormalSelectorUniqueElementResult
 		|	UniqueSelector			// !
 				(Global DefinedSymbol)	// 	tuple type
-				!Bool					// 	is result element unique?

 ::	Expression	= Var !BoundVar 
 				| App !App
@@ -1661,9 +1663,9 @@ where

 instance <<< SelectorKind
 where
- 	(<<<) file NormalSelector = file <<< "!"
- 	(<<<) file (UniqueSelector _ False) = file <<< "!"
- 	(<<<) file (UniqueSelector _ True) = file <<< "!*"
+ 	(<<<) file NormalSelector = file <<< "."
+ 	(<<<) file NormalSelectorUniqueElementResult = file <<< "!*"
+ 	(<<<) file (UniqueSelector _) = file <<< "!"

 instance <<< Selection
 where
@@ -1695,7 +1697,7 @@ where
 	(<<<) file (PE_List exprs) = file <<< exprs
 	(<<<) file (PE_Tuple args) = file <<< '(' <<< args <<< ')'
 	(<<<) file (PE_Basic basic_value) = file <<< basic_value
-	(<<<) file (PE_Selection is_unique expr selectors) =  file <<< expr <<< (if is_unique '!' '.') <<< selectors
+	(<<<) file (PE_Selection selector_kind expr selectors) =  file <<< expr <<< selector_kind <<< selectors
 	(<<<) file (PE_Update expr1 selections expr2) =  file <<< '{' <<< expr1  <<< " & " <<<  selections <<< " = " <<< expr2 <<< '}'
 	(<<<) file (PE_Record PE_Empty _ fields) = file <<< '{' <<< fields <<< '}'
 	(<<<) file (PE_Record rec _ fields) = file <<< '{' <<< rec <<< " & " <<< fields <<< '}'
@@ -1718,7 +1720,12 @@ where
 				-> file <<< "dynamic " <<< expr
 	(<<<) file _ = file <<< "some expression"

-
+instance <<< ParsedSelectorKind
+where
+	(<<<) file ParsedNormalSelector			= file <<< "."
+	(<<<) file (ParsedUniqueSelector False)	= file <<< "!"
+	(<<<) file (ParsedUniqueSelector True)	= file <<< "!*"
+	
 instance <<< ParsedSelection
 where
 	(<<<) file (PS_Record selector _)	= file <<< selector

--- a/frontend/type.icl
+++ b/frontend/type.icl
@@ -1470,9 +1470,9 @@ where
 	requirements ti (Selection selector_kind expr selectors) reqs_ts
 		# (expr_type, opt_expr_ptr, (reqs, ts)) = requirements ti expr reqs_ts
 		= case selector_kind of
-			UniqueSelector {glob_object={ds_ident,ds_index,ds_arity}, glob_module} _
+			UniqueSelector {glob_object={ds_ident,ds_index,ds_arity}, glob_module}
 				# (var, ts) = freshAttributedVariable ts
-			  	  (_, result_type, (reqs, ts)) =  requirementsOfSelectors ti No expr selectors False var expr (reqs, ts)
+			  	  (_, result_type, (reqs, ts)) =  requirementsOfSelectors ti No expr selectors False False var expr (reqs, ts)
 				  tuple_type = MakeTypeSymbIdent { glob_object = ds_index, glob_module = glob_module } ds_ident ds_arity
 				  non_unique_type_var = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TempV ts.ts_var_store }
 				  req_type_coercions
@@ -1482,13 +1482,16 @@ where
 				  result_type = { at_type = TA tuple_type [non_unique_type_var,var], at_attribute = TA_Unique, at_annotation = AN_None }
 				-> (result_type, No, ({ reqs & req_type_coercions = req_type_coercions }, 
 						{ts & ts_var_store = inc ts.ts_var_store, ts_expr_heap = storeAttribute opt_expr_ptr TA_Multi ts.ts_expr_heap}))
-			_
-				# (_, result_type, reqs_ts) =  requirementsOfSelectors ti No expr selectors True expr_type expr (reqs, ts)
+			NormalSelectorUniqueElementResult
+				# (_, result_type, reqs_ts) =  requirementsOfSelectors ti No expr selectors True True expr_type expr (reqs, ts)
+				-> (result_type, opt_expr_ptr, reqs_ts)
+			NormalSelector
+				# (_, result_type, reqs_ts) =  requirementsOfSelectors ti No expr selectors True False expr_type expr (reqs, ts)
 				-> (result_type, opt_expr_ptr, reqs_ts)
 	requirements ti (Update composite_expr selectors elem_expr) reqs_ts
 		# (composite_expr_type, opt_composite_expr_ptr, reqs_ts) = requirements ti composite_expr reqs_ts
 		  (has_array_selection, result_type, (reqs, ts))
-		  		= requirementsOfSelectors ti (Yes elem_expr) composite_expr selectors True composite_expr_type composite_expr reqs_ts
+		  		= requirementsOfSelectors ti (Yes elem_expr) composite_expr selectors True False composite_expr_type composite_expr reqs_ts
 		| has_array_selection
 			# ts = { ts & ts_expr_heap = storeAttribute opt_composite_expr_ptr TA_Unique ts.ts_expr_heap }
 			= (composite_expr_type, No, (reqs, ts))
@@ -1560,21 +1563,29 @@ where
 		= (abort ("Error in requirements\n" ---> expr), No, reqs_ts)


-requirementsOfSelectors ti opt_expr expr [selector] tc_coercible sel_expr_type sel_expr reqs_ts 
-	= requirementsOfSelector ti opt_expr expr selector tc_coercible sel_expr_type sel_expr reqs_ts
-requirementsOfSelectors ti opt_expr expr [selector : selectors] tc_coercible sel_expr_type sel_expr reqs_ts 
-	# (has_array_selection, result_type, reqs_ts) = requirementsOfSelector ti No expr selector tc_coercible sel_expr_type sel_expr reqs_ts
-	# (have_array_selection, result_type, reqs_ts) = requirementsOfSelectors ti opt_expr expr selectors tc_coercible result_type sel_expr reqs_ts 
+requirementsOfSelectors ti opt_expr expr [selector] tc_coercible change_uselect sel_expr_type sel_expr reqs_ts 
+	= requirementsOfSelector ti opt_expr expr selector tc_coercible change_uselect sel_expr_type sel_expr reqs_ts
+requirementsOfSelectors ti opt_expr expr [selector : selectors] tc_coercible change_uselect sel_expr_type sel_expr reqs_ts 
+	# (has_array_selection, result_type, reqs_ts) = requirementsOfSelector ti No expr selector tc_coercible change_uselect sel_expr_type sel_expr reqs_ts
+	# (have_array_selection, result_type, reqs_ts) = requirementsOfSelectors ti opt_expr expr selectors tc_coercible False result_type sel_expr reqs_ts 
 	= (has_array_selection || have_array_selection, result_type, reqs_ts)

-requirementsOfSelector ti _ expr (RecordSelection field _) tc_coercible sel_expr_type sel_expr (reqs, ts )
+requirementsOfSelector ti _ expr (RecordSelection field _) tc_coercible change_uselect sel_expr_type sel_expr (reqs, ts )
 	# ({tst_args, tst_result, tst_attr_env}, ts) = standardFieldSelectorType (CP_Expression sel_expr) field ti ts
 	  req_type_coercions = [{ tc_demanded = hd tst_args, tc_offered = sel_expr_type, tc_position = CP_Expression sel_expr, tc_coercible = tc_coercible } : 
 	  			reqs.req_type_coercions ]
 	= (False, tst_result, ({ reqs & req_type_coercions = req_type_coercions }, ts))
-requirementsOfSelector ti opt_expr expr (ArraySelection {glob_object = {ds_ident,ds_index,ds_arity},glob_module} expr_ptr index_expr) tc_coercible sel_expr_type sel_expr (reqs, ts) 
+requirementsOfSelector ti opt_expr expr (ArraySelection {glob_object = {ds_ident,ds_index,ds_arity},glob_module} expr_ptr index_expr) tc_coercible change_uselect sel_expr_type sel_expr (reqs, ts) 
 	# {me_type} = ti.ti_common_defs.[glob_module].com_member_defs.[ds_index]
 	  ({tst_attr_env,tst_args,tst_result,tst_context}, ts) = freshSymbolType (Yes (CP_Expression expr)) cWithFreshContextVars me_type ti.ti_common_defs ts
+	# (tst_args, tst_result, ts)
+		=	case ds_ident.id_name of
+				// RWS FIXME: use predef symbols
+				"uselect"
+					| change_uselect
+						-> change_uselect_attributes tst_args tst_result ts
+				_
+					-> (tst_args, tst_result, ts)
 	  (dem_array_type, dem_index_type, rest_type) = array_and_index_type tst_args
 	  reqs ={ reqs & req_attr_coercions = tst_attr_env ++ reqs.req_attr_coercions}
 	  (index_type, opt_expr_ptr, (reqs, ts)) = requirements ti index_expr (reqs, ts)
@@ -1601,6 +1612,24 @@ where
 						tc_position = CP_Expression elem_expr, tc_coercible = True } : reqs.req_type_coercions ]}
 		= (reqs, ts)

+	/*
+		change
+			uselect	:: !u:(a  e) !Int -> ( e, !u:(a  e)) | uselect_u e
+		to
+			uselect	:: !u:(a .e) !Int -> (.e, !u:(a .e)) | uselect_u e
+		(necessary for uselects in updates)
+	*/
+	change_uselect_attributes :: [AType] AType u:TypeState  -> ([AType], AType, u:TypeState)
+	change_uselect_attributes args=:[arg_array=:{at_type=aa :@: [ae]}, arg_int]
+					result=:{at_type=TA tuple_symb [result_element, result_array=:{at_type=ra :@: [re]}]} ts
+		# (attribute, ts) =	freshAttribute ts
+		# args = [{arg_array & at_type = aa :@: [{ae & at_attribute = attribute}]}, arg_int]
+		# result = {result & at_type = TA tuple_symb [{result_element & at_attribute = attribute}, {result_array & at_type=ra :@: [{re & at_attribute = attribute}]}]}
+		= (args, result, ts)
+	change_uselect_attributes _ _ ts
+		= abort "type.icl, change_uselect_attributes: wrong type for uselect"
+
+
 possibly_accumulate_reqs_in_new_group position state_transition reqs_ts
 	:== possibly_accumulate_reqs position reqs_ts
  where