Bug fixes: default cases and (more or less) correct types for generated case and let expressions in the conversion of dynamics

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

1 files changed, 97 insertions, 78 deletions

diff --git a/frontend/refmark.icl b/frontend/refmark.icl
index c73df63..6c2ef7d 100644
--- a/frontend/refmark.icl
+++ b/frontend/refmark.icl
@@ -6,13 +6,13 @@ import syntax, Heap, typesupport, check, overloading, unitype, utilities //, RWS
 
 NotASelector :== -1
 
-class refMark expr ::  ![[FreeVar]] !Int !expr !*VarHeap -> *VarHeap
+class refMark expr ::  ![[FreeVar]] !Int !(Optional Expression) !expr !*VarHeap -> *VarHeap
 
 
 instance refMark [a] | refMark a
 where
-	refMark free_vars sel list var_heap
-		= foldSt (refMark free_vars sel) list var_heap
+	refMark free_vars sel _ list var_heap
+		= foldSt (refMark free_vars sel No) list var_heap
 
 collectAllSelections [] cum_sels
 	= cum_sels
@@ -34,7 +34,6 @@ where
 	save_occurrence {fv_name,fv_info_ptr} var_heap
 		# (VI_Occurrence old_occ=:{occ_ref_count,occ_previous}, var_heap) = readPtr fv_info_ptr var_heap
 		= var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = RC_Unused, occ_previous = [occ_ref_count : occ_previous] } )
-	
 
 adjustRefCount sel RC_Unused var_expr_ptr
 	| sel == NotASelector
@@ -77,7 +76,7 @@ refMarkOfVariable free_vars sel (VI_Occurrence var_occ) var_name var_info_ptr va
 	= case var_occ.occ_bind of // ---> ("refMarkOfVariable", var_name,occ_ref_count,var_occ.occ_ref_count) of
 		OB_OpenLet let_expr
 			# var_heap = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count, occ_bind = OB_LockedLet let_expr })
-			-> refMark free_vars sel let_expr var_heap
+			-> refMark free_vars sel No let_expr var_heap
 		OB_Pattern used_pattern_vars occ_bind
 			-> markPatternVariables sel used_pattern_vars (var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count }))
 		_
@@ -86,33 +85,40 @@ refMarkOfVariable free_vars sel (VI_Occurrence var_occ) var_name var_info_ptr va
 
 instance refMark BoundVar
 where
-	refMark free_vars sel {var_name,var_expr_ptr,var_info_ptr} var_heap
+	refMark free_vars sel _ {var_name,var_expr_ptr,var_info_ptr} var_heap
 		# (var_occ, var_heap) = readPtr var_info_ptr var_heap
 		= refMarkOfVariable free_vars sel var_occ var_name var_info_ptr var_expr_ptr var_heap
+
+combineDefaults outer_default No explicit
+	| explicit
+		= No
+		= outer_default
+combineDefaults outer_default this_default explicit
+	= this_default
 			
 instance refMark Expression
 where
-	refMark free_vars sel (Var var) var_heap
-		= refMark free_vars sel var var_heap
-	refMark free_vars sel (App {app_args}) var_heap
-		= refMark free_vars NotASelector app_args var_heap
-	refMark free_vars sel (fun @ args) var_heap
-		= refMark free_vars NotASelector args (refMark free_vars NotASelector fun var_heap)
-	refMark free_vars sel (Let {let_strict_binds,let_lazy_binds,let_expr}) var_heap
+	refMark free_vars sel _ (Var var) var_heap
+		= refMark free_vars sel No var var_heap
+	refMark free_vars sel _ (App {app_args}) var_heap
+		= refMark free_vars NotASelector No app_args var_heap
+	refMark free_vars sel _ (fun @ args) var_heap
+		= refMark free_vars NotASelector No args (refMark free_vars NotASelector No fun var_heap)
+	refMark free_vars sel def (Let {let_strict_binds,let_lazy_binds,let_expr}) var_heap
 		| isEmpty let_lazy_binds
 			# new_free_vars = [ [ lb_dst \\ {lb_dst} <- let_strict_binds ] : free_vars]
 			# (observing, var_heap) = binds_are_observing let_strict_binds var_heap
 			| observing
 				# var_heap = saveOccurrences free_vars var_heap
