remove differences in layout between the compiler and the iTask compiler

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

1 files changed, 40 insertions, 70 deletions

diff --git a/frontend/trans.icl b/frontend/trans.icl
index ad1e792..bfa2718 100644
--- a/frontend/trans.icl
+++ b/frontend/trans.icl
@@ -3197,13 +3197,13 @@ where
 
 determineProducer :: App ExprInfo Bool Bool Bool Bool [Expression] Int *{!Producer} ReadOnlyTI *TransformInfo -> *(!*{!Producer},![Expression],!*TransformInfo)
 determineProducer app=:{app_symb = symb=:{symb_kind = SK_Constructor _}, app_args} (EI_DictionaryType type) _ _ _ _
-				  new_args prod_index producers _ ti
+				  new_args prod_index producers _ ti=:{ti_var_heap}
 	# (app_args, (new_vars_and_types, free_vars, ti_var_heap)) 
-			= renewVariables app_args ti.ti_var_heap
+			= renewVariables app_args ti_var_heap
 	# prod	= PR_Class { app & app_args = app_args } new_vars_and_types type
-	= ( { producers & [prod_index] = prod }
+	= ( {producers & [prod_index] = prod}
 	  , mapAppend Var free_vars new_args
-	  , { ti & ti_var_heap = ti_var_heap }
+	  , {ti & ti_var_heap = ti_var_heap}
 	  )
 determineProducer app=:{app_symb = symb=:{symb_kind = SK_Constructor cons_index, symb_ident}, app_args} _ _ _ _ linear_bit
 				  new_args prod_index producers ro ti
@@ -3440,37 +3440,52 @@ where
 	is_a_producer _ 		= True
 
 :: *RenewState :== (![(BoundVar, Type)], ![BoundVar], !*VarHeap)
-// DvA: should be in typesupport?
-renewVariables :: ![Expression] !*VarHeap
-				-> (![Expression], !RenewState)
+
+renewVariables :: ![Expression] !*VarHeap -> (![Expression], !RenewState)
 renewVariables exprs var_heap
 	# (exprs, (new_vars, free_vars, var_heap))
-			= mapSt (mapExprSt map_expr preprocess_local_var postprocess_local_var)
-					exprs ([], [], var_heap)
+			= mapSt map_expr_st exprs ([], [], var_heap)
 	  var_heap
 	  		= foldSt (\{var_info_ptr} var_heap -> writeVarInfo var_info_ptr VI_Empty var_heap)
 	  				free_vars var_heap
 	= (exprs, (new_vars, free_vars, var_heap))
   where
-	map_expr :: !Expression !RenewState -> (!Expression, !RenewState)
-	map_expr (Var var=:{var_info_ptr, var_ident}) (new_vars_accu, free_vars_accu, var_heap)
-		# (var_info, var_heap)
-				= readPtr var_info_ptr var_heap
+	map_expr_st (Var var=:{var_info_ptr, var_ident}) (new_vars_accu, free_vars_accu, var_heap)
+		# (var_info, var_heap) = readPtr var_info_ptr var_heap
 		= case var_info of
 			VI_Extended _ (VI_Forward new_var)
-				-> ( Var new_var
-				   , (new_vars_accu, free_vars_accu, var_heap))
+				-> (Var new_var, (new_vars_accu, free_vars_accu, var_heap))
 			VI_Extended evi=:(EVI_VarType var_type) _
 				# (new_var, var_heap)
-						= allocate_and_bind_new_var var_ident var_info_ptr evi var_heap
-				-> ( Var new_var
-				   , ( [(new_var, var_type.at_type) : new_vars_accu]
-				     , [var:free_vars_accu]
-				     , var_heap
-				     )
-				   )
-			_	-> abort "map_expr in module trans does not match\n"// <<- ("map_expr",var,var_info)
-	map_expr x st = (x, st)
+					= allocate_and_bind_new_var var_ident var_info_ptr evi var_heap
+				-> (Var new_var, ([(new_var, var_type.at_type) : new_vars_accu], [var:free_vars_accu], var_heap))
+	map_expr_st (App app=:{app_args}) st
+		# (app_args, st) = mapSt map_expr_st app_args st
+		= (App { app & app_args = app_args }, st)
+	map_expr_st (Let lad=:{let_lazy_binds, let_strict_binds, let_expr}) st
+		# (lazy_free_vars, st)
+				= mapSt (\{lb_dst} st -> preprocess_local_var lb_dst st) let_lazy_binds st
+		  (strict_free_vars, st)
+				= mapSt (\{lb_dst} st -> preprocess_local_var lb_dst st) let_strict_binds st
+		  (lazy_rhss, st)
+		  		= mapSt (\{lb_src} st -> map_expr_st lb_src st) let_lazy_binds st
+		  (strict_rhss, st)
+		  		= mapSt (\{lb_src} st -> map_expr_st lb_src st) let_strict_binds st
+		  (let_expr, st)
+		  		= map_expr_st let_expr st
+		  st	= foldSt (\{lb_dst} st -> postprocess_local_var lb_dst st) let_lazy_binds st
+		  st	= foldSt (\{lb_dst} st -> postprocess_local_var lb_dst st) let_strict_binds st
+		  expr	= Let { lad
+		  			& let_lazy_binds	= add_let_binds lazy_free_vars lazy_rhss let_lazy_binds
+		  			, let_strict_binds	= add_let_binds strict_free_vars strict_rhss let_strict_binds
+		  			, let_expr			= let_expr
+					}
+		= (expr, st)
+	map_expr_st (Selection a expr b) st
+		# (expr, st) = map_expr_st expr st
+		= (Selection a expr b, st)
+	map_expr_st expr=:(BasicExpr _) st 
+		= (expr, st)
 
 	preprocess_local_var :: !FreeVar !RenewState -> (!FreeVar, !RenewState)
 	preprocess_local_var fv=:{fv_ident, fv_info_ptr} (new_vars_accu, free_vars_accu, var_heap)
@@ -3492,51 +3507,6 @@ renewVariables exprs var_heap
 	postprocess_local_var :: !FreeVar !RenewState -> RenewState
 	postprocess_local_var {fv_info_ptr} (a, b, var_heap)
 		= (a, b, writeVarInfo fv_info_ptr VI_Empty var_heap)
-	
-//@ ExprSt ops
-
-mapExprSt f map_free_var postprocess_free_var expr st
-	:== map_expr_st expr st
-where
-	map_expr_st expr=:(Var bound_var) st
-		= f expr st
-	map_expr_st (App app=:{app_args}) st
-		# (app_args, st) = mapSt map_expr_st app_args st
-		= f (App { app & app_args = app_args }) st
-	map_expr_st (Let lad=:{let_lazy_binds, let_strict_binds, let_expr}) st
-		# (lazy_free_vars, st)
-				= mapSt (\{lb_dst} st -> map_free_var lb_dst st) let_lazy_binds st
-		  (strict_free_vars, st)
-				= mapSt (\{lb_dst} st -> map_free_var lb_dst st) let_strict_binds st
-		  (lazy_rhss, st)
-		  		= mapSt (\{lb_src} st -> map_expr_st lb_src st) let_lazy_binds st
-		  (strict_rhss, st)
-		  		= mapSt (\{lb_src} st -> map_expr_st lb_src st) let_strict_binds st
-		  (let_expr, st)
-		  		= map_expr_st let_expr st
-		  st	= foldSt (\{lb_dst} st -> postprocess_free_var lb_dst st) let_lazy_binds st
-		  st	= foldSt (\{lb_dst} st -> postprocess_free_var lb_dst st) let_strict_binds st
-		  expr	= Let { lad
-		  			& let_lazy_binds	= add_let_binds lazy_free_vars lazy_rhss let_lazy_binds
-		  			, let_strict_binds	= add_let_binds strict_free_vars strict_rhss let_strict_binds
-		  			, let_expr			= let_expr
-					}
-		= f expr st
-	map_expr_st (Selection a expr b) st
-		# (expr, st) = map_expr_st expr st
-		= f (Selection a expr b) st
-
-	// AA:
-	map_expr_st expr=:(BasicExpr _) st 
-		= f expr st
-	map_expr_st (expr @ exprs) st 
-		= abort "trans.icl: map_expr_st (expr @ exprs) not implemented\n"
-	map_expr_st (TupleSelect ds n expr) st 
-		= abort "trans.icl: map_expr_st (TupleSelect ds n expr) not implemented\n"
-	map_expr_st (DynamicExpr dyn_expr) st 
-		= abort "trans.icl: map_expr_st (DynamicExpr dyn_expr) not implemented\n"
-	map_expr_st _ st = abort "trans.icl: map_expr_st does not match !!!!!!!!!!!!\n"
-
 
 foldrExprSt f expr st :== foldr_expr_st expr st
   where
@@ -3838,7 +3808,7 @@ where
 		  	, ets_contains_unexpanded_abs_syn_type	= False
 		  	}
 		#! (_,(st_result,st_args), {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap})
-		  		= expandSynTypes (if (fi_properties bitand FI_HasTypeSpec == 0) (RemoveAnnotationsMask bitor ExpandAbstractSynTypesMask) ExpandAbstractSynTypesMask) common_defs (st_result,st_args) ets
+				= expandSynTypes (if (fi_properties bitand FI_HasTypeSpec == 0) (RemoveAnnotationsMask bitor ExpandAbstractSynTypesMask) ExpandAbstractSynTypesMask) common_defs (st_result,st_args) ets
 		# ft = { ft &  st_result = st_result, st_args = st_args }
 		| fi_group_index >= size groups
 			= abort ("add_new_function_to_group "+++ toString fi_group_index+++ "," +++ toString (size groups) +++ "," +++ toString gf_fun_index)