minor changes to files associated with dynamics. Most notably is the

use of the TypeVarHeap.

frontend/convertDynamics.icl

@@ -52,33 +52,53 @@ F a b = b
 
 
 //write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] -> (.Bool,.File)
-write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] -> (.Bool,.File)
-write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} common_defs tcl_file directly_imported_dcl_modules
-	#! tcl_file
-		= write_type_info common_defs tcl_file
-	#! tcl_file
-		= write_type_info directly_imported_dcl_modules tcl_file
+write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] !*TypeHeaps -> (.Bool,.File,!*TypeHeaps)
+write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} common_defs tcl_file directly_imported_dcl_modules type_heaps
+	# write_type_info_state2
+		= { WriteTypeInfoState |
+			wtis_type_heaps		= type_heaps
+		,	wtis_n_type_vars		= 0
+		};
+	# (j,tcl_file)
+		= fposition tcl_file
+//	| True
+//		= abort ("TypeVar " +++ toString j)
+				
+	#! (tcl_file,write_type_info_state)
+		= write_type_info common_defs tcl_file write_type_info_state2
+	#! (tcl_file,write_type_info_state)
+		= write_type_info directly_imported_dcl_modules tcl_file write_type_info_state
+		
+	#! (type_heaps,_)
+		= f write_type_info_state //!type_heaps;
+		
+		
 	#! tcl_file
 		= fwritei (size main_dcl_module.dcl_common.com_type_defs) tcl_file
 	#! tcl_file
 		= fwritei (size main_dcl_module.dcl_common.com_cons_defs) tcl_file
-	= (True,tcl_file) 
+	= (True,tcl_file,type_heaps) 
+	
+where
+	f write_type_info_state=:{wtis_type_heaps}
+		= (wtis_type_heaps,{write_type_info_state & wtis_type_heaps = abort "convertDynamics.icl"});
 //---> ("dcl",size main_dcl_module.dcl_common.com_type_defs, "icl", size common_defs.com_type_defs);
+
 			
 convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap /* TD */ (Optional !*File) {# DclModule} !IclModule /* TD */ [String]
 			-> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, /* TD */ (Optional !*File))
 convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap /* TD */ tcl_file dcl_mods icl_mod  /* TD */ directly_imported_dcl_modules
 	// TD ...
-	# tcl_file
+	# (tcl_file,type_heaps)
 		= case tcl_file of
 			No
-				-> No
+				-> (No,type_heaps)
 			(Yes tcl_file)
-				# (ok,tcl_file)
-					= write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file /* TD */ directly_imported_dcl_modules
+				# (ok,tcl_file,type_heaps)
+					= write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file /* TD */ directly_imported_dcl_modules type_heaps
 				| not ok
 					-> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
-					-> Yes tcl_file
+					-> (Yes tcl_file,type_heaps)
 
 				
 	// ... TD

frontend/type_io.dcl

@@ -8,9 +8,15 @@ import scanner, general, Heap, typeproperties, utilities, checksupport
 
 import StdEnv
 
+:: WriteTypeInfoState
+	= { 
+		wtis_type_heaps			:: !.TypeHeaps
+	,	wtis_n_type_vars		:: !Int
+	};
+
 class WriteTypeInfo a 
 where
-	write_type_info :: a !*File -> !*File
+	write_type_info :: a !*File !*WriteTypeInfoState -> (!*File,!*WriteTypeInfoState)
 	
 instance WriteTypeInfo CommonDefs, Char, [a] | WriteTypeInfo a
 

frontend/type_io.icl

@@ -22,108 +22,99 @@ import type_io_common
 //import DebugUtilities;
 F a b :== b;
 
-/*
-class NormaliseTypeDef a 
-where
-	normalise_type_def :: a -> a
-*/	
-//import RWSDebug
-
-/*
-instance NormaliseTypeDef TypeRhs
-where
-	normalise_type_def (AlgType defined_symbols)
-		// algebraic data types are further normalized by an alphabetical sort on the
-		// constructor names.
-		= AlgType (sortBy (\{ds_ident={id_name=id_name1}} {ds_ident={id_name=id_name2}} -> id_name1 < id_name2) defined_symbols)
-	normalise_type_def i
-		= i
-
-//1.3		
-instance NormaliseTypeDef TypeDef rhs | NormaliseTypeDef rhs
-//3.1
-/*2.0
-instance NormaliseTypeDef (TypeDef rhs) | NormaliseTypeDef rhs
-0.2*/
-where
-	normalise_type_def type_def=:{td_args,td_arity}
-		= type_def
-*/				
+:: WriteTypeInfoState
+	= { 
+		wtis_type_heaps			:: !.TypeHeaps
+	,	wtis_n_type_vars		:: !Int
+	};
 	
 class WriteTypeInfo a 
 where
-	write_type_info :: a !*File -> !*File
+	write_type_info :: a !*File !*WriteTypeInfoState -> (!*File,!*WriteTypeInfoState)
 	
 instance WriteTypeInfo CommonDefs
 where 
-	write_type_info {com_type_defs,com_cons_defs,com_selector_defs} tcl_file
-		# tcl_file
-			= write_type_info com_type_defs tcl_file
-		# tcl_file
- 			= write_type_info com_cons_defs tcl_file
- 		# tcl_file
- 			= write_type_info com_selector_defs tcl_file
-		= tcl_file
+	write_type_info {com_type_defs,com_cons_defs,com_selector_defs} tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info com_type_defs tcl_file wtis
+		# (tcl_file,wtis)
+ 			= write_type_info com_cons_defs tcl_file wtis
+ 		# (tcl_file,wtis)
+ 			= write_type_info com_selector_defs tcl_file wtis
+		= (tcl_file,wtis)
 		
 instance WriteTypeInfo SelectorDef
 where
-	write_type_info {sd_type} tcl_file
-		# tcl_file
-			= write_type_info sd_type tcl_file
-		= tcl_file
+	write_type_info {sd_type} tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info sd_type tcl_file wtis
+		= (tcl_file,wtis)
 	
 instance WriteTypeInfo ConsDef
 where 
-	write_type_info {cons_symb,cons_type,cons_arg_vars,cons_priority,cons_index,cons_type_index,cons_exi_vars} tcl_file
-		# tcl_file
-			= write_type_info cons_symb tcl_file
-		# tcl_file
-			= write_type_info cons_type tcl_file
-		# tcl_file
-			= write_type_info cons_arg_vars tcl_file
-		# tcl_file
-			= write_type_info cons_priority tcl_file
+	write_type_info {cons_symb,cons_type,cons_arg_vars,cons_priority,cons_index,cons_type_index,cons_exi_vars} tcl_file wtis=:{wtis_n_type_vars}
+ 		// normalize ...
+ 		# (th_vars,wtis)
+ 			= sel_type_var_heap wtis
+ 		# (_,(_,th_vars))
+ 			= mapSt normalize_type_var cons_exi_vars (wtis_n_type_vars,th_vars)
+  		# wtis
+ 			= { wtis &
+ 				wtis_type_heaps		=  { wtis.wtis_type_heaps & th_vars = th_vars }
+ 			}
+ 		// ... normalize
 
-		# tcl_file
-			= write_type_info cons_index tcl_file
-		# tcl_file
-			= write_type_info cons_type_index tcl_file
-		# tcl_file
-			= write_type_info cons_exi_vars tcl_file
+		# (tcl_file,wtis)
+			= write_type_info cons_symb tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info cons_type tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info cons_arg_vars tcl_file wtis
+//		# (tcl_file,wtis)
+//			= write_type_info cons_priority tcl_file wtis
+
+		# (tcl_file,wtis)
+			= write_type_info cons_index tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info cons_type_index tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info cons_exi_vars tcl_file wtis
 	
-		= tcl_file
+		= (tcl_file,wtis)
 		
+/*
 instance WriteTypeInfo Priority
 where 
-	write_type_info (Prio assoc i) tcl_file
+	write_type_info (Prio assoc i) tcl_file wtis
 		# tcl_file
 			= fwritec PrioCode tcl_file
-		# tcl_file
-			= write_type_info assoc tcl_file
-		# tcl_file
-			= write_type_info i tcl_file
-		= tcl_file
-	write_type_info NoPrio tcl_file
-		# tcl_file
-			= fwritec NoPrioCode tcl_file
-		= tcl_file
+		# (tcl_file,wtis)
+			= write_type_info assoc tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info i tcl_file wtis
+		= (tcl_file,wtis)
+	write_type_info NoPrio tcl_file wtis
+		# tcl_file
+			= fwritec NoPrioCode tcl_file 
+		= (tcl_file,wtis)
 		
 instance WriteTypeInfo Assoc
 where 
-	write_type_info LeftAssoc tcl_file
+	write_type_info LeftAssoc tcl_file wtis
 		# tcl_file
-			= fwritec LeftAssocCode tcl_file
-		= tcl_file
+			= fwritec LeftAssocCode tcl_file 
+		= (tcl_file,wtis)
 
-	write_type_info RightAssoc tcl_file
+	write_type_info RightAssoc tcl_file wtis
 		# tcl_file
 			= fwritec RightAssocCode tcl_file
-		= tcl_file	
+		= (tcl_file,wtis)	
 
-	write_type_info NoAssoc tcl_file
+	write_type_info NoAssoc tcl_file wtis
 		# tcl_file
-			= fwritec NoAssocCode tcl_file
-		= tcl_file	
+			= fwritec NoAssocCode tcl_file 
+		= (tcl_file,wtis)	
+*/
 		
 //1.3
 instance WriteTypeInfo TypeDef TypeRhs
@@ -132,232 +123,273 @@ instance WriteTypeInfo TypeDef TypeRhs
 instance WriteTypeInfo (TypeDef TypeRhs)
 0.2*/
 where 
-	write_type_info {td_name,td_arity,td_args,td_rhs} tcl_file
- 		#! tcl_file
- 			= write_type_info td_name tcl_file
-		#! tcl_file
- 			= write_type_info td_arity tcl_file
- 		#! tcl_file
- 			= write_type_info td_args tcl_file
-		#! tcl_file
- 			= write_type_info td_rhs tcl_file
- 		= tcl_file
+	write_type_info {td_name,td_arity,td_args,td_rhs} tcl_file wtis
+		// normalize ...
+ 		# (th_vars,wtis)
+ 			= sel_type_var_heap wtis
+ 		# (_,(n_type_vars,th_vars))
+ 			= mapSt normalize_type_var td_args (0,th_vars)
+  		# wtis
+ 			= { wtis &
+ 				wtis_type_heaps		=  { wtis.wtis_type_heaps & th_vars = th_vars }
+ 			,	wtis_n_type_vars		= n_type_vars
+ 			}
+ 		// ... normalize
  		
+ 		# (tcl_file,wtis)
+ 			= write_type_info td_name tcl_file wtis
+		# (tcl_file,wtis)
+ 			= write_type_info td_arity tcl_file wtis 				
+ 		# (tcl_file,wtis)
+ 			= write_type_info td_args tcl_file wtis
+		# (tcl_file,wtis)
+ 			= write_type_info td_rhs tcl_file wtis
+ 			
+ 		= (tcl_file,wtis)
+ 	
+normalize_type_var :: !ATypeVar (!Int,!*TypeVarHeap) -> (!Int,(!Int,!*TypeVarHeap))
+normalize_type_var td_arg=:{atv_variable={tv_info_ptr}} (id,th_vars)
+	# th_vars
+		= writePtr tv_info_ptr (TVI_Normalized id) th_vars
+	= (id,(inc id,th_vars));
+		
+sel_type_var_heap :: !*WriteTypeInfoState -> (!*TypeVarHeap,!*WriteTypeInfoState)
+sel_type_var_heap wtis=:{wtis_type_heaps}
+	# (th_vars,wtis_type_heaps)
+		= sel wtis_type_heaps
+	= (th_vars,{ wtis & wtis_type_heaps = wtis_type_heaps} )
+	
+	where
+		sel wtis_type_heaps=:{th_vars}
+			= (th_vars,{ wtis_type_heaps & th_vars = newHeap } )
+ 
 instance WriteTypeInfo ATypeVar
 where 
-	write_type_info {atv_annotation,atv_variable} tcl_file
- 		#! tcl_file
- 			= write_type_info atv_annotation tcl_file
- 		#! tcl_file
- 			= write_type_info atv_variable tcl_file
- 		= tcl_file
+	write_type_info {atv_annotation,atv_variable} tcl_file wtis
+ 		# (tcl_file,wtis) 
+ 			= write_type_info atv_annotation tcl_file wtis
+ 		# (tcl_file,wtis)
+ 			= write_type_info atv_variable tcl_file wtis
+ 		= (tcl_file,wtis)
  		
 instance WriteTypeInfo Annotation
 where 
-	write_type_info AN_Strict tcl_file	
-		= fwritec '!' tcl_file
-	write_type_info AN_None tcl_file
-		= fwritec ' ' tcl_file
+	write_type_info AN_Strict tcl_file wtis	
+		= (fwritec '!' tcl_file,wtis)
+	write_type_info AN_None tcl_file wtis
+		= (fwritec ' ' tcl_file,wtis)
 		
 instance WriteTypeInfo TypeVar
 where
-	write_type_info {tv_name} tcl_file
-		// writing tv_name as number suffices
-		= write_type_info tv_name tcl_file
-		
+	write_type_info {tv_info_ptr} tcl_file wtis
+		# (th_vars,wtis)
+			= sel_type_var_heap wtis
+		# ( v,th_vars)
+			= readPtr tv_info_ptr th_vars
+		# tcl_file
+			= fwritei (get_type_var_nf_number v) tcl_file
+
+  		# wtis 
+ 			= { wtis &
+ 				wtis_type_heaps		=  { wtis.wtis_type_heaps & th_vars = th_vars }
+ 			}
+ 		= (tcl_file,wtis)	
+ 	where 
+ 		get_type_var_nf_number (TVI_Normalized i)	= i
+
 instance WriteTypeInfo TypeRhs
 where 
-	write_type_info (AlgType defined_symbols) tcl_file
- 		#! tcl_file
- 			= fwritec AlgTypeCode tcl_file;
+	write_type_info (AlgType defined_symbols) tcl_file wtis
+ 		# tcl_file
+ 			= fwritec AlgTypeCode tcl_file
 		
 		# defined_symbols
 			= (sortBy (\{ds_ident={id_name=id_name1}} {ds_ident={id_name=id_name2}} -> id_name1 < id_name2) defined_symbols)
-		# tcl_file
-			= write_type_info defined_symbols tcl_file
+		# (tcl_file,wtis)
+			= write_type_info defined_symbols tcl_file wtis
 
-		= tcl_file
+		= (tcl_file,wtis)
 		
-	write_type_info (SynType _) tcl_file
-		#! tcl_file
+	write_type_info (SynType _) tcl_file wtis
+		# tcl_file
  			= fwritec SynTypeCode tcl_file;
  			
  		// unimplemented
- 		= tcl_file 
+ 		= (tcl_file,wtis) 
 		
-	write_type_info (RecordType {rt_fields}) tcl_file
+	write_type_info (RecordType {rt_fields}) tcl_file wtis
  		#! tcl_file
  			= fwritec RecordTypeCode tcl_file;
-		= write_type_info rt_fields tcl_file
+		= write_type_info rt_fields tcl_file wtis
 
-	write_type_info (AbstractType _) tcl_file
+	write_type_info (AbstractType _) tcl_file wtis
  		#! tcl_file
  			= fwritec AbstractTypeCode tcl_file;
  			
  		// unimplemented
-		= tcl_file
+		= (tcl_file,wtis)
 		
 instance WriteTypeInfo DefinedSymbol 
 where
-	write_type_info {ds_ident,ds_arity,ds_index} tcl_file
-		# tcl_file
-			= write_type_info ds_ident tcl_file
-		# tcl_file
-			= write_type_info ds_arity tcl_file
-		# tcl_file
-			= write_type_info ds_index tcl_file
-		= tcl_file
+	write_type_info {ds_ident,ds_arity,ds_index} tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info ds_ident tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info ds_arity tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info ds_index tcl_file wtis
+		= (tcl_file,wtis)
 
 instance WriteTypeInfo Ident 
 where
-	write_type_info {id_name} tcl_file
+	write_type_info {id_name} tcl_file wtis
 		# tcl_file
 			= fwritei (size id_name) tcl_file
-		= fwrites id_name tcl_file
+		= (fwrites id_name tcl_file,wtis)
 		
 instance WriteTypeInfo FieldSymbol
 where
-	write_type_info {fs_name,fs_var,fs_index} tcl_file
-		# tcl_file
-			= write_type_info fs_name tcl_file
-		# tcl_file
-			= write_type_info fs_var tcl_file
-		# tcl_file
-			= write_type_info fs_index tcl_file
-		= tcl_file
+	write_type_info {fs_name,fs_var,fs_index} tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info fs_name tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info fs_var tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info fs_index tcl_file wtis
+		= (tcl_file,wtis)
 		
 // NEW ->
 instance WriteTypeInfo SymbolType
 where
-	write_type_info {st_vars,st_args,st_arity,st_result} tcl_file
-		# tcl_file
-			= write_type_info st_vars tcl_file
-		# tcl_file
-			= write_type_info st_args tcl_file
-		# tcl_file
-			= write_type_info st_arity tcl_file
-		# tcl_file
-			= write_type_info st_result tcl_file
-		= tcl_file
+	write_type_info {st_vars,st_args,st_arity,st_result} tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info st_vars tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info st_args tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info st_arity tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info st_result tcl_file wtis
+		= (tcl_file,wtis)
 		
 instance WriteTypeInfo AType
 where
-	write_type_info {at_annotation,at_type} tcl_file
-		# tcl_file
-			= write_type_info at_annotation tcl_file
-		# tcl_file
-			= write_type_info at_type tcl_file
-		= tcl_file
+	write_type_info {at_annotation,at_type} tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info at_annotation tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info at_type tcl_file wtis
+		= (tcl_file,wtis)
 		
 instance WriteTypeInfo Type
 where
-	write_type_info (TA type_symb_ident atypes) tcl_file
+	write_type_info (TA type_symb_ident atypes) tcl_file wtis
 		# tcl_file
 			= fwritec TypeTACode tcl_file
-		# tcl_file
-			= write_type_info type_symb_ident tcl_file
-		# tcl_file
-			= write_type_info atypes tcl_file
-		= tcl_file
+		# (tcl_file,wtis)
+			= write_type_info type_symb_ident tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info atypes tcl_file wtis
+		= (tcl_file,wtis)
 
-	write_type_info (atype1 --> atype2) tcl_file
+	write_type_info (atype1 --> atype2) tcl_file wtis
 		# tcl_file
 			= fwritec TypeArrowCode tcl_file
-		# tcl_file
-			= write_type_info atype1 tcl_file
-		# tcl_file
-			= write_type_info atype2 tcl_file
-		= tcl_file
+		# (tcl_file,wtis)
+			= write_type_info atype1 tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info atype2 tcl_file wtis
+		= (tcl_file,wtis)
 		
-	write_type_info (cons_variable :@: atypes) tcl_file
+	write_type_info (cons_variable :@: atypes) tcl_file wtis
 		# tcl_file
 			= fwritec TypeConsApplyCode tcl_file
-		# tcl_file
-			= write_type_info cons_variable tcl_file
-		# tcl_file
-			= write_type_info atypes tcl_file
-		= tcl_file
+		# (tcl_file,wtis)
+			= write_type_info cons_variable tcl_file wtis
+		# (tcl_file,wtis)
+			= write_type_info atypes tcl_file wtis
+		= (tcl_file,wtis)
 		
-	write_type_info tb=:(TB basic_type) tcl_file
-		# tcl_file
+	write_type_info tb=:(TB basic_type) tcl_file wtis
+		# (tcl_file,wtis)
 			= case basic_type of
-				BT_Int		-> fwritec BT_IntCode tcl_file
-				BT_Char		-> fwritec BT_CharCode tcl_file
-				BT_Real		-> fwritec BT_RealCode tcl_file
-				BT_Bool		-> fwritec BT_BoolCode tcl_file
-				BT_Dynamic	-> fwritec BT_DynamicCode tcl_file
-				BT_File		-> fwritec BT_FileCode tcl_file
-				BT_World	-> fwritec BT_WorldCode tcl_file
+				BT_Int		-> (fwritec BT_IntCode tcl_file,wtis)
+				BT_Char		-> (fwritec BT_CharCode tcl_file,wtis)
+				BT_Real		-> (fwritec BT_RealCode tcl_file,wtis)
+				BT_Bool		-> (fwritec BT_BoolCode tcl_file,wtis)
+				BT_Dynamic	-> (fwritec BT_DynamicCode tcl_file,wtis)
+				BT_File		-> (fwritec BT_FileCode tcl_file,wtis)
+				BT_World	-> (fwritec BT_WorldCode tcl_file,wtis)
 				BT_String type
 					# tcl_file
 						= fwritec BT_StringCode tcl_file
-					# tcl_file
-						= write_type_info type tcl_file
-					-> tcl_file
-		= tcl_file
+					# (tcl_file,wtis)
+						= write_type_info type tcl_file wtis
+					-> (tcl_file,wtis)
+		= (tcl_file,wtis)
 	
-	write_type_info (GTV type_var) tcl_file
+	write_type_info (GTV type_var) tcl_file wtis
 		# tcl_file
 			= fwritec TypeGTVCode tcl_file
-		# tcl_file
-			= write_type_info type_var tcl_file
-		= tcl_file
+		# (tcl_file,wtis)
+			= write_type_info type_var tcl_file wtis
+		= (tcl_file,wtis)
 
-	write_type_info (TV type_var) tcl_file
+	write_type_info (TV type_var) tcl_file wtis
 		# tcl_file
 			= fwritec TypeTVCode tcl_file
-		# tcl_file
-			= write_type_info type_var tcl_file
-		= tcl_file
+		# (tcl_file,wtis)
+			= write_type_info type_var tcl_file wtis
+		= (tcl_file,wtis)