StdCompare.icl 6.9 KB
Newer Older
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
1
2
3
4
5
6
7
implementation module StdCompare

import StdEnv, compare_constructor
import syntax

instance == TypeVar
where
Martin Wierich's avatar
bugfix    
Martin Wierich committed
8
	(==) varid1 varid2 = varid1.tv_info_ptr == varid2.tv_info_ptr
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
9

10
11
12
13
//AA..
instance == AttributeVar 
where
	(==) varid1 varid2 = varid1.av_info_ptr == varid2.av_info_ptr
Artem Alimarine's avatar
Artem Alimarine committed
14
15
16
17

instance == AttrInequality
where
	(==) ai1 ai2 = ai1.ai_demanded == ai2.ai_demanded && ai1.ai_offered == ai2.ai_offered
18
19
//..AA

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
20
21
22
23
instance == FunKind
where
	(==) fk1 fk2 = equal_constructor fk1 fk2

24
instance == (Global a) | == a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
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
44
45
	(==) (TempQCV tv1) (TempQCV tv2)	= tv1 == tv2 // MW4++
// MW4 removed:	(==) cv1 cv2					= False
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
46
47
48
49
50
51
52
53
54
55
56

instance == TypeContext
where
 (==) tc1 tc2 = tc1.tc_class == tc2.tc_class && tc1.tc_types == tc2.tc_types

instance == BasicType
where
	(==) bt1 bt2 = equal_constructor bt1 bt2

instance == BasicValue
where
57
58
59
60
	(==) (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
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
61
62
63
64
65
66
67
68
69
	(==) (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
Artem Alimarine's avatar
Artem Alimarine committed
70
		= ds1.ds_index == ds2.ds_index //&& ds1.ds_ident == ds2.ds_ident 
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89

instance == Type
where
	(==) 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 (TA tc1 types1) (TA tc2 types2)
			= tc1 == tc2 && types1 == types2
		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
90
91
92
93
94
95
96
97
// MW4..
		equal_constructor_args (GTV varid1) (GTV varid2)
			= varid1 == varid2
		equal_constructor_args (TempQV varid1) (TempQV varid2)
			= varid1 == varid2
		equal_constructor_args (TLifted varid1) (TLifted varid2)
			= varid1 == varid2
// ..MW4
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
98
99
100
		equal_constructor_args type1 type2
			= True

101
102
103
104
instance == Priority
where
	(==) NoPrio NoPrio = True
	(==) (Prio assoc1 prio1) (Prio assoc2 prio2) = assoc1==assoc2 && prio1==prio2
105
	(==) _ _ = False
106
107
108
109
110
	
instance == Assoc
where
	(==) a1 a2 = equal_constructor a1 a2

Martin Wierich's avatar
Martin Wierich committed
111
112
113
instance == SignClassification where
	(==) sc1 sc2 = sc1.sc_pos_vect == sc2.sc_pos_vect && sc1.sc_neg_vect == sc2.sc_neg_vect

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
::	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
137
			compare_indexes (SK_LocalMacroFunction i1) (SK_LocalMacroFunction i2) = i1 =< i2
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
138
139
140
141
142
143
//			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
144
			compare_indexes (SK_LocalDclMacroFunction i1) (SK_LocalDclMacroFunction i2) = i1 =< i2
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195

		| 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) 
196
//			compare_arguments (Lambda vars1 expr1) (Lambda vars2 expr2)	= (vars1,expr1) =< (vars2,expr2)
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
			compare_arguments EE EE										= Equal		
			compare_arguments _ _										= Greater		
		| less_constructor expr1 expr2
			= Smaller
			= Greater

instance =< BoundVar
where
	(=<) bv1 bv2
		= bv1.var_name =< bv2.var_name
	
instance =< FreeVar
where
	(=<) fv1 fv2
		= fv1.fv_name =< fv2.fv_name
	
instance =< Ident
where
	(=<) id1 id2
		= id1.id_name =< id2.id_name

218
instance =< (Global a) | =< a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
where
	(=<) g1 g2
		= (g1.glob_module,g1.glob_object) =< (g2.glob_module,g2.glob_object)

instance =< TypeSymbIdent
where
	(=<) s1 s2
		= s1.type_name =< s2.type_name

instance =< Type
where
	(=<) 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 (TA tc1 _) (TA tc2 _)	= tc1 =< tc2
		compare_arguments _ _					= Equal

241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
smallerOrEqual :: !Type !Type -> CompareValue
smallerOrEqual t1 t2
		| equal_constructor t1 t2
			= compare_arguments t1 t2
		| less_constructor t1 t2
			= Smaller
			= Greater
	where
		compare_arguments (TA tc1 args1) (TA tc2 args2)
			# cmp_app_symb = tc1 =< tc2
			| cmp_app_symb==Equal
				= args1 =< args2
			= cmp_app_symb
		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}
Martin Wierich's avatar
bugfix    
Martin Wierich committed
267
		= smallerOrEqual at_type_1 at_type_2
268

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
269
270
271
272
273
274
275
276
277
278
279
280
281
instance =< BasicType
where
	(=<) bt1 bt2
		| equal_constructor bt1 bt2
			= Equal
		| less_constructor bt1 bt2
			= Smaller
			= Greater

instance < MemberDef
where
	(<) md1 md2 = md1.me_symb.id_name < md2.me_symb.id_name