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

2 files changed, 147 insertions, 108 deletions

diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl
index d22f5ab..76e25dc 100644
--- a/frontend/convertDynamics.icl
+++ b/frontend/convertDynamics.icl
@@ -317,7 +317,7 @@ where
 					//	loadandrun2 _ _ = abort "Loader: process and input do not match"
 					//
 					# (Yes old_case_default) = this_case_default
-					# (let_info_ptr,  ci) = let_ptr ci
+//					# (let_info_ptr,  ci) = let_ptr ci
 					# (default_var, ci) = newVariable "s" (VI_BoundVar {at_attribute=TA_None,at_annotation=AN_None,at_type=TE}) ci
 					# default_fv = varToFreeVar default_var 1
 					# ci
@@ -332,6 +332,8 @@ where
 						= map (patch_defaults new_case_default) algebraic_patterns
 					#  (algebraic_patterns, ci) = mapSt (convertDynamicsOfAlgebraicPattern cinp bound_vars nested_case_default)
 														(zip2 algebraic_patterns ct_cons_types) ci
+/* Sjaak */
+					# (let_info_ptr,  ci) = let_ptr 1 ci
 					# letje
 						= Let {
 							let_strict_binds	= []
@@ -408,7 +410,8 @@ where
 			[]	-> (App {	app_symb		= ci_symb_ident, //USE_TUPLES twoTuple_symb ci_symb_ident, //twoTuple_symb,
 							app_args 		= [dyn_expr, dyn_type_code],
 							app_info_ptr	= nilPtr }, ci)
-			_ 	#  (let_info_ptr,  ci) = let_ptr ci
+/* Sjaak */
+			_ 	#  (let_info_ptr,  ci) = let_ptr (length let_binds) ci
 				-> ( Let {	let_strict_binds	= [],
 							let_lazy_binds		= let_binds,
 							let_expr			= App {	app_symb		= ci_symb_ident, //USE_TUPLES twoTuple_symb ci_symb_ident,
@@ -438,7 +441,7 @@ where
 /* Sjaak ... */
 convertTypecode2 cinp (TCE_UniType uni_vars type_code) replace_tc_args binds placeholders_and_tc_args ci
 		# (let_binds,     ci) 	= createVariables uni_vars [] ci
-		  (let_info_ptr,  ci)	= let_ptr ci
+		  (let_info_ptr,  ci)	= let_ptr (length let_binds) ci
 		  (e, type_code_expr, binds, placeholders_and_tc_args, ci)	= convertTypecode2 cinp type_code False [] [] ci
 		= (e, Let {	let_strict_binds	= [],
 					let_lazy_binds		= let_binds,
@@ -642,12 +645,12 @@ convertDynamicPatterns cinp=:{cinp_st_args} bound_vars {case_expr, case_guards =
 
 																// c_1 ind_0
 	  (binds, expr, ci) = convert_dynamic_pattern cinp bound_vars new_default 1 opened_dynamic result_type case_default patterns ci
-	  (let_info_ptr, ci) = let_ptr ci
-
 	# ci
 		= { ci & ci_placeholders_and_tc_args=old_ci_placeholders_and_tc_args}
 	# (tc_binds,ci)
 		= foldSt remove_non_used_arg tc_binds ([],ci) 
+/* Sjaak */		
+	  (let_info_ptr, ci) = let_ptr (length  binds + length tc_binds + 1) ci
 
 // MW0	= (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ] ++ tc_binds, let_expr = expr, let_info_ptr = let_info_ptr}, ci)
 	= (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ] ++ tc_binds, let_expr = expr,
@@ -716,8 +719,7 @@ where
 		#		
 		  (coerce_symb, ci)		= getSymbol PD_coerce SK_Function (extended_unify_and_coerce 2 3) ci
 		  (twotuple, ci) 		= getTupleSymbol 2 ci
-		  (let_info_ptr, ci) 	= let_ptr ci
-		  (case_info_ptr, ci)	= case_ptr ci
+//Sjaak		  (case_info_ptr, ci)	= case_ptr ci
 		
 		  (coerce_result_var, ci)	= newVariable "result" VI_Empty ci
 		  coerce_result_fv 			= varToFreeVar coerce_result_var 1
@@ -747,26 +749,25 @@ where
 			= toExpression this_default ci
 			
 		#! app_args2 = extended_unify_and_coerce [Var a_ij_var, Var a_ij_tc_var] [Var a_ij_var, Var a_ij_tc_var, ci_module_id_symbol ]
+/* Sjaak ... */
 
-
-		# let_expr
-			= Let {
-					let_strict_binds	= []
-// MW0				,	let_lazy_binds		= (if (isNo this_default) [] [ {bind_src = opt opt_expr		,	bind_dst = c_inc_i_fv }]) ++ [
-// MW0										  { bind_src = App { app_symb = coerce_symb,  app_args = [Var a_ij_var, Var a_ij_tc_var],  app_info_ptr = nilPtr },
-// MW0										   bind_dst = coerce_result_fv }
-				,	let_lazy_binds		= (if (isNo this_default) [] [ {lb_src = opt opt_expr, lb_dst = c_inc_i_fv, lb_position = NoPos }]) ++ [
+		# let_lazy_binds		= (if (isNo this_default) [] [ {lb_src = opt opt_expr, lb_dst = c_inc_i_fv, lb_position = NoPos }]) ++ [
 										  { lb_src = App { app_symb = coerce_symb,  app_args = app_args2,  app_info_ptr = nilPtr },
 										   lb_dst = coerce_result_fv, lb_position = NoPos }
 										   ,
-// MW0										 { bind_src = TupleSelect twotuple 0 (Var coerce_result_var),
-// MW0										   bind_dst = coerce_bool_fv } : let_binds
 										 { lb_src = /*USE_TUPLES (*/ TupleSelect twotuple 0 (Var coerce_result_var) /*) sel_type*/,
 										   lb_dst = coerce_bool_fv, lb_position = NoPos } : let_binds
-										],
-							let_expr =
-							 Case {	case_expr 		= Var coerce_bool_var,
-		// MW was:												case_guards		= BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs}],
+										]
+		  (let_info_ptr, ci) 	= let_ptr (length let_lazy_binds) ci
+		  (case_info_ptr, ci)	= bool_case_ptr ci
+/* ... Sjaak */
+
+		# let_expr
+			= Let {
+					let_strict_binds	= []
+				,	let_lazy_binds		= let_lazy_binds
+				,	let_expr =
+							 Case {			case_expr 		= Var coerce_bool_var,
 											case_guards		= BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = new_dp_rhs, bp_position = NoPos }],
 											case_default	= default_expr,
 											case_ident		= No,
@@ -849,8 +850,7 @@ where
 		  /***  generate the expression  ***/
 	 	  (unify_symb, ci) 		= getSymbol (if generate_coerce PD_coerce PD_unify ) SK_Function (extended_unify_and_coerce 2 3) /*3 was 2 */ ci
 		  (twotuple, ci) 		= getTupleSymbol 2 ci
-		  (let_info_ptr, ci) 	= let_ptr ci
-		  (case_info_ptr, ci)	= case_ptr ci
+//Sjaak		  (case_info_ptr, ci)	= case_ptr ci
 		  (default_expr, ci) 	= toExpression this_default ci
 		  
 		  // was coercions
@@ -885,21 +885,20 @@ where
 			App module_symb
 		// ...TIJDELIJK
 */
+/* Sjaak ... */
+		  (let_info_ptr, ci) 	= let_ptr 2 ci
+		  (case_info_ptr, ci)	= bool_case_ptr ci
+/* ... Sjaak */
 
 		  app_args2 = extended_unify_and_coerce [opened_dynamic.opened_dynamic_type, type_code] [opened_dynamic.opened_dynamic_type, type_code, ci_module_id_symbol ]
 		  
 		  let_expr = Let {	let_strict_binds = [],
-// MW0		  					let_lazy_binds = [{ bind_src = App { app_symb = unify_symb,  app_args = [opened_dynamic.opened_dynamic_type, type_code],  app_info_ptr = nilPtr },
-// MW0		  								   bind_dst = unify_result_fv },
-// MW0		  								 { bind_src = TupleSelect twotuple 0 (Var unify_result_var),
-// MW0		  								   bind_dst = unify_bool_fv } : let_binds
 		  					let_lazy_binds = [{ lb_src = App { app_symb = unify_symb,  app_args = app_args2,  app_info_ptr = nilPtr },
 		  								   lb_dst = unify_result_fv, lb_position = NoPos },
 		  								 { lb_src = /*USE_TUPLES (*/ TupleSelect twotuple 0 (Var unify_result_var) /*) sel_type*/,
 		  								   lb_dst = unify_bool_fv, lb_position = NoPos } : let_binds
 		  								],
 		  					let_expr = Case {	case_expr 		= Var unify_bool_var,
-// MW was:												case_guards		= BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs}],
 												case_guards		= BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs, bp_position = NoPos }],
 												case_default	= default_expr,
 												case_ident		= No,
@@ -908,7 +907,6 @@ where
 												case_explicit	= False,
 // ... RWS
 												case_default_pos= NoPos }, // MW4++
-// MW0		  					let_info_ptr = let_info_ptr	}
 		  					let_info_ptr = let_info_ptr,
 		  					let_expr_position = NoPos }
 		  					
@@ -1177,6 +1175,9 @@ v_tc_placeholder		:== "tc_placeholder"
 
 a_aij_tc_var_name 	:== { id_name = "a_ij_tc", id_info = nilPtr }
 
+/* Sjaak ...
+WAS
+
 case_ptr :: !*ConversionInfo -> (ExprInfoPtr, !*ConversionInfo)
 case_ptr ci=:{ci_expr_heap}
 	# (expr_info_ptr, ci_expr_heap) = newPtr (EI_CaseType {	ct_pattern_type = empty_attributed_type,
@@ -1189,9 +1190,28 @@ let_ptr ci=:{ci_expr_heap}
 	# (expr_info_ptr, ci_expr_heap) = newPtr (EI_LetType (repeat empty_attributed_type)) ci_expr_heap
 	= (expr_info_ptr, {ci &  ci_expr_heap = ci_expr_heap})
 
+REPLACED BY:
+Sjaak ... */
+
+bool_case_ptr :: !*ConversionInfo -> (ExprInfoPtr, !*ConversionInfo)
+bool_case_ptr ci=:{ci_expr_heap}
+	# (expr_info_ptr, ci_expr_heap) = newPtr (EI_CaseType {	ct_pattern_type = toAType (TB BT_Bool),
+															ct_result_type = empty_attributed_type,
+															ct_cons_types = [[toAType (TB BT_Bool)]]}) ci_expr_heap
+	= (expr_info_ptr, {ci &  ci_expr_heap = ci_expr_heap})
+
+let_ptr :: !Int !*ConversionInfo -> (ExprInfoPtr, !*ConversionInfo)
+let_ptr nr_of_binds ci=:{ci_expr_heap}
+	# (expr_info_ptr, ci_expr_heap) = newPtr (EI_LetType (repeatn nr_of_binds empty_attributed_type)) ci_expr_heap
+	= (expr_info_ptr, {ci &  ci_expr_heap = ci_expr_heap})
+
+/* Sjaak ... */
+toAType :: Type -> AType
+toAType type = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = type }
 
 empty_attributed_type :: AType
-empty_attributed_type = { at_attribute = TA_Multi, at_annotation = AN_None, at_type = TE }
+empty_attributed_type = toAType TE
+/* ... Sjaak */
 
 
 isNo :: (Optional a) -> Bool
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)