StdCompare.icl 6.29 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

instance == FunKind
where
	(==) fk1 fk2 = equal_constructor fk1 fk2

14
instance == (Global a) | == a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
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
34
35
	(==) (TempQCV tv1) (TempQCV tv2)	= tv1 == tv2 // MW4++
// MW4 removed:	(==) cv1 cv2					= False
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76

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
	(==) (BVI int1) (BVI 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_ident == ds2.ds_ident && ds1.ds_index == ds2.ds_index

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
77
78
79
80
81
82
83
84
// 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
85
86
87
		equal_constructor_args type1 type2
			= True

88
89
90
91
92
93
94
95
96
instance == Priority
where
	(==) NoPrio NoPrio = True
	(==) (Prio assoc1 prio1) (Prio assoc2 prio2) = assoc1==assoc2 && prio1==prio2
	
instance == Assoc
where
	(==) a1 a2 = equal_constructor a1 a2

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
::	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
120
			compare_indexes (SK_LocalMacroFunction i1) (SK_LocalMacroFunction i2) = i1 =< i2
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
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
196
197
198
199
//			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

		| 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_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

200
instance =< (Global a) | =< a
Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
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

223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
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
249
		= smallerOrEqual at_type_1 at_type_2
250

Ronny Wichers Schreur's avatar
Ronny Wichers Schreur committed
251
252
253
254
255
256
257
258
259
260
261
262
263
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