-				  var_heap = refMark new_free_vars NotASelector let_strict_binds var_heap
+				  var_heap = refMark new_free_vars NotASelector No let_strict_binds var_heap
 				  var_heap = saveOccurrences new_free_vars var_heap
-				  var_heap = refMark new_free_vars sel let_expr var_heap
+				  var_heap = refMark new_free_vars sel def let_expr var_heap
 				= let_combine free_vars var_heap
-				= refMark new_free_vars sel let_expr (refMark new_free_vars NotASelector let_strict_binds var_heap)
+				= refMark new_free_vars sel def let_expr (refMark new_free_vars NotASelector No let_strict_binds var_heap)
 			# new_free_vars = [ [ lb_dst \\ {lb_dst} <- let_strict_binds ++ let_lazy_binds ] : free_vars]
 			  var_heap = foldSt bind_variable let_strict_binds var_heap
 			  var_heap = foldSt bind_variable let_lazy_binds var_heap
-			= refMark new_free_vars sel let_expr var_heap
+			= refMark new_free_vars sel def let_expr var_heap
 
 		where
 		    binds_are_observing binds var_heap
@@ -135,26 +141,26 @@ where
 				# (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap
 				= var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_bind = OB_OpenLet lb_src })
 
-	refMark free_vars sel (Case {case_expr,case_guards,case_default}) var_heap
-		= refMarkOfCase free_vars sel case_expr case_guards case_default var_heap
-	refMark free_vars sel (Selection _ expr selectors) var_heap
-		= refMark free_vars (field_number selectors) expr var_heap
+	refMark free_vars sel def (Case {case_expr,case_guards,case_default,case_explicit}) var_heap
+		= refMarkOfCase free_vars sel case_expr case_guards case_explicit (combineDefaults def case_default case_explicit) var_heap
+	refMark free_vars sel _ (Selection _ expr selectors) var_heap
+		= refMark free_vars (field_number selectors) No expr var_heap
 	where
 		field_number [ RecordSelection _ field_nr : _ ]
 			= field_nr	
 		field_number _
 			= NotASelector	
-	refMark free_vars sel (Update expr1 selectors expr2) var_heap
-		# var_heap = refMark free_vars NotASelector expr1 var_heap
-		  var_heap = refMark free_vars NotASelector selectors var_heap
-		= refMark free_vars NotASelector expr2 var_heap
-	refMark free_vars sel (RecordUpdate cons_symbol expression expressions) var_heap
+	refMark free_vars sel _ (Update expr1 selectors expr2) var_heap
+		# var_heap = refMark free_vars NotASelector No expr1 var_heap
+		  var_heap = refMark free_vars NotASelector No selectors var_heap
+		= refMark free_vars NotASelector No expr2 var_heap
+	refMark free_vars sel _ (RecordUpdate cons_symbol expression expressions) var_heap
 		= ref_mark_of_record_expression free_vars expression expressions var_heap
 	where
 		ref_mark_of_record_expression free_vars (Var var) fields var_heap
 			= ref_mark_of_fields 0 free_vars fields var var_heap
 		ref_mark_of_record_expression free_vars expression fields var_heap
-			# var_heap = refMark free_vars NotASelector expression var_heap
+			# var_heap = refMark free_vars NotASelector No expression var_heap
 			= foldSt (ref_mark_of_field free_vars) fields var_heap
 	
 		ref_mark_of_fields field_nr free_vars [] var var_heap
@@ -164,19 +170,19 @@ where
 			  var_heap = refMarkOfVariable free_vars field_nr var_occ var_name var_info_ptr expr_ptr var_heap
 			= ref_mark_of_fields (inc field_nr) free_vars fields var var_heap
 		ref_mark_of_fields field_nr free_vars [{bind_src} : fields] var var_heap
-			# var_heap = refMark free_vars NotASelector bind_src var_heap
+			# var_heap = refMark free_vars NotASelector No bind_src var_heap
 			= ref_mark_of_fields (inc field_nr) free_vars fields var var_heap
 
 		ref_mark_of_field free_vars {bind_src} var_heap
-			= refMark free_vars NotASelector bind_src var_heap
+			= refMark free_vars NotASelector No bind_src var_heap
 
