rename module StdCompare to compare_types

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

11 files changed, 9 insertions, 355 deletions

diff --git a/frontend/StdCompare.dcl b/frontend/StdCompare.dcl
deleted file mode 100644
index 1162eba..0000000
--- a/frontend/StdCompare.dcl
+++ /dev/null
@@ -1,22 +0,0 @@
-definition module StdCompare
-
-import syntax, compare_constructor
-
-::	CompareValue :== Int
-Smaller :== -1
-Greater	:== 1
-Equal	:== 0
-
-class (=<) infix 4 a :: !a !a -> CompareValue
-
-instance =< Int, Expression, {# Char}, Ident, [a] | =< a, BasicType //, (Global a) | =< a
-
-instance =< Type, SymbIdent
-
-instance == BasicType, TypeVar, AttributeVar, AttrInequality, TypeSymbIdent, DefinedSymbol, 
-			TypeContext, BasicValue, FunKind, (Global a) | == a, Priority, Assoc, Type, 
-			ConsVariable, SignClassification, TypeCons, TCClass
-
-instance < MemberDef
-
-smallerOrEqual :: !Type !Type -> CompareValue
diff --git a/frontend/StdCompare.icl b/frontend/StdCompare.icl
deleted file mode 100644
index 1e39be4..0000000
--- a/frontend/StdCompare.icl
+++ /dev/null
@@ -1,324 +0,0 @@
-implementation module StdCompare
-
-import StdEnv, compare_constructor
-import syntax
-
-instance == TypeVar
-where
-	(==) varid1 varid2 = varid1.tv_info_ptr == varid2.tv_info_ptr
-
-instance == AttributeVar 
-where
-	(==) varid1 varid2 = varid1.av_info_ptr == varid2.av_info_ptr
-
-instance == AttrInequality
-where
-	(==) ai1 ai2 = ai1.ai_demanded == ai2.ai_demanded && ai1.ai_offered == ai2.ai_offered
-
-instance == FunKind
-where
-	(==) fk1 fk2 = equal_constructor fk1 fk2
-
-instance == (Global a) | == a
-where
-	(==) g1 g2
-		= g1.glob_module == g2.glob_module && g1.glob_object == g2.glob_object
-
-
-instance == TypeSymbIdent
-where
-	(==) tsymb_id1 tsymb_id2
-		= tsymb_id1.type_index == tsymb_id2.type_index
-
-
-instance == AType
-where
-	(==) atype1 atype2 = atype1.at_type == atype2.at_type
-
-instance == ConsVariable
-where
-	(==) (CV tv1) (CV tv2)			= tv1 == tv2
-	(==) (TempCV tv1) (TempCV tv2)	= tv1 == tv2
-	(==) (TempQCV tv1) (TempQCV tv2)= tv1 == tv2
-	(==) (TempQCDV tv1) (TempQCDV tv2)= tv1 == tv2
-	(==) _ _ = False
-
-instance == TypeContext
-where
- (==) tc1 tc2 = tc1.tc_class == tc2.tc_class && tc1.tc_types == tc2.tc_types
-
-instance == TCClass
-where
-	(==) (TCClass x) (TCClass y) 				= x == y
-	(==) (TCGeneric {gtc_class}) (TCClass y) 	= gtc_class == y
-	(==) (TCClass x) (TCGeneric {gtc_class}) 	= x == gtc_class
-	(==) (TCGeneric {gtc_generic=g1,gtc_kind=k1}) (TCGeneric {gtc_generic=g2,gtc_kind=k2}) 	
-		= g1 == g2 && k1 == k2
-
-instance == BasicType
-where
-	(==) bt1 bt2 = equal_constructor bt1 bt2
-
-instance == BasicValue
-where
-	(==) (BVI int1) (BVI int2) = int1 == int2
-	(==) (BVI int1) (BVInt int2) = int1 == toString int2
-	(==) (BVInt int1) (BVI int2) = toString int1 == int2
-	(==) (BVInt int1) (BVInt int2) = int1 == int2
-	(==) (BVC char1) (BVC char2)		= char1 == char2
-	(==) (BVB bool1) (BVB bool2)		= bool1 == bool2
-	(==) (BVR real1) (BVR real2)		= real1 == real2
-	(==) (BVS string1) (BVS string2)	= string1 == string2
-	(==) _ _							= False
-			
-instance == DefinedSymbol
-where
-	(==) ds1 ds2
-		= ds1.ds_index == ds2.ds_index //&& ds1.ds_ident == ds2.ds_ident 
-
-instance == Type
-where
-	(==) (TA tc1 types1) (TA tc2 types2)
-		= tc1 == tc2 && types1 == types2
-	(==) (TA tc1 types1) (TAS tc2 types2 _)
-		= tc1 == tc2 && types1 == types2
-	(==) (TA tc1 types1) _
-		= False
-	(==) (TAS tc1 types1 _) (TA tc2 types2)
-		= tc1 == tc2 && types1 == types2
-	(==) (TAS tc1 types1 _) (TAS tc2 types2 _)
-		= tc1 == tc2 && types1 == types2
-	(==) (TAS tc1 types1 _) _
-		= False
-	(==) t1 t2
-		= equal_constructor t1 t2 && equal_constructor_args t1 t2
-	where
-		equal_constructor_args (TV varid1) (TV varid2)
-			= varid1 == varid2
-		equal_constructor_args (TempV varid1) (TempV varid2)
-			= varid1 == varid2
-		equal_constructor_args (arg_type1 --> restype1) (arg_type2 --> restype2)
-			= arg_type1 == arg_type2 && restype1 == restype2
-		equal_constructor_args (TB tb1) (TB tb2)
-			= tb1 == tb2
-		equal_constructor_args (type1 :@: types1) (type2 :@: types2)
-			= type1 == type2 && types1 == types2
-		equal_constructor_args (TQV varid1) (TQV varid2)
-			= varid1 == varid2
-		equal_constructor_args (GTV varid1) (GTV varid2)
-			= varid1 == varid2
-		equal_constructor_args (TempQV varid1) (TempQV varid2)
-			= varid1 == varid2
-		equal_constructor_args (TempQDV varid1) (TempQDV varid2)
-			= varid1 == varid2
-		equal_constructor_args (TLifted varid1) (TLifted varid2)
-			= varid1 == varid2
-		equal_constructor_args type1 type2
-			= True
-
-instance == Priority
-where
-	(==) NoPrio NoPrio = True
-	(==) (Prio assoc1 prio1) (Prio assoc2 prio2) = assoc1==assoc2 && prio1==prio2
-	(==) _ _ = False
-	
-instance == Assoc
-where
-	(==) a1 a2 = equal_constructor a1 a2
-
-instance == SignClassification where
-	(==) sc1 sc2 = sc1.sc_pos_vect == sc2.sc_pos_vect && sc1.sc_neg_vect == sc2.sc_neg_vect
-
-instance == TypeCons where
-	(==) (TypeConsSymb x) (TypeConsSymb y) = x == y 
-	(==) (TypeConsBasic x) (TypeConsBasic y) = x == y 
-	(==) TypeConsArrow TypeConsArrow = True
-	(==) (TypeConsVar x) (TypeConsVar y) = x == y
-	(==) _ _ = False
-
-::	CompareValue :== Int
-Smaller :== -1
-Greater	:== 1
-Equal	:== 0
-
-class (=<) infix 4 a :: !a !a -> CompareValue
-
-instance =< Int
-where
-	(=<) i1 i2
-		| i1 == i2
-			= Equal
-		| i1 < i2
-			= Smaller
-			= Greater
-
-instance =< SymbKind
-where
-	(=<) symb1 symb2
-		| equal_constructor symb1 symb2
-			= compare_indexes  symb1 symb2
-		with
-			compare_indexes (SK_Function i1) (SK_Function i2)						= i1 =< i2
-			compare_indexes (SK_LocalMacroFunction i1) (SK_LocalMacroFunction i2) = i1 =< i2
-//			compare_indexes (SK_ClassRecord i1) (SK_ClassRecord i2)					= i1 =< i2
-			compare_indexes (SK_Constructor i1) (SK_Constructor i2)					= i1 =< i2
-//			compare_indexes (SK_DeltaFunction i1) (SK_DeltaFunction i2)				= i1 =< i2
-//			compare_indexes (SK_InternalFunction i1) (SK_InternalFunction i2)		= i1 =< i2
-			compare_indexes (SK_OverloadedFunction i1) (SK_OverloadedFunction i2)	= i1 =< i2
-			compare_indexes (SK_GeneratedFunction _ i1) (SK_GeneratedFunction _ i2)	= i1 =< i2
-			compare_indexes (SK_LocalDclMacroFunction i1) (SK_LocalDclMacroFunction i2) = i1 =< i2
-
-		| less_constructor symb1 symb2
-			= Smaller
-			= Greater
-
-instance =< SymbIdent
-where
-	(=<) {symb_kind=symb_kind1} {symb_kind=symb_kind2} = symb_kind1 =< symb_kind2
-			
-
-instance =< App
-where
-	(=<) app1 app2
-		# cmp = app1.app_symb =< app2.app_symb
-		| cmp == Equal
-			= app1.app_args =< app2.app_args
-			= cmp
-
-instance =< (a,b) | =< a & =< b
-where
-	(=<) (x1,y1) (x2,y2)
-		# cmp = x1 =< x2
-		| cmp == Equal
-			= y1 =< y2
-			= cmp
-	
-instance =< [a] | =< a
-where
-	(=<) [x:xs] [y:ys]	= (x,xs) =< (y,ys)
-	(=<) [] []			= Equal
-	(=<) [] _			= Smaller
-	(=<) _ _			= Greater
-
-instance =< {# Char}
-where
-	(=<) s1 s2
-		| s1 == s2
-			= Equal
-		| s1 < s2
-			= Smaller
-			= Greater
-	
-instance =< Expression
-where
-	(=<) expr1 expr2
-		| equal_constructor expr1 expr2
-			= compare_arguments  expr1 expr2
-		with
-			compare_arguments (App app1) (App app2)						= app1 =< app2
-			compare_arguments (Var v1) (Var v2)							= v1 =< v2
-			compare_arguments (fun1 @ args1) (fun2 @ args2)				= (fun1,args1) =< (fun2,args2) 
-//			compare_arguments (Lambda vars1 expr1) (Lambda vars2 expr2)	= (vars1,expr1) =< (vars2,expr2)
-			compare_arguments EE EE										= Equal		
-			compare_arguments _ _										= Greater		
-		| less_constructor expr1 expr2
-			= Smaller
-			= Greater
-
-instance =< BoundVar
-where
-	(=<) bv1 bv2
-		= bv1.var_ident =< bv2.var_ident
-	
-instance =< FreeVar
-where
-	(=<) fv1 fv2
-		= fv1.fv_ident =< fv2.fv_ident
-	
-instance =< Ident
-where
-	(=<) id1 id2
-		= id1.id_name =< id2.id_name
-
-instance =< (Global a) | =< a
-where
-	(=<) g1 g2
-		= (g1.glob_module,g1.glob_object) =< (g2.glob_module,g2.glob_object)
-
-instance =< TypeSymbIdent
-where
-	(=<) s1 s2
-		= s1.type_ident =< s2.type_ident
-
-instance =< Type
-where
-	(=<) (TA tc1 _) (TA tc2 _)	= tc1 =< tc2
-	(=<) (TA tc1 _) (TAS tc2 _ _)	= tc1 =< tc2
-	(=<) (TAS tc1 _ _) (TA tc2 _)	= tc1 =< tc2
-	(=<) (TAS tc1 _ _) (TAS tc2 _ _)	= tc1 =< tc2
-	(=<) t1 t2
-		| equal_constructor t1 t2
-			= compare_arguments t1 t2
-		| less_constructor t1 t2
-			= Smaller
-			= Greater
-	where
-		compare_arguments (TB tb1) (TB tb2)		= tb1 =< tb2 
-		compare_arguments _ _					= Equal
-
-smallerOrEqual :: !Type !Type -> CompareValue
-smallerOrEqual (TA tc1 args1) (TA tc2 args2)
-	# cmp_app_symb = tc1 =< tc2
-	| cmp_app_symb==Equal
-		= args1 =< args2
-	= cmp_app_symb
-smallerOrEqual (TA tc1 args1) (TAS tc2 args2 _)
-	# cmp_app_symb = tc1 =< tc2
-	| cmp_app_symb==Equal
-		= args1 =< args2
-	= cmp_app_symb
-smallerOrEqual (TAS tc1 args1 _) (TA tc2 args2)
-	# cmp_app_symb = tc1 =< tc2
-	| cmp_app_symb==Equal
-		= args1 =< args2
-	= cmp_app_symb
-smallerOrEqual (TAS tc1 args1 _) (TAS tc2 args2 _)
-	# cmp_app_symb = tc1 =< tc2
-	| cmp_app_symb==Equal
-		= args1 =< args2
-	= cmp_app_symb
-smallerOrEqual t1 t2
-	| equal_constructor t1 t2
-		= compare_arguments t1 t2
-	| less_constructor t1 t2
-		= Smaller
-		= Greater
-	where
-		compare_arguments (l1 --> r1) (l2 --> r2)
-			# cmp_app_symb = l1 =< l2
-			| cmp_app_symb==Equal
-				= r1 =< r2
-			= cmp_app_symb
-		compare_arguments (_ :@: args1) (_ :@: args2)
-			= args1 =< args2
-		compare_arguments (TB tb1) (TB tb2)		= tb1 =< tb2 
-		compare_arguments _ _					= Equal
-
-instance =< AType
-where
-	(=<) {at_type=at_type_1} {at_type=at_type_2}
-		= smallerOrEqual at_type_1 at_type_2
-
-instance =< BasicType
-where
-	(=<) bt1 bt2
-		| equal_constructor bt1 bt2
-			= Equal
-		| less_constructor bt1 bt2
-			= Smaller
-			= Greater
-
-instance < MemberDef
-where
-	(<) md1 md2 = md1.me_ident.id_name < md2.me_ident.id_name
-
diff --git a/frontend/check.icl b/frontend/check.icl
index e323c7f..3d6e18b 100644
--- a/frontend/check.icl
+++ b/frontend/check.icl
@@ -1,6 +1,6 @@
 implementation module check
 
-import StdEnv, StdCompare
+import StdEnv, compare_types
 
 import syntax, typesupport, parse, checksupport, utilities, checktypes, transform, predef
 import explicitimports, comparedefimp, checkFunctionBodies, containers
diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl
index c41d511..9c5c8a9 100644
--- a/frontend/convertcases.icl
+++ b/frontend/convertcases.icl
@@ -3,7 +3,7 @@
 */
 implementation module convertcases
 
-import syntax, transform, StdCompare, utilities, typesupport, general
+import syntax, transform, compare_types, utilities, typesupport, general
 from partition import ::Component(..),::ComponentMembers(..)
 from trans import convertSymbolType
 
diff --git a/frontend/generics1.icl b/frontend/generics1.icl
index abc165d..5730220 100644
--- a/frontend/generics1.icl
+++ b/frontend/generics1.icl
@@ -4,7 +4,7 @@
 
 implementation module generics1
 
-import StdEnv,StdCompare
+import StdEnv,compare_types
 import check
 from checktypes import createClassDictionaries
 from transform import ::Group
diff --git a/frontend/mergecases.icl b/frontend/mergecases.icl
index 995820c..fee3c4c 100644
--- a/frontend/mergecases.icl
+++ b/frontend/mergecases.icl
@@ -3,7 +3,7 @@
 */
 implementation module mergecases
 
-import syntax, transform, StdCompare, utilities
+import syntax, transform, compare_types, utilities
 
 class GetSetPatternRhs a
 where
diff --git a/frontend/overloading.icl b/frontend/overloading.icl
index d5e61b7..f97389b 100644
--- a/frontend/overloading.icl
+++ b/frontend/overloading.icl
@@ -1,6 +1,6 @@
 implementation module overloading
 
-import StdEnv, StdCompare
+import StdEnv, compare_types
 
 import syntax, type, typesupport, utilities, unitype, predef, checktypes, convertDynamics 
 import genericsupport, type_io_common
diff --git a/frontend/postparse.icl b/frontend/postparse.icl
index 872f30e..d547327 100644
--- a/frontend/postparse.icl
+++ b/frontend/postparse.icl
@@ -1,7 +1,7 @@
 implementation module postparse
 
 import StdEnv
-import syntax, parse, utilities, containers, StdCompare
+import syntax, parse, utilities, containers, compare_types
 import genericsupport
 
 :: *CollectAdmin =
diff --git a/frontend/trans.icl b/frontend/trans.icl
index bfa2718..f8cc889 100644
--- a/frontend/trans.icl
+++ b/frontend/trans.icl
@@ -2,7 +2,7 @@ implementation module trans
 
 import StdEnv
 
-import syntax, transform, checksupport, StdCompare, check, utilities, unitype, typesupport, type
+import syntax, transform, checksupport, compare_types, check, utilities, unitype, typesupport, type
 import classify, partition
 
 SwitchCaseFusion			fuse dont_fuse :== fuse
diff --git a/frontend/typeproperties.icl b/frontend/typeproperties.icl
index 5f6e04d..1b8ab5a 100644
--- a/frontend/typeproperties.icl
+++ b/frontend/typeproperties.icl
@@ -2,7 +2,7 @@ implementation module typeproperties
 
 import StdEnv
 
-import general, StdCompare
+import general, compare_types
 
 ::	TypeClassification = 
 	{	tc_signs	:: TypeSignTree
diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl
index 54f0d8d..6f1b229 100644
--- a/frontend/typesupport.icl
+++ b/frontend/typesupport.icl
@@ -1,6 +1,6 @@
 implementation module typesupport
 
-import StdEnv, StdCompare
+import StdEnv, compare_types
 import syntax, unitype, utilities, checktypes
 
 ::	Store	:== Int