1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
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
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
|
implementation module StdCompare
import StdEnv, compare_constructor
import syntax
instance == TypeVar
where
(==) varid1 varid2 = varid1.tv_info_ptr == varid2.tv_info_ptr
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 // MW4++
// MW4 removed: (==) cv1 cv2 = False
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
// 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
equal_constructor_args type1 type2
= True
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
:: 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
| 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
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_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
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
|