-	refMark free_vars sel (TupleSelect _ arg_nr expr) var_heap
-		= refMark free_vars arg_nr expr var_heap
-	refMark free_vars sel (MatchExpr _ _ expr) var_heap
-		= refMark free_vars sel expr var_heap
-	refMark free_vars sel EE var_heap
+	refMark free_vars sel _ (TupleSelect _ arg_nr expr) var_heap
+		= refMark free_vars arg_nr No expr var_heap
+	refMark free_vars sel _ (MatchExpr _ _ expr) var_heap
+		= refMark free_vars sel No expr var_heap
+	refMark free_vars sel _ EE var_heap
 		= var_heap
-	refMark _ _ _ var_heap
+	refMark _ _ _ _ var_heap
 		= var_heap
 
 
@@ -185,21 +191,15 @@ isUsed _			= True
 
 instance refMark LetBind
 where
-	refMark free_vars sel {lb_src} var_heap
-		= refMark free_vars NotASelector lb_src var_heap
+	refMark free_vars sel _ {lb_src} var_heap
+		= refMark free_vars NotASelector No lb_src var_heap
 
-/* MW0 not necessary anymore
-instance refMark (Bind a b) | refMark a
-where
-	refMark free_vars sel {bind_src} var_heap
-		= refMark free_vars NotASelector bind_src var_heap
-*/
 
 instance refMark Selection
 where
-	refMark free_vars _ (ArraySelection _ _ index_expr) var_heap
-		= refMark free_vars NotASelector index_expr var_heap
-	refMark free_vars _ _ var_heap
+	refMark free_vars _ _ (ArraySelection _ _ index_expr) var_heap
+		= refMark free_vars NotASelector No index_expr var_heap
+	refMark free_vars _ _ _ var_heap
 		= var_heap
 
 collectUsedFreeVariables free_vars var_heap
@@ -257,26 +257,28 @@ where
 			_
 				-> var_heap
 
-refMarkOfCase free_vars sel expr (AlgebraicPatterns type patterns) defaul var_heap
-	= ref_mark_of_algebraic_case free_vars sel expr patterns defaul var_heap
+refMarkOfCase free_vars sel expr (AlgebraicPatterns type patterns) explicit defaul var_heap
+	= ref_mark_of_algebraic_case free_vars sel expr patterns explicit defaul var_heap
 where
-	ref_mark_of_algebraic_case free_vars sel (Var {var_name,var_info_ptr,var_expr_ptr}) patterns defaul var_heap
+	ref_mark_of_algebraic_case free_vars sel (Var {var_name,var_info_ptr,var_expr_ptr}) patterns explicit defaul var_heap
 		# (VI_Occurrence var_occ=:{occ_bind,occ_ref_count}, var_heap) = readPtr var_info_ptr var_heap
 		= case occ_bind of
 			OB_Empty
-				-> ref_mark_of_algebraic_case_with_variable_pattern False var_info_ptr var_expr_ptr var_occ free_vars sel patterns defaul var_heap
+				-> ref_mark_of_algebraic_case_with_variable_pattern False var_info_ptr var_expr_ptr var_occ free_vars sel patterns explicit defaul var_heap
 			OB_OpenLet let_expr
 				# var_heap = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count, occ_bind = OB_LockedLet let_expr })
-				  var_heap = refMark free_vars sel let_expr var_heap
-				-> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel patterns defaul var_heap
+				  var_heap = refMark free_vars sel No let_expr var_heap
+				-> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel patterns explicit defaul var_heap
 			OB_LockedLet _
-				-> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel patterns defaul var_heap
-	ref_mark_of_algebraic_case free_vars sel expr patterns defaul var_heap
-		= ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns defaul var_heap
+				-> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel patterns explicit defaul var_heap
+			OB_Pattern vars ob
+				-> ref_mark_of_algebraic_case_with_variable_pattern False var_info_ptr var_expr_ptr var_occ free_vars sel patterns explicit defaul var_heap
+	ref_mark_of_algebraic_case free_vars sel expr patterns explicit defaul var_heap
+		= ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns explicit defaul var_heap
 
 	ref_mark_of_algebraic_case_with_variable_pattern with_composite_pattern var_info_ptr var_expr_ptr {occ_ref_count = RC_Unused}
-					free_vars sel patterns case_default var_heap
-		# var_heap = ref_mark_of_patterns with_composite_pattern free_vars sel (Yes var_info_ptr) patterns case_default var_heap
+					free_vars sel patterns case_explicit case_default var_heap
+		# var_heap = ref_mark_of_patterns with_composite_pattern free_vars sel (Yes var_info_ptr) patterns case_explicit case_default var_heap
 		  (VI_Occurrence var_occ, var_heap) = readPtr var_info_ptr var_heap
 		= case var_occ.occ_ref_count of
 				RC_Unused
