aboutsummaryrefslogtreecommitdiff
path: root/frontend
diff options
context:
space:
mode:
Diffstat (limited to 'frontend')
-rw-r--r--frontend/compare_types.dcl22
-rw-r--r--frontend/compare_types.icl318
2 files changed, 340 insertions, 0 deletions
diff --git a/frontend/compare_types.dcl b/frontend/compare_types.dcl
new file mode 100644
index 0000000..ee0bf1c
--- /dev/null
+++ b/frontend/compare_types.dcl
@@ -0,0 +1,22 @@
+definition module compare_types
+
+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
+
+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/compare_types.icl b/frontend/compare_types.icl
new file mode 100644
index 0000000..494407f
--- /dev/null
+++ b/frontend/compare_types.icl
@@ -0,0 +1,318 @@
+implementation module compare_types
+
+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_Constructor i1) (SK_Constructor 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 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
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-25 22:14:24 +0000