blob: 69a9773e172123c2d5a251a327c6303e1d7ac013 (
plain) (
tree)
|
|
implementation module StdCompare
import StdEnv, compare_constructor
import syntax
instance == TypeVar
where
(==) varid1 varid2 = varid1.tv_info_ptr == varid2.tv_info_ptr
//AA..
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
//..AA
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 == 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
(==) 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 (TA tc1 types1) (TAS tc2 types2 _)
= tc1 == tc2 && types1 == types2
equal_constructor_args (TAS tc1 types1 _) (TA tc2 types2)
= tc1 == tc2 && types1 == types2
equal_constructor_args (TAS tc1 types1 _) (TAS 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
(==) _ _ = 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
(=<) 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 (TA tc1 _) (TAS tc2 _ _) = tc1 =< tc2
compare_arguments (TAS tc1 _ _) (TA tc2 _) = tc1 =< tc2
compare_arguments (TAS tc1 _ _) (TAS tc2 _ _) = tc1 =< tc2
compare_arguments _ _ = Equal
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 (TA tc1 args1) (TAS tc2 args2 _)
# cmp_app_symb = tc1 =< tc2
| cmp_app_symb==Equal
= args1 =< args2
= cmp_app_symb
compare_arguments (TAS tc1 args1 _) (TA tc2 args2)
# cmp_app_symb = tc1 =< tc2
| cmp_app_symb==Equal
= args1 =< args2
= cmp_app_symb
compare_arguments (TAS tc1 args1 _) (TAS 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}
= 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
|