@@ -286,33 +288,44 @@ where
 					-> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ &
 								occ_ref_count = RC_Used { rcu & rcu_uniquely = [var_expr_ptr : rcu.rcu_uniquely] }})					
 	ref_mark_of_algebraic_case_with_variable_pattern with_composite_pattern var_info_ptr var_expr_ptr
-			var_occ=:{occ_ref_count = RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}} free_vars sel patterns case_default var_heap
+			var_occ=:{occ_ref_count = RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}} free_vars sel patterns case_explicit case_default var_heap
 		# var_occ = { var_occ & occ_ref_count = RC_Used { rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ [var_expr_ptr : rcu_multiply]),
 														  rcu_uniquely = [], rcu_selectively = [] }}
 		  var_heap = var_heap <:= (var_info_ptr, VI_Occurrence var_occ )
-		= ref_mark_of_patterns with_composite_pattern free_vars sel (Yes var_info_ptr) patterns case_default var_heap
+		= ref_mark_of_patterns with_composite_pattern free_vars sel (Yes var_info_ptr) patterns case_explicit case_default var_heap
 
-	ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns case_default var_heap
-		# var_heap = refMark free_vars NotASelector expr var_heap
-		= ref_mark_of_patterns True free_vars sel No patterns case_default var_heap
+	ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns case_explicit case_default var_heap
+		# var_heap = refMark free_vars NotASelector No expr var_heap
+		= ref_mark_of_patterns True free_vars sel No patterns case_explicit case_default var_heap
 
-	ref_mark_of_patterns with_composite_pattern free_vars sel opt_pattern_var patterns case_default var_heap
+	ref_mark_of_patterns with_composite_pattern free_vars sel opt_pattern_var patterns case_explicit case_default var_heap
 		# (local_lets, var_heap) = collectLocalLetVars free_vars var_heap
 		  (with_pattern_bindings, pattern_depth, used_lets, var_heap)
-			= foldSt (ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets) patterns (False, 0, [], var_heap)		
+			= foldSt (ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets (propagateDefault case_explicit case_default))
+								patterns (False, 0, [], var_heap)		
 		= refMarkOfDefault (with_composite_pattern && with_pattern_bindings) pattern_depth free_vars sel case_default used_lets var_heap
 
-	ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets {ap_vars,ap_expr}
+	ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets def {ap_vars,ap_expr}
 					(with_pattern_bindings, pattern_depth, used_lets, var_heap) 
 		# pattern_depth = inc pattern_depth
 		  var_heap = saveOccurrences free_vars var_heap
 		  used_pattern_vars = collectPatternsVariables ap_vars
 		  var_heap = bind_optional_pattern_variable opt_pattern_var used_pattern_vars var_heap
-		  var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel ap_expr var_heap
+		  var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel def ap_expr var_heap
 		  var_heap = restore_binding_of_pattern_variable opt_pattern_var used_pattern_vars var_heap
 		  (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap)
+		  var_heap = clear_local_vars used_pattern_vars var_heap
 		= (with_pattern_bindings || not (isEmpty used_pattern_vars), pattern_depth, used_lets, var_heap)
 	
+	clear_local_vars vars var_heap
+		= foldSt clear_occurrence vars var_heap
+	where
+		clear_occurrence ({fv_name,fv_info_ptr},_) var_heap 
+			# (var_info, var_heap) = readPtr fv_info_ptr var_heap
+			= case var_info of
+				VI_Occurrence occ
+					-> var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_previous = [], occ_bind = OB_Empty })
+
 	bind_optional_pattern_variable _ [] var_heap
 		= var_heap
 	bind_optional_pattern_variable (Yes var_info_ptr) used_pattern_vars var_heap
@@ -330,41 +343,47 @@ where
 	restore_binding_of_pattern_variable _ used_pattern_vars var_heap
 		= var_heap
 	
-refMarkOfCase free_vars sel expr (BasicPatterns type patterns) defaul var_heap
-	# var_heap = refMark free_vars NotASelector expr var_heap
+refMarkOfCase free_vars sel expr (BasicPatterns type patterns) explicit defaul var_heap
+	# var_heap = refMark free_vars NotASelector No expr var_heap
 	  (local_lets, var_heap) = collectLocalLetVars free_vars var_heap
-	  (pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_basic_pattern free_vars sel local_lets) patterns (0, [], var_heap)
+	  (pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_basic_pattern free_vars sel local_lets (propagateDefault explicit defaul))
+	  		patterns (0, [], var_heap)
 	= refMarkOfDefault False pattern_depth free_vars sel defaul used_lets var_heap
 //		---> ("refMarkOfCase", expr, [ (bp_value, bp_expr) \\ {bp_value, bp_expr} <- patterns])
 where
-	ref_mark_of_basic_pattern free_vars sel local_lets {bp_expr} (pattern_depth, used_lets, var_heap)
+	ref_mark_of_basic_pattern free_vars sel local_lets def {bp_expr} (pattern_depth, used_lets, var_heap)
 		# pattern_depth = inc pattern_depth
 		  var_heap = saveOccurrences free_vars var_heap
-		  var_heap = refMark free_vars sel bp_expr var_heap
+		  var_heap = refMark free_vars sel def bp_expr var_heap
 		  (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap)
 		= (pattern_depth, used_lets, var_heap)
 
-refMarkOfCase free_vars sel expr (DynamicPatterns patterns) defaul var_heap
+refMarkOfCase free_vars sel expr (DynamicPatterns patterns) explicit defaul var_heap
 	# var_heap = saveOccurrences free_vars var_heap
-	  var_heap = refMark free_vars NotASelector expr var_heap
+	  var_heap = refMark free_vars NotASelector No expr var_heap
 	  (used_free_vars, var_heap) = collectUsedFreeVariables free_vars var_heap
 	  var_heap = parCombine free_vars var_heap
 	  (local_lets, var_heap) = collectLocalLetVars free_vars var_heap
-	  (pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_dynamic_pattern free_vars sel local_lets) patterns (0, [], var_heap)
+	  (pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_dynamic_pattern free_vars sel local_lets (propagateDefault explicit defaul)) patterns (0, [], var_heap)
 	= refMarkOfDefault True pattern_depth free_vars sel defaul used_lets var_heap
 where
-	ref_mark_of_dynamic_pattern free_vars sel local_lets {dp_var, dp_rhs} (pattern_depth, used_lets, var_heap)
+	ref_mark_of_dynamic_pattern free_vars sel local_lets def {dp_var, dp_rhs} (pattern_depth, used_lets, var_heap)
 		# pattern_depth = inc pattern_depth
 		  var_heap = saveOccurrences free_vars var_heap
 		  used_pattern_vars = collectPatternsVariables [dp_var]
-		  var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel dp_rhs var_heap
+		  var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel def dp_rhs var_heap
 		  (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap)
 		= (pattern_depth, used_lets, var_heap)
 
+propagateDefault case_explicit case_default
+	| case_explicit
+		= No
+		= case_default
+
 refMarkOfDefault do_par_combine pattern_depth free_vars sel (Yes expr) used_lets var_heap
 	# pattern_depth = inc pattern_depth
 	  var_heap = saveOccurrences free_vars var_heap
-	  var_heap = refMark free_vars sel expr var_heap
+	  var_heap = refMark free_vars sel No expr var_heap
 	  var_heap = setUsedLetVars used_lets var_heap
 	= caseCombine do_par_combine free_vars var_heap pattern_depth
 refMarkOfDefault do_par_combine pattern_depth free_vars sel No used_lets var_heap
@@ -494,7 +513,7 @@ where
 			coercion_env subst type_def_infos var_heap expr_heap error
 	# variables = tb_args ++ fi_local_vars
 	  (subst, type_def_infos, var_heap, expr_heap) = clear_occurrences variables subst type_def_infos var_heap expr_heap
-	  var_heap = refMark [tb_args] NotASelector tb_rhs var_heap // (tb_rhs ---> ("makeSharedReferencesNonUnique", fun_symb, tb_rhs)) var_heap
+	  var_heap = refMark [tb_args] NotASelector No tb_rhs var_heap // (tb_rhs ---> ("makeSharedReferencesNonUnique", fun_symb)) var_heap
 	  position = newPosition fun_symb fun_pos
 	  (coercion_env, var_heap, expr_heap, error) = make_shared_vars_non_unique variables coercion_env var_heap expr_heap
 	  		(setErrorAdmin position error)