Added: field to CModule to indicate number of data-constructors in a...

Added: field to CModule to indicate number of data-constructors in a DCL-module, not counting dictionary-creators.
Updated: support for recognizing dictionay creators by means of temporary translation to classes.

Sparkle/Tools/Core/ChangeDefinition.icl

@@ -167,15 +167,20 @@ bindDefinition mb_conversions all_names all_ptrs (DclDefinitionPtr dcl_name def_
 										MemberDef			-> cMemberDefs
 										ClassInstance		-> cInstanceDefs
 	# conv_table					= conv_tables.[conv_index]
-	| def_index >= size conv_table
-		// Check for record-constructors belonging to dictionaries; temporarily replace these by class pointers
-		| def_kind == ConsDef
-			# nr_conses				= size conv_table
-			= bindDefinition (Just conversions) all_names all_ptrs (DclDefinitionPtr dcl_name def_name ClassDef (def_index-nr_conses)) heaps
+	| (def_kind <> ConsDef) && (def_index >= size conv_table)
 		# dicts						= conversions.ccDictionaries
 		# icl_ptr					= check_dictionary def_name def_kind dicts (IclDefinitionPtr dcl_name (-2) def_name def_kind def_index)
 		= bindDefinition (Just conversions) all_names all_ptrs icl_ptr heaps
-	# def_index						= conv_table.[def_index]
+	# (nr_conses, heaps)			= find_nr_conses dcl_name all_names all_ptrs heaps
+	| (def_kind == ConsDef) && (def_index >= nr_conses)
+		// Constructor is a dictionary creator, which cannot be converted at this time.
+		// Therefore, it is replaced by the class that the dictionary belongs to and is later converted back.
+		# def_name					= remove_last_semicolon def_name
+		# class_ptr					= (DclDefinitionPtr dcl_name def_name ClassDef (def_index-nr_conses))
+		= bindDefinition (Just conversions) all_names all_ptrs class_ptr heaps
+	# def_index						= case def_index >= size conv_table of
+										True	-> def_index
+										False	-> conv_table.[def_index]
 	= bindDefinition (Just conversions) all_names all_ptrs (IclDefinitionPtr dcl_name (-2) def_name def_kind def_index) heaps
 	where
 		check_dictionary :: !String !CompilerDefinitionKind ![(CName, IndexedPtr)] !IndexedPtr -> !IndexedPtr
@@ -185,6 +190,25 @@ bindDefinition mb_conversions all_names all_ptrs (DclDefinitionPtr dcl_name def_
 			= newptr
 		check_dictionary defname other dicts oldptr
 			= oldptr
+		
+		// When temporary converting dictionary_creators (conses) to classes, its index has to be adjusted by the number of real conses in the dcl.
+		// This number is stored in the module (and set by the function 'convertFrontEndSyntaxTree' in 'Conversion.icl'.
+		find_nr_conses :: !String ![ModuleName] ![ModulePtr] !*CHeaps -> (!Int, !*CHeaps)
+		find_nr_conses dcl_name [name:names] [ptr:ptrs] heaps
+			| dcl_name <> name			= find_nr_conses dcl_name names ptrs heaps
+			# (mod, heaps)				= readPointer ptr heaps
+			= (mod.pmOriginalNrDclConses, heaps)
+		find_nr_conses _ _ _ heaps
+			= (0, heaps)
+		
+		// When temporary converting record-constructors to class pointers, the last ; has to be removed to get the proper class name.
+		remove_last_semicolon :: !String -> String
+		remove_last_semicolon name
+			# size_name					= size name
+			| size_name == 0			= name
+			# last_char					= name.[size_name - 1]
+			| last_char <> ';'			= name
+			= name % (0, size name - 2)
 bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr icl_name icl_key _ CheckedTypeDef def_index) heaps
 	# (ok, conversions, heaps)			= findConversions mb_conversions icl_name all_names all_ptrs heaps
 	| not ok							= (pushError (X_Internal ("Rule 'bindDefinition' does not match. (unknown iclmodule " +++ icl_name +++ ")")) OK, DummyValue, heaps)
@@ -196,6 +220,9 @@ bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr icl_name icl_
 bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr icl_name icl_key _ ClassDef def_index) heaps
 	# (ok, conversions, heaps)			= findConversions mb_conversions icl_name all_names all_ptrs heaps
 	| not ok							= (pushError (X_Internal ("Rule 'bindDefinition' does not match. (unknown iclmodule " +++ icl_name +++ ")")) OK, DummyValue, heaps)
+	
+	| def_index >= size conversions.ccClassPtrs		= abort "HALLO! NIET DOEN!"
+	
 	= (OK, conversions.ccClassPtrs.[def_index], heaps)
 bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr "_tupleselect" icl_key _ FunDef def_index) heaps
 	= (OK, CTupleSelectPtr icl_key def_index, heaps)
@@ -216,6 +243,32 @@ bindDefinition mb_conversions all_names all_ptrs (IclDefinitionPtr icl_name icl_
 	| not ok							= (pushError (X_Internal ("Rule 'bindDefinition' does not match. (unknown iclmodule " +++ icl_name +++ ")")) OK, DummyValue, heaps)
 	= (OK, conversions.ccSelectorPtrs.[def_index], heaps)
 
+// -------------------------------------------------------------------------------------------------------------------------------------------------   
+bindDefinition2 :: !(Maybe CompilerConversion) ![ModuleName] ![ModulePtr] !IndexedPtr !*CHeaps -> (!Error, !HeapPtr, !*CHeaps)
+// -------------------------------------------------------------------------------------------------------------------------------------------------   
+bindDefinition2 mb_conversions all_names all_ptrs ptr1 heaps
+	# (error, ptr2, heaps)				= bindDefinition mb_conversions all_names all_ptrs ptr1 heaps
+	| isError error						= (error, ptr2, heaps)
+	# kind_1							= get_kind ptr1
+	# kind_2							= ptrKind ptr2
+	= check kind_1 kind_2 error ptr1 ptr2 heaps
+	where
+		get_kind :: !IndexedPtr -> CompilerDefinitionKind
+		get_kind (IclDefinitionPtr _ _ _ kind _)
+			= kind
+		get_kind (DclDefinitionPtr _ _ kind _)
+			= kind
+		
+		check :: !CompilerDefinitionKind !DefinitionKind !Error !IndexedPtr !HeapPtr !*CHeaps -> (!Error, !HeapPtr, !*CHeaps)
+		check CheckedTypeDef CRecordType error ptr1 ptr2 heaps
+			= (error, ptr2, heaps)
+		check kind1 CRecordType error ptr1 ptr2 heaps
+//			#! heaps					= heaps --->> ptr1
+			= (error, ptr2, heaps)
+		check _ _ error ptr1 ptr2 heaps
+			= (error, ptr2, heaps)
+	
+
 
 
 
@@ -620,7 +673,7 @@ bindModule all_names all_ptrs mod_ptr heaps prj
 		
 		bindFuns :: ![HeapPtr] ![CFunDefI] !*CHeaps !*CProject -> (!Error, !*CHeaps, !*CProject)
 		bindFuns [ptr:ptrs] [def:defs] heaps prj
-			# (error, def, heaps)		= changeDefinition (bindDefinition Nothing all_names all_ptrs) def heaps
+			# (error, def, heaps)		= changeDefinition (bindDefinition2 Nothing all_names all_ptrs) def heaps
 			| isError error				= (error, heaps, prj)
 			# (error, prj)				= putFunDef ptr def prj
 			| isError error				= (error, heaps, prj)

Sparkle/Tools/Core/Conversion.icl

@@ -544,6 +544,7 @@ convertFrontEndSyntaxTree tree heaps mod_key mod_path cheaps prj
 	# (mod_ptr, cheaps)										= newPointer DummyValue cheaps
 	# (cenv, mod_name, dcl_modules, tree, heaps)			= makeConvertEnv mod_key mod_ptr tree cheaps heaps
 	# icl_module											= tree.fe_icl
+	# maybe_dcl_module										= find_own_dcl_module 0 (size tree.fe_dcls) mod_name tree.fe_dcls
 
 	# checked_type_defs										= [def \\ def <-: icl_module.icl_common.com_type_defs]
 	# (error, type_ptrs, alg_defs, rec_defs, cenv, prj)		= convertTypeDefs checked_type_defs cenv prj
@@ -614,6 +615,7 @@ convertFrontEndSyntaxTree tree heaps mod_key mod_path cheaps prj
 																							, ccConversionTable		= conversion_table
 																							, ccDclIclConversions	= {} //fromOptional tree.fe_dclIclConversions
 																							}
+																, pmOriginalNrDclConses	= find_original_nr_dcl_conses maybe_dcl_module
 																}
 	# cheaps												= writePointer mod_ptr mod cenv.cenvHeaps
 	= (OK, mod_ptr, heaps, cheaps, prj)
@@ -622,6 +624,19 @@ convertFrontEndSyntaxTree tree heaps mod_key mod_path cheaps prj
 		fromOptional (Yes a)	= a
 		fromOptional No			= {}
 		
+		find_own_dcl_module :: !Int !Int !String !{#DclModule} -> Maybe DclModule
+		find_own_dcl_module index nr_dcls module_name dcls
+			| index >= nr_dcls							= Nothing
+			# dcl										= dcls.[index]
+			| dcl.dcl_name.id_name == module_name		= Just dcl
+			= find_own_dcl_module (index+1) nr_dcls module_name dcls
+		
+		find_original_nr_dcl_conses :: !(Maybe DclModule) -> Int
+		find_original_nr_dcl_conses Nothing
+			= 0
+		find_original_nr_dcl_conses (Just dcl)
+			= (size dcl.dcl_common.com_cons_defs) - (size dcl.dcl_common.com_class_defs)
+		
 		get_conversion_table :: !ModuleName !{#DclModule} -> ConversionTable
 		get_conversion_table modname dcls
 			# si									= size dcls

Sparkle/Tools/Core/CoreTypes.dcl

@@ -426,6 +426,7 @@ instance DummyValue (CMemberDef def_ptr) | DummyValue def_ptr
 	, pmRecordFieldPtrs		:: ![HeapPtr]
 	, pmCompilerStore		:: !Maybe CompilerStore
 	, pmCompilerConversion	:: !CompilerConversion
+	, pmOriginalNrDclConses	:: !Int						// needed for conversion of dictionary creation conses (which are translated via classes)
 	}
 instance DummyValue CModule
 

Sparkle/Tools/Core/CoreTypes.icl

@@ -507,12 +507,14 @@ instance DummyValue (CMemberDef def_ptr) | DummyValue def_ptr
 	, pmRecordFieldPtrs		:: ![HeapPtr]
 	, pmCompilerStore		:: !Maybe CompilerStore
 	, pmCompilerConversion	:: !CompilerConversion
+	, pmOriginalNrDclConses	:: !Int						// needed for conversion of dictionary creation conses (which are translated via classes)
 	}
 instance DummyValue CModule
 	where DummyValue = {pmName = "", pmPath = "", pmImportedModules = [], pmAlgTypePtrs = [], 
 						pmClassPtrs = [], pmDataConsPtrs = [], pmFunPtrs = [],
 						pmInstancePtrs = [], pmMemberPtrs = [], pmRecordTypePtrs = [],
-						pmRecordFieldPtrs = [], pmCompilerStore = Nothing, pmCompilerConversion = DummyValue}
+						pmRecordFieldPtrs = [], pmCompilerStore = Nothing, pmCompilerConversion = DummyValue,
+						pmOriginalNrDclConses = 0}
 
 // -------------------------------------------------------------------------------------------------------------------------------------------------
 :: CPredefined =

Sparkle/Tools/Core/FormattedShow.icl

@@ -1108,6 +1108,7 @@ where
 					# name							= if (isInfix inf) ("(" +++ name +++ ")") name
 //					| isJust fundef.fdDeltaRule		= (OK, fundef.fdName +++ "", fundef.fdInfix, prj)
 					= (OK, name, inf, prj)
+				#! prj								= prj --->> kind
 				= (pushError (X_Internal ("encountered something other than a function or data-constructor at an application")) OK, DummyValue, DummyValue, prj)
 	FormattedShow finfo (CLet strict bindings expr) heaps prj
 		# (finfo, heaps)					= storeExprVars (map fst bindings) finfo heaps

Sparkle/Tools/Core/Predefined.icl

@@ -279,6 +279,7 @@ CPredefined
 		, pmRecordTypePtrs		= [CTCDictPtr]
 		, pmCompilerStore		= Nothing
 		, pmCompilerConversion	= DummyValue
+		, pmOriginalNrDclConses	= DummyValue
 		}
 
 // -------------------------------------------------------------------------------------------------------------------------------------------------