bug fixes, ModuleID argument in T_ypeConsSymbol, added _SystemDynamic

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

1 files changed, 75 insertions, 20 deletions

diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl
index 76e25dc..c5f7ed0 100644
--- a/frontend/convertDynamics.icl
+++ b/frontend/convertDynamics.icl
@@ -1,13 +1,14 @@
 implementation module convertDynamics
 
-import syntax, transform, utilities, convertcases
+import syntax, transform, utilities, convertcases /* MV ... */, compilerSwitches /* ... MV */
+from type_io_common import PredefinedModuleName
 // Optional
 USE_TUPLES tuple b :== b;					// change also StdDynamic.icl and recompile all applications
 extended_unify_and_coerce no yes :== no;	// change also _unify and _coerce in StdDynamic
 
 //import pp;
 
-APPEND_DEFINING_TYPE_MODULE_NAMES_TO_TYPE_NAMES yes no :== no
+APPEND_DEFINING_TYPE_MODULE_NAMES_TO_TYPE_NAMES yes no :== yes
 import type_io; 
 //import RWSDebug;
 
@@ -28,6 +29,8 @@ import type_io;
 	,	ci_sel_type_field						:: Expression -> Expression  //Optional (!Int,!(Global DefinedSymbol))
 	,	ci_sel_value_field						:: Expression -> Expression  //Optional (!Int,!(Global DefinedSymbol))
 	,	ci_module_id_symbol						:: Expression
+	,	ci_internal_type_id						:: Expression
+	,	ci_module_id							:: Optional LetBind
 	}
 
 ::	ConversionInput =
@@ -106,7 +109,7 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_
 
 				
 	// ... TD
-	# ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamics]
+	# ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamic]
 	#! (dynamic_temp_symb_ident,ci_sel_value_field,ci_sel_type_field,predefined_symbols)
 		= case (pds_module == (-1) || pds_def == (-1)) of
 			True
@@ -174,13 +177,8 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_
 							= (\dynamic_expr -> Selection No dynamic_expr [RecordSelection value_defined_symbol sd_field_nr3])
 						-> (dynamic_temp_symb_ident, ci_sel_value_field, ci_sel_type_field,predefined_symbols)
 						
-	// get module id symbol
-	# ({pds_module, pds_def, pds_ident}, predefined_symbols)	= predefined_symbols![PD_ModuleConsSymbol]
-	# module_symb = 
-		{	app_symb 		= { symb_name = pds_ident, symb_kind = SK_Constructor { glob_module = pds_module, glob_object = pds_def}, symb_arity = 0 }
-		,	app_args 		= []
-		,	app_info_ptr	= nilPtr
-		}
+	# (module_symb,module_id_app,predefined_symbols)
+		= get_module_id_app predefined_symbols
 						
 	#! nr_of_funs = size fun_defs
 	# imported_types = {com_type_defs \\ {com_type_defs} <-: common_defs }
@@ -190,7 +188,9 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_
 							ci_new_functions = [], ci_new_variables = [], ci_fun_heap = newHeap, ci_next_fun_nr = nr_of_funs, ci_placeholders_and_tc_args = [],
 							ci_generated_global_tc_placeholders = False,
 							ci_used_tcs = [],ci_symb_ident = dynamic_temp_symb_ident , ci_sel_type_field =  ci_sel_type_field, ci_sel_value_field = ci_sel_value_field, 
-							ci_module_id_symbol = App module_symb })
+							ci_module_id_symbol = App module_symb,
+							ci_internal_type_id = module_id_app,
+							ci_module_id		  = No })
 	  (groups, new_fun_defs, imported_types, imported_conses, type_heaps, ci_var_heap)
 			= addNewFunctionsToGroups common_defs ci_fun_heap ci_new_functions main_dcl_module_n groups imported_types [] type_heaps ci_var_heap
 	= (groups, { fundef \\ fundef <- [ fundef \\ fundef <-: fun_defs ] ++ new_fun_defs }, ci_predef_symb, imported_types, imported_conses, ci_var_heap, type_heaps, ci_expr_heap, tcl_file)
@@ -395,7 +395,9 @@ where
 /* Sjaak ... */
 	convertDynamics cinp bound_vars default_expr  (DynamicExpr {dyn_expr, dyn_info_ptr, dyn_type_code}) ci=:{ci_symb_ident}
 		#  (dyn_expr,      ci) 			= convertDynamics cinp bound_vars default_expr dyn_expr ci
-		   (_,dyn_type_code, _, _, ci)	= convertTypecode2 cinp dyn_type_code False [] [] ci
+		   (_,dyn_type_code, _, _, ci)	= convertTypecode2 cinp dyn_type_code False [] [] {ci & ci_module_id = No}
+		# (dyn_type_code,ci)
+			= build_type_identification dyn_type_code ci
 		= (App {	app_symb		= ci_symb_ident,
 					app_args 		= [dyn_expr, dyn_type_code],
 					app_info_ptr	= nilPtr }, ci)
@@ -427,8 +429,21 @@ where
 	convertDynamics cinp bound_vars default_expr expression ci
 		= abort "unexpected value in convertDynamics: 'convertDynamics.Expression'"
 
-
-
+// identification of types generated by the compiler. If there is no TypeConsSymbol, then
+// no identification is necessary.
+build_type_identification dyn_type_code ci=:{ci_module_id=No}
+	= (dyn_type_code,ci)
+build_type_identification dyn_type_code ci=:{ci_module_id=Yes let_bind}
+	# (let_info_ptr,  ci)	= let_ptr 1 ci
+	# letje
+		= Let {	let_strict_binds	= [],
+				let_lazy_binds		= [let_bind],
+				let_expr			= dyn_type_code,
+				let_info_ptr		= let_info_ptr,
+				let_expr_position	= NoPos
+		}
+	= (letje,ci)
+	
 //convertTypecode ::  !ConversionInput TypeCodeExpression !*ConversionInfo  -> (Expression,!*ConversionInfo)
 /*
 	replace all references in a type code expression which refer to an argument i.e. the argument contains a
@@ -529,13 +544,36 @@ convertTypecode cinp (TCE_TypeTerm var_info_ptr) replace_tc_args binds placehold
 	*/
 	= convertTypecode cinp (TCE_Var var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
 
-convertTypecode cinp (TCE_Constructor index typecode_exprs) replace_tc_args binds placeholders_and_tc_args ci
-	# (typecons_symb,  ci) 									= getSymbol PD_TypeConsSymbol SK_Constructor 2 ci
+convertTypecode cinp (TCE_Constructor index typecode_exprs) replace_tc_args binds placeholders_and_tc_args ci=:{ci_internal_type_id}
+	# (typecons_symb,  ci) 									=  getSymbol PD_TypeConsSymbol SK_Constructor (USE_DummyModuleName 3 2) ci
 	  constructor											= get_constructor cinp.cinp_glob_type_inst index
 	  (typecode_exprs,binds,placeholders_and_tc_args,ci)	= convertTypecodes cinp typecode_exprs replace_tc_args binds placeholders_and_tc_args ci
+	# (ci_internal_type_id,ci)
+		= get_module_id ci
 	= (App {app_symb		= typecons_symb,
-			app_args 		= [constructor , typecode_exprs],
+			app_args 		= USE_DummyModuleName [constructor , ci_internal_type_id, typecode_exprs] [constructor , typecode_exprs] ,
 			app_info_ptr	= nilPtr},binds,placeholders_and_tc_args,ci)
+where
+	get_module_id ci=:{ci_module_id=Yes {lb_dst}}
+		= (Var (freeVarToVar lb_dst),ci)
+
+	get_module_id ci
+		# (dst=:{var_info_ptr},ci)
+			= newVariable "module_id" VI_Empty ci
+		# dst_fv
+			= varToFreeVar dst 1
+
+		# let_bind
+			= { lb_src = ci_internal_type_id
+			,	lb_dst = dst_fv
+			,	lb_position = NoPos
+			}
+		# ci
+			= { ci & 
+				ci_new_variables	= [ dst_fv : ci.ci_new_variables ]
+			,	ci_module_id		= Yes let_bind
+			}
+		= (Var dst,ci)
 
 convertTypecode cinp (TCE_Selector selections var_info_ptr) replace_tc_args binds placeholders_and_tc_args ci
 	#! (var,binds,placeholders_and_tc_args,ci)		
@@ -800,7 +838,9 @@ where
 		  /***  convert the elements of this pattern  ***/
 
 		  (a_ij_binds, ci)		= createVariables dp_type_patterns_vars [] ci
-	 	  (generate_coerce,type_code,_,martijn, ci)	= convertTypecode2 cinp dp_type_code True /* should be changed to True for type dependent functions */  /* WAS: a_ij_binds*/ [] [] ci
+	 	  (generate_coerce,type_code,_,martijn, ci)	= convertTypecode2 cinp dp_type_code True /* should be changed to True for type dependent functions */  /* WAS: a_ij_binds*/ [] [] {ci & ci_module_id = No} // ci
+		# (type_code,ci)
+			= build_type_identification type_code ci
 	
 		// collect ...
 	 	# (is_last_dynamic_pattern,dp_rhs) 
@@ -1122,7 +1162,7 @@ get_constructor glob_type_inst index
 
 instance toString GlobalTCType
 where
-	toString (GTT_Basic basic_type)							= toString basic_type
+	toString (GTT_Basic basic_type)							= toString basic_type +++ (APPEND_DEFINING_TYPE_MODULE_NAMES_TO_TYPE_NAMES ("'" +++ PredefinedModuleName ) "")
 	toString GTT_Function									= " -> "
 	toString (GTT_Constructor type_symb_indent mod_name)	= type_symb_indent.type_name.id_name +++ (APPEND_DEFINING_TYPE_MODULE_NAMES_TO_TYPE_NAMES ("'" +++ mod_name) "")
 
@@ -1228,5 +1268,20 @@ instance <<< (Ptr a)
 where
 	(<<<) file ptr = file <<< ptrToInt ptr  
 
+get_module_id_app :: !*PredefinedSymbols -> (App,Expression,!*PredefinedSymbols)
+get_module_id_app predef_symbols
+	// get module id symbol
+	# ({pds_module, pds_def, pds_ident}, predef_symbols)	= predef_symbols![PD_ModuleConsSymbol]
+	# module_symb = 
+		{	app_symb 		= { symb_name = pds_ident, symb_kind = SK_Constructor { glob_module = pds_module, glob_object = pds_def}, symb_arity = 0 }
+		,	app_args 		= []
+		,	app_info_ptr	= nilPtr
+		}
 
-
+	# ({pds_module, pds_def, pds_ident}, predef_symbols)	= predef_symbols![PD_ModuleID]
+	# module_id_symb = 
+		{	app_symb 		= { symb_name = pds_ident, symb_kind = SK_Constructor { glob_module = pds_module, glob_object = pds_def}, symb_arity = 1 }
+		,	app_args 		= [App module_symb]
+		,	app_info_ptr	= nilPtr
+		}
+	= (module_symb,App module_id_symb,predef_symbols)
\ No newline at end of file