implement pattern matching of strict, unboxed and overloaded lists

in let, with and where expressions


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

5 files changed, 122 insertions, 23 deletions

diff --git a/backend/backendconvert.icl b/backend/backendconvert.icl
index 23ab64d..73475dd 100644
--- a/backend/backendconvert.icl
+++ b/backend/backendconvert.icl
@@ -1866,7 +1866,17 @@ where
 	convertExpr (TupleSelect {ds_arity} n expr)
 		=	beTupleSelectNode ds_arity n (convertExpr expr)
 	convertExpr (MatchExpr {glob_module, glob_object={ds_index,ds_arity}} expr)
-		=	beMatchNode ds_arity (beConstructorSymbol glob_module ds_index) (convertExpr expr)
+		| glob_module==cPredefinedModuleIndex
+			&& (let
+					pd_cons_index=ds_index+FirstConstructorPredefinedSymbolIndex
+				in
+					pd_cons_index==PD_UnboxedConsSymbol || pd_cons_index==PD_UnboxedTailStrictConsSymbol || pd_cons_index==PD_OverloadedConsSymbol)
+			= case expr of
+				App {app_args=[src_expr],app_symb={symb_kind=SK_Function {glob_module=decons_module,glob_object=deconsindex}}}
+					->	beMatchNode ds_arity (beOverloadedConsSymbol glob_module ds_index decons_module deconsindex) (convertExpr src_expr)
+				_
+					->	convertExpr expr
+			=	beMatchNode ds_arity (beConstructorSymbol glob_module ds_index) (convertExpr expr)
 	convertExpr (Conditional {if_cond=cond, if_then, if_else=Yes else})
 		=	beIfNode (convertExpr cond) (convertExpr if_then) (convertExpr else)
 
diff --git a/backendC/CleanCompilerSources/codegen1.c b/backendC/CleanCompilerSources/codegen1.c
index 2ff6fe5..7e20ee0 100644
--- a/backendC/CleanCompilerSources/codegen1.c
+++ b/backendC/CleanCompilerSources/codegen1.c
@@ -2374,6 +2374,9 @@ SymbDef create_match_function (SymbolP constructor_symbol,int constructor_arity,
 	if (strict_constructor){
 		struct arg **rhs_arg_p,*lhs_arg;
 		StateP constructor_arg_state_p;
+#if STRICT_LISTS
+		StateS head_and_tail_states[2];
+#endif
 
 		lhs_function_arg=NewArgument (constructor_node);
 		lhs_function_arg->arg_state=StrictState;
@@ -2381,6 +2384,26 @@ SymbDef create_match_function (SymbolP constructor_symbol,int constructor_arity,
 		rhs_root=NewNode (TupleSymbol,NULL,constructor_arity);
 		rhs_arg_p=&rhs_root->node_arguments;
 
+#if STRICT_LISTS
+		if (constructor_symbol->symb_kind==cons_symb && constructor_symbol->symb_head_strictness>1 || constructor_symbol->symb_tail_strictness){
+			constructor_symbol->symb_def->sdef_constructor->cl_state_p;
+			
+			if (constructor_symbol->symb_head_strictness>1){
+				if (constructor_symbol->symb_head_strictness==4)
+					head_and_tail_states[0]=*constructor_symbol->symb_state_p;
+				else
+					head_and_tail_states[0]=StrictState;
+			} else
+				head_and_tail_states[0]=LazyState;
+			
+			if (constructor_symbol->symb_tail_strictness)
+				head_and_tail_states[1]=StrictState;
+			else
+				head_and_tail_states[1]=LazyState;
+			
+			constructor_arg_state_p=head_and_tail_states;
+		} else
+#endif
 		constructor_arg_state_p=constructor_symbol->symb_def->sdef_constructor->cl_state_p;
 
 		for_l (lhs_arg,constructor_node->node_arguments,arg_next){
diff --git a/backendC/CleanCompilerSources/codegen2.c b/backendC/CleanCompilerSources/codegen2.c
index abac86a..00cc491 100644
--- a/backendC/CleanCompilerSources/codegen2.c
+++ b/backendC/CleanCompilerSources/codegen2.c
@@ -2754,7 +2754,7 @@ LabDef *unboxed_cons_label (SymbolP cons_symbol_p)
 	if (cons_symbol_p->symb_unboxed_cons_state_p->state_type==SimpleState && BETWEEN (IntObj,FileObj,cons_symbol_p->symb_unboxed_cons_state_p->state_object))
 		return &unboxed_cons_labels[cons_symbol_p->symb_unboxed_cons_state_p->state_object-IntObj][cons_symbol_p->symb_tail_strictness];
 	else if (cons_symbol_p->symb_unboxed_cons_state_p->state_type==RecordState){
-		unboxed_record_cons_lab.lab_mod=NULL;
+		unboxed_record_cons_lab.lab_mod=ExportLocalLabels ? CurrentModule : NULL;
 		unboxed_record_cons_lab.lab_pref=cons_symbol_p->symb_tail_strictness ? "r_Cons#!" : "r_Cons#";
 		unboxed_record_cons_lab.lab_issymbol=False;
 		unboxed_record_cons_lab.lab_name=cons_symbol_p->symb_unboxed_cons_state_p->state_record_symbol->sdef_ident->ident_name;
@@ -3901,9 +3901,13 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe
 				}
 		}
 
-		if (!symbol_arity_eq_one)
+		if (!symbol_arity_eq_one){
+#if STRICT_LISTS
+			if (symbol->symb_kind==cons_symb && symbol->symb_head_strictness>1 || symbol->symb_tail_strictness)
+				strict_constructor=1;
+#endif
 			new_match_sdef=create_match_function (symbol,node->node_arity,strict_constructor);
-		else	
+		} else
 			new_match_sdef=create_select_and_match_function (symbol,strict_constructor);
 	
 		ConvertSymbolToDandNLabel (&name,&codelab,new_match_sdef);
@@ -4009,7 +4013,42 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe
 			*bsp_p += b_size;
 
 			AdjustTuple (a_size,b_size,asp_p,bsp_p,arity,demanded_state_array,constructor_args_state_p,a_size,b_size);
-		} else {
+		} else
+#if STRICT_LISTS
+		if (symbol->symb_kind==cons_symb && (symbol->symb_head_strictness>1 || symbol->symb_tail_strictness)){
+			StateS head_and_tail_states[2];
+			
+			if (symbol->symb_head_strictness>1){
+				if (symbol->symb_head_strictness==4)
+					head_and_tail_states[0]=*symbol->symb_state_p;
+				else
+					head_and_tail_states[0]=StrictState;
+			} else
+				head_and_tail_states[0]=LazyState;
+			
+			if (symbol->symb_tail_strictness)
+				head_and_tail_states[1]=StrictState;
+			else
+				head_and_tail_states[1]=LazyState;
+			
+			if (symbol->symb_head_strictness==4){
+				DetermineSizeOfState (head_and_tail_states[0],&a_size,&b_size);
+				++a_size;
+
+				GenReplRArgs (a_size,b_size);
+				*asp_p -= 1-a_size;
+				*bsp_p += b_size;
+
+				AdjustTuple (a_size,b_size,asp_p,bsp_p,2,demanded_state_array,head_and_tail_states,a_size,b_size);
+			} else {
+				GenReplArgs (2,2);
+				*asp_p -= 1-2;
+				
+				AdjustTuple (2,0,asp_p,bsp_p,2,demanded_state_array,head_and_tail_states,2,0);			
+			}
+		} else
+#endif
+		{
 			*asp_p-=1;
 			UnpackTuple (*asp_p,asp_p,bsp_p,True,demanded_state_arity,demanded_state_array);
 		}
diff --git a/frontend/checkFunctionBodies.icl b/frontend/checkFunctionBodies.icl
index c46ae3e..e27a602 100644
--- a/frontend/checkFunctionBodies.icl
+++ b/frontend/checkFunctionBodies.icl
@@ -58,9 +58,9 @@ get_unboxed_list_indices_and_decons_u_ident :: *CheckState -> (!Index,!Index,!In
 get_unboxed_list_indices_and_decons_u_ident cs=:{cs_predef_symbols,cs_x}
 	# (stdStrictLists_index,cs_predef_symbols)=cs_predef_symbols![PD_StdStrictLists].pds_def
 	# (cons_u_index,cs_predef_symbols)=cs_predef_symbols![PD_cons_u].pds_def
+	# (nil_u_index,cs_predef_symbols)=cs_predef_symbols![PD_nil_u].pds_def
 	# (decons_u_symbol,cs_predef_symbols)=cs_predef_symbols![PD_decons_u]
 	# decons_u_index=decons_u_symbol.pds_def
-	# (nil_u_index,cs_predef_symbols)=cs_predef_symbols![PD_nil_u].pds_def
 	# cs={cs & cs_predef_symbols=cs_predef_symbols,cs_x.x_needed_modules=cs_x.x_needed_modules bitor cNeedStdStrictLists}
 	= (stdStrictLists_index,cons_u_index,decons_u_index,nil_u_index,predefined_idents.[PD_decons_u],cs)
 
@@ -71,18 +71,18 @@ make_unboxed_list type_symbol expr_heap cs
 	# decons_expr = App {app_symb={symb_name=decons_u_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_u_index,glob_module=stdStrictLists_index}},app_args=[],app_info_ptr=new_info_ptr}
 	= (unboxed_list,decons_expr,expr_heap,cs)
 
-get_unboxed_tail_strict_list_indices_and_decons_u_ident :: *CheckState -> (!Index,!Index,!Index,!Index,!Ident,!*CheckState);
-get_unboxed_tail_strict_list_indices_and_decons_u_ident cs=:{cs_predef_symbols,cs_x}
+get_unboxed_tail_strict_list_indices_and_decons_uts_ident :: *CheckState -> (!Index,!Index,!Index,!Index,!Ident,!*CheckState);
+get_unboxed_tail_strict_list_indices_and_decons_uts_ident cs=:{cs_predef_symbols,cs_x}
 	# (stdStrictLists_index,cs_predef_symbols)=cs_predef_symbols![PD_StdStrictLists].pds_def
 	# (cons_uts_index,cs_predef_symbols)=cs_predef_symbols![PD_cons_uts].pds_def
+	# (nil_uts_index,cs_predef_symbols)=cs_predef_symbols![PD_nil_uts].pds_def
 	# (decons_uts_symbol,cs_predef_symbols)=cs_predef_symbols![PD_decons_uts]
 	# decons_uts_index=decons_uts_symbol.pds_def
-	# (nil_uts_index,cs_predef_symbols)=cs_predef_symbols![PD_nil_uts].pds_def
 	# cs={cs & cs_predef_symbols=cs_predef_symbols,cs_x.x_needed_modules=cs_x.x_needed_modules bitor cNeedStdStrictLists}
 	= (stdStrictLists_index,cons_uts_index,decons_uts_index,nil_uts_index,predefined_idents.[PD_decons_uts],cs)
 
 make_unboxed_tail_strict_list type_symbol expr_heap cs
-	# (stdStrictLists_index,cons_uts_index,decons_uts_index,nil_uts_index,decons_uts_ident,cs) = get_unboxed_tail_strict_list_indices_and_decons_u_ident cs
+	# (stdStrictLists_index,cons_uts_index,decons_uts_index,nil_uts_index,decons_uts_ident,cs) = get_unboxed_tail_strict_list_indices_and_decons_uts_ident cs
 	# unboxed_list=UnboxedTailStrictList type_symbol stdStrictLists_index decons_uts_index nil_uts_index
 	# (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap
 	# decons_expr = App {app_symb={symb_name=decons_uts_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_uts_index,glob_module=stdStrictLists_index}},app_args=[],app_info_ptr=new_info_ptr}
@@ -92,9 +92,9 @@ get_overloaded_list_indices_and_decons_ident :: *CheckState -> (!Index,!Index,!I
 get_overloaded_list_indices_and_decons_ident cs=:{cs_predef_symbols,cs_x}
 	# (stdStrictLists_index,cs_predef_symbols)=cs_predef_symbols![PD_StdStrictLists].pds_def
 	# (cons_index,cs_predef_symbols)=cs_predef_symbols![PD_cons].pds_def
+	# (nil_index,cs_predef_symbols)=cs_predef_symbols![PD_nil].pds_def
 	# (decons_symbol,cs_predef_symbols)=cs_predef_symbols![PD_decons]
 	# decons_index=decons_symbol.pds_def
-	# (nil_index,cs_predef_symbols)=cs_predef_symbols![PD_nil].pds_def
 	# cs={cs & cs_predef_symbols=cs_predef_symbols,cs_x.x_needed_modules=cs_x.x_needed_modules bitor cNeedStdStrictLists}
 	= (stdStrictLists_index,cons_index,decons_index,nil_index,predefined_idents.[PD_decons],cs)
 
@@ -1808,7 +1808,28 @@ transfromPatternIntoBind mod_index def_level (AP_Algebraic cons_symbol=:{glob_mo
 								position var_store expr_heap e_info cs
 					-> (opt_var_bind ++ binds, var_store, expr_heap, e_info, cs)
 					# (tuple_cons, cs) = getPredefinedGlobalSymbol (GetTupleConsIndex ds_arity) PD_PredefinedModule STE_Constructor ds_arity cs
-					  (match_var, match_bind, var_store, expr_heap)
+					# (src_expr,expr_heap,cs) = add_decons_call_for_overloaded_lists src_expr expr_heap cs
+						with
+							add_decons_call_for_overloaded_lists src_expr expr_heap cs
+								| glob_module==cPredefinedModuleIndex
+									# pd_cons_index=ds_index+FirstConstructorPredefinedSymbolIndex
+									| pd_cons_index==PD_UnboxedConsSymbol			
+										# (stdStrictLists_index,_,decons_u_index,_,decons_u_ident,cs) = get_unboxed_list_indices_and_decons_u_ident cs
+										# (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap
+										# decons_u_expr = App {app_symb={symb_name=decons_u_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_u_index,glob_module=stdStrictLists_index}},app_args=[src_expr],app_info_ptr=new_info_ptr}			
+										= (decons_u_expr,expr_heap,cs)
+									| pd_cons_index==PD_UnboxedTailStrictConsSymbol
+										# (stdStrictLists_index,_,decons_uts_index,_,decons_uts_ident,cs) = get_unboxed_tail_strict_list_indices_and_decons_uts_ident cs
+										# (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap
+										# decons_uts_expr = App {app_symb={symb_name=decons_uts_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_uts_index,glob_module=stdStrictLists_index}},app_args=[src_expr],app_info_ptr=new_info_ptr}
+										= (decons_uts_expr,expr_heap,cs)
+									| pd_cons_index==PD_OverloadedConsSymbol
+										# (stdStrictLists_index,_,decons_index,_,decons_ident,cs) = get_overloaded_list_indices_and_decons_ident cs
+										# (new_info_ptr,expr_heap) = newPtr EI_Empty expr_heap
+										# decons_expr = App {app_symb={symb_name=decons_ident,symb_kind=SK_OverloadedFunction {glob_object=decons_index,glob_module=stdStrictLists_index}},app_args=[src_expr],app_info_ptr=new_info_ptr}
+										= (decons_expr,expr_heap,cs)
+										= (src_expr,expr_heap,cs)
+					# (match_var, match_bind, var_store, expr_heap)
 						=  bind_match_expr (MatchExpr cons_symbol src_expr) opt_var_bind position var_store expr_heap
 					-> transform_sub_patterns mod_index def_level args tuple_cons.glob_object 0 match_var match_bind
 							position var_store expr_heap e_info cs
diff --git a/frontend/type.icl b/frontend/type.icl
index e5d91ab..ab6f71f 100644
--- a/frontend/type.icl
+++ b/frontend/type.icl
@@ -1547,17 +1547,23 @@ where
 		attributedBasicType {box=type} ts=:{ts_attr_store}
 			= ({ at_annotation = AN_None, at_attribute = TA_TempVar ts_attr_store, at_type = type}, {ts & ts_attr_store = inc ts_attr_store})
 
-	requirements ti (MatchExpr {glob_object={ds_arity, ds_index},glob_module} expr) (reqs, ts)
-		# cp = CP_Expression expr
-		  ({tst_result,tst_args,tst_attr_env}, ts) = standardLhsConstructorType cp ds_index glob_module ds_arity ti ts	
-		  (e_type, opt_expr_ptr, (reqs, ts)) = requirements ti expr (reqs, ts)
-		  reqs = { reqs & req_attr_coercions =  tst_attr_env ++ reqs.req_attr_coercions,
-		  				  req_type_coercions = [{ tc_demanded = tst_result, tc_offered = e_type, tc_position = cp, tc_coercible = True } : reqs.req_type_coercions ] }
-		  ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr tst_result.at_attribute ts.ts_expr_heap }
-		| ds_arity<>1
-			# tuple_type = MakeTypeSymbIdent { glob_object = PD_Arity2TupleTypeIndex+(ds_arity-2), glob_module = cPredefinedModuleIndex } predefined_idents.[PD_Arity2TupleType+(ds_arity-2)] ds_arity
-			= ({ at_type = TA tuple_type tst_args, at_attribute = TA_Unique, at_annotation = AN_None }, No, (reqs, ts))
-			= ( hd tst_args, No, (reqs, ts))
+	requirements ti (MatchExpr {glob_object={ds_arity, ds_index},glob_module} expr) reqs_ts=:(reqs, ts)
+		| glob_module==cPredefinedModuleIndex
+			&& (let
+					pd_cons_index=ds_index+FirstConstructorPredefinedSymbolIndex
+				in
+					pd_cons_index==PD_UnboxedConsSymbol || pd_cons_index==PD_UnboxedTailStrictConsSymbol || pd_cons_index==PD_OverloadedConsSymbol)
+			= requirements ti expr reqs_ts
+			# cp = CP_Expression expr
+			  ({tst_result,tst_args,tst_attr_env}, ts) = standardLhsConstructorType cp ds_index glob_module ds_arity ti ts	
+			  (e_type, opt_expr_ptr, (reqs, ts)) = requirements ti expr (reqs, ts)
+			  reqs = { reqs & req_attr_coercions =  tst_attr_env ++ reqs.req_attr_coercions,
+			  				  req_type_coercions = [{ tc_demanded = tst_result, tc_offered = e_type, tc_position = cp, tc_coercible = True } : reqs.req_type_coercions ] }
+			  ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr tst_result.at_attribute ts.ts_expr_heap }
+			| ds_arity<>1
+				# tuple_type = MakeTypeSymbIdent { glob_object = PD_Arity2TupleTypeIndex+(ds_arity-2), glob_module = cPredefinedModuleIndex } predefined_idents.[PD_Arity2TupleType+(ds_arity-2)] ds_arity
+				= ({ at_type = TA tuple_type tst_args, at_attribute = TA_Unique, at_annotation = AN_None }, No, (reqs, ts))
+				= ( hd tst_args, No, (reqs, ts))
 
 	requirements _ (AnyCodeExpr _ _ _) (reqs, ts)
 		# (fresh_v, ts) = freshAttributedVariable ts