new implementation of generics

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

1 files changed, 76 insertions, 0 deletions

diff --git a/frontend/genericsupport.icl b/frontend/genericsupport.icl
new file mode 100644
index 0000000..b9033e2
--- /dev/null
+++ b/frontend/genericsupport.icl
@@ -0,0 +1,76 @@
+implementation module genericsupport
+
+import syntax, checksupport
+
+getGenericMember :: 
+	!(Global Index) 	// generic
+	!TypeKind 			// kind argument
+	!{#CommonDefs} 		// modules
+	!*GenericHeap
+	-> 		
+	( Optional (Global Index)
+	, !*GenericHeap					
+	)
+getGenericMember {glob_module, glob_object} kind modules generic_heap
+	#! (gen_def=:{gen_info_ptr}) = modules.[glob_module].com_generic_defs.[glob_object]
+	#! ({gen_classes}, generic_heap) = readPtr gen_info_ptr generic_heap
+	= case lookupGenericClassInfo kind gen_classes of
+		No -> (No, generic_heap) 
+		Yes {gci_module, gci_member}
+			#! member_glob = {glob_module = gci_module, glob_object = gci_member}
+			-> (Yes member_glob, generic_heap)
+				 
+lookupGenericClassInfo :: !TypeKind !GenericClassInfos	-> !(Optional GenericClassInfo)
+lookupGenericClassInfo kind class_infos
+	#! hash_index = case kind of
+		KindConst -> 0
+		KindArrow kinds -> length kinds
+	= lookup kind class_infos.[hash_index] 		
+where
+	lookup kind [] = No
+	lookup kind [gci:gcis]
+		| gci.gci_kind == kind 	= Yes gci
+								= lookup kind gcis
+
+addGenericClassInfo :: !GenericClassInfo !GenericClassInfos -> !GenericClassInfos
+addGenericClassInfo class_info=:{gci_kind} class_infos
+	#! hash_index = case gci_kind of
+		KindConst -> 0
+		KindArrow kinds -> length kinds
+	#! (class_infos1, class_infos) = class_infos ! [hash_index]
+	#! class_infos1 = [class_info:class_infos1]	
+	= {{x\\x<-:class_infos} & [hash_index] = class_infos1 }
+
+//****************************************************************************************
+//	Ident Helpers
+//****************************************************************************************
+makeIdent :: !String -> !Ident
+makeIdent str = {id_name = str, id_info = nilPtr} 
+
+postfixIdent :: !Ident !String -> !Ident
+postfixIdent {id_name} postfix = makeIdent (id_name +++ postfix)
+
+genericIdentToClassIdent :: !Ident !TypeKind -> !Ident
+genericIdentToClassIdent gen_name kind
+	= postfixIdent gen_name ("_" +++ kind_to_str kind) 
+where
+	kind_to_str KindConst = "s"
+	kind_to_str (KindArrow kinds) 
+		= kinds_to_str  kinds +++ "s"
+	kinds_to_str [] = ""
+	kinds_to_str [KindConst:ks] = "s" +++ kinds_to_str ks
+	kinds_to_str [k:ks] = "o" +++ (kind_to_str k) +++ "c" +++ kinds_to_str ks	
+
+genericIdentToMemberIdent :: !Ident !TypeKind -> !Ident
+genericIdentToMemberIdent gen_name kind
+	= genericIdentToClassIdent gen_name kind
+
+genericIdentToFunIdent :: !Ident !TypeCons -> !Ident
+genericIdentToFunIdent gen_name type_cons
+	= postfixIdent gen_name ("_" +++ type_cons_to_str type_cons)
+where
+	type_cons_to_str (TypeConsSymb {type_name}) = toString type_name
+	type_cons_to_str (TypeConsBasic bt) = toString bt
+	type_cons_to_str TypeConsArrow = "ARROW"
+	type_cons_to_str (TypeConsVar tv) = tv.tv_name.id_name
+		 	
\ No newline at end of file