[m-rev.] for review: user-defined comparison
Simon Taylor
stayl at cs.mu.OZ.AU
Wed Jul 10 03:34:30 AEST 2002
Estimated hours taken: 10
Branches: main
Allow user-defined comparison functions using the syntax
:- type t ---> t where equality is t_equal, comparison is t_compare.
.
Allow user-defined equality and comparison for foreign types using the syntax
:- pragma foreign_type(c, t, "c_t") where
equality is t_equal, comparison is t_compare.
compiler/prog_data.m:
compiler/mercury_to_mercury.m:
compiler/hlds_out.m:
compiler/*.m:
Allow comparison predicates in `type' and `pragma foreign_type'
declarations
compiler/hlds_data.m:
compiler/*.m:
Allow equality and comparison predicates to be attached
to foreign types.
compiler/prog_io.m:
compiler/prog_io_pragma.m:
Parse the new syntax.
compiler/make_hlds.m:
Don't add the types to the HLDS or do typechecking if
there are errors in the type declarations.
Test case: tests/invalid/foreign_type_visibility.m.
compiler/foreign.m:
compiler/special_pred.m:
compiler/type_util.m:
Check whether foreign types have user-defined equality.
compiler/unify_proc.m:
Generate clauses for user-defined comparison,
and clauses for unification for foreign types.
compiler/intermod.m:
Resolve overloading before writing the `.opt' files.
library/builtin.m:
Add `uo' modes for promise_only_solution, for use in
user-defined comparison predicates.
Add types and insts to allow declaration of user-defined
comparison predicates using `with_type` and `with_inst`.
NEWS:
doc/reference_manual.texi:
Document the change.
tests/hard_coded/Mmakefile:
tests/hard_coded/user_compare.{m,exp}:
Test case.
tests/invalid/Mmakefile:
tests/invalid/typeclass_test_{9,10}.{m,err_exp}:
The change to error-checking in make_hlds.m meant that
the compilation stopped before some errors in
typeclass_test_9.m were detected. The code which
tests for those errors is now in typeclass_test_10.m.
Index: NEWS
===================================================================
RCS file: /home/mercury1/repository/mercury/NEWS,v
retrieving revision 1.260
diff -u -u -r1.260 NEWS
--- NEWS 2 Jul 2002 07:39:16 -0000 1.260
+++ NEWS 9 Jul 2002 11:13:36 -0000
@@ -9,6 +9,7 @@
* Predicate and function equivalence type and mode declarations.
* Support for defining predicates or functions
using different clauses for different modes.
+* User-defined comparison predicates.
* Support for Haskell-like "@" expressions.
Changes to the Mercury compiler:
@@ -55,6 +56,12 @@
declarations" section of the "Modes chapter" of the Mercury Language
Reference Manual.
+* We now allow user-defined comparison routines, using the syntax
+ :- type t ---> t where equality is unify_t, comparison is compare_t.
+
+ See the "User-defined equality and comparison" chapter of the
+ Mercury Language Reference Manual for details.
+
* The constructor for lists is now called '[|]' rather than '.'.
`./2' will eventually become the module qualification operator.
This change only affects programs which use `./2' explicitly.
@@ -222,6 +229,9 @@
implementing sets in the Mercury standard library.
* We've added a predicate version of `set__fold'.
+
+* builtin.m now contains types and insts `unify' and `compare' for use
+ in defining user-defined equality and comparison predicates.
* We've added function versions of `builtin__unsafe_promise_unique',
`ops__init_op_table' and `ops__max_priority'.
Index: compiler/foreign.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/foreign.m,v
retrieving revision 1.17
diff -u -u -r1.17 foreign.m
--- compiler/foreign.m 30 Jun 2002 17:06:13 -0000 1.17
+++ compiler/foreign.m 8 Jul 2002 13:42:19 -0000
@@ -19,7 +19,7 @@
:- interface.
:- import_module parse_tree__prog_data, libs__globals.
-:- import_module hlds__hlds_module, hlds__hlds_pred.
+:- import_module hlds__hlds_module, hlds__hlds_pred, hlds__hlds_data.
:- import_module bool, list, string, term.
@@ -74,6 +74,11 @@
% of that type on the current backend.
:- func foreign__to_exported_type(module_info, (type)) = exported_type.
+ % Does the implementation of the given foreign type body on
+ % the current backend use a user-defined comparison predicate.
+:- func foreign_type_body_has_user_defined_equality_pred(module_info,
+ foreign_type_body) = unify_compare is semidet.
+
% Given the exported_type representation for a type,
% determine whether or not it is a foreign type.
:- func foreign__is_foreign_type(exported_type) = bool.
@@ -594,43 +599,57 @@
to_exported_type(ModuleInfo, Type) = ExportType :-
module_info_types(ModuleInfo, Types),
- module_info_globals(ModuleInfo, Globals),
- globals__get_target(Globals, Target),
(
type_to_ctor_and_args(Type, TypeCtor, _),
map__search(Types, TypeCtor, TypeDefn)
->
hlds_data__get_type_defn_body(TypeDefn, Body),
- ( Body = foreign_type(foreign_type_body(MaybeIL, MaybeC)) ->
- ( Target = c,
- ( MaybeC = yes(c(NameStr)),
- Name = unqualified(NameStr)
- ; MaybeC = no,
- unexpected(this_file,
- "to_exported_type: no C type")
- )
- ; Target = il,
- ( MaybeIL = yes(il(_, _, Name))
- ; MaybeIL = no,
- unexpected(this_file,
- "to_exported_type: no IL type")
- )
- ; Target = java,
- sorry(this_file, "to_exported_type for java")
- ; Target = asm,
- ( MaybeC = yes(c(NameStr)),
- Name = unqualified(NameStr)
- ; MaybeC = no,
- unexpected(this_file,
- "to_exported_type: no C type")
- )
- ),
- ExportType = foreign(Name)
+ ( Body = foreign_type(ForeignTypeBody) ->
+ ExportType = foreign(fst(
+ foreign_type_body_to_exported_type(ModuleInfo,
+ ForeignTypeBody)))
;
ExportType = mercury(Type)
)
;
ExportType = mercury(Type)
+ ).
+
+foreign_type_body_has_user_defined_equality_pred(ModuleInfo, Body) =
+ UserEqComp :-
+ yes(UserEqComp) =
+ snd(foreign_type_body_to_exported_type(ModuleInfo, Body)).
+
+:- func foreign_type_body_to_exported_type(module_info, foreign_type_body) =
+ pair(sym_name, maybe(unify_compare)).
+
+foreign_type_body_to_exported_type(ModuleInfo,
+ foreign_type_body(MaybeIL, MaybeC)) = Name - MaybeUserEqComp :-
+ module_info_globals(ModuleInfo, Globals),
+ globals__get_target(Globals, Target),
+
+ ( Target = c,
+ ( MaybeC = yes(c(NameStr) - MaybeUserEqComp),
+ Name = unqualified(NameStr)
+ ; MaybeC = no,
+ unexpected(this_file,
+ "to_exported_type: no C type")
+ )
+ ; Target = il,
+ ( MaybeIL = yes(il(_, _, Name) - MaybeUserEqComp)
+ ; MaybeIL = no,
+ unexpected(this_file,
+ "to_exported_type: no IL type")
+ )
+ ; Target = java,
+ sorry(this_file, "to_exported_type for java")
+ ; Target = asm,
+ ( MaybeC = yes(c(NameStr) - MaybeUserEqComp),
+ Name = unqualified(NameStr)
+ ; MaybeC = no,
+ unexpected(this_file,
+ "to_exported_type: no C type")
+ )
).
is_foreign_type(foreign(_)) = yes.
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.70
diff -u -u -r1.70 hlds_data.m
--- compiler/hlds_data.m 30 Jun 2002 17:06:13 -0000 1.70
+++ compiler/hlds_data.m 8 Jul 2002 09:36:31 -0000
@@ -303,8 +303,9 @@
du_type_cons_tag_values :: cons_tag_values,
% is this type an enumeration?
du_type_is_enum :: bool,
- % user-defined equality pred
- du_type_usereq :: maybe(sym_name),
+ % user-defined equality and
+ % comparison preds
+ du_type_usereq :: maybe(unify_compare),
% are there `:- pragma foreign' type
% declarations for this type.
du_type_is_foreign_type :: maybe(foreign_type_body)
@@ -315,9 +316,11 @@
:- type foreign_type_body
---> foreign_type_body(
- il :: maybe(il_foreign_type),
- c :: maybe(c_foreign_type)
+ il :: foreign_type_lang_body(il_foreign_type),
+ c :: foreign_type_lang_body(c_foreign_type)
).
+
+:- type foreign_type_lang_body(T) == maybe(pair(T, maybe(unify_compare))).
% The `cons_tag_values' type stores the information on how
% a discriminated union type is represented.
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.285
diff -u -u -r1.285 hlds_out.m
--- compiler/hlds_out.m 30 Jun 2002 17:06:14 -0000 1.285
+++ compiler/hlds_out.m 8 Jul 2002 09:36:31 -0000
@@ -2882,11 +2882,27 @@
[]
),
hlds_out__write_constructors(Indent, Tvarset, Ctors, Tags),
- ( { MaybeEqualityPred = yes(PredName) } ->
+ ( { MaybeEqualityPred = yes(unify_compare(MaybeEq, MaybeCompare)) } ->
io__write_string("\n"),
hlds_out__write_indent(Indent + 1),
- io__write_string("where equality is "),
- prog_out__write_sym_name(PredName)
+ io__write_string("where "),
+ ( { MaybeEq = yes(Eq) } ->
+ io__write_string("equality is "),
+ prog_out__write_sym_name(Eq),
+ ( { MaybeCompare = yes(_) } ->
+ io__write_string(", ")
+ ;
+ []
+ )
+ ;
+ []
+ ),
+ ( { MaybeCompare = yes(Compare) } ->
+ io__write_string("comparison is "),
+ prog_out__write_sym_name(Compare)
+ ;
+ []
+ )
;
[]
),
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.122
diff -u -u -r1.122 intermod.m
--- compiler/intermod.m 30 Jun 2002 17:06:18 -0000 1.122
+++ compiler/intermod.m 8 Jul 2002 09:36:31 -0000
@@ -997,31 +997,101 @@
(
intermod__should_write_type(ModuleName, TypeCtor, TypeDefn0)
->
+ hlds_data__get_type_defn_body(TypeDefn0, TypeBody0),
(
- hlds_data__get_type_defn_body(TypeDefn0, TypeBody0),
- TypeBody0 = du_type(Ctors, Tags, Enum, MaybeUserEq0, Foreign),
- MaybeUserEq0 = yes(UserEq0)
+ TypeBody0 = du_type(Ctors, Tags, Enum,
+ MaybeUserEqComp0, MaybeForeign0)
->
- module_info_get_special_pred_map(ModuleInfo, SpecialPreds),
- map__lookup(SpecialPreds, unify - TypeCtor, UnifyPredId),
- module_info_pred_info(ModuleInfo, UnifyPredId, UnifyPredInfo),
- pred_info_arg_types(UnifyPredInfo, TVarSet, _, ArgTypes),
- typecheck__resolve_pred_overloading(ModuleInfo, ArgTypes,
- TVarSet, UserEq0, UserEq, UserEqPredId),
- TypeBody = du_type(Ctors, Tags, Enum, yes(UserEq), Foreign),
- hlds_data__set_type_defn_body(TypeDefn0, TypeBody, TypeDefn),
- intermod__add_proc(UserEqPredId, _, Info1, Info2)
+ intermod__resolve_unify_compare_overloading(ModuleInfo,
+ TypeCtor, MaybeUserEqComp0, MaybeUserEqComp,
+ Info1, Info2),
+ (
+ MaybeForeign0 = yes(Foreign0),
+ intermod__resolve_foreign_type_body_overloading(
+ ModuleInfo, TypeCtor, Foreign0, Foreign,
+ Info2, Info3),
+ MaybeForeign = yes(Foreign)
+ ;
+ MaybeForeign0 = no,
+ MaybeForeign = no,
+ Info3 = Info2
+ ),
+ TypeBody = du_type(Ctors, Tags, Enum,
+ MaybeUserEqComp, MaybeForeign),
+ hlds_data__set_type_defn_body(TypeDefn0, TypeBody, TypeDefn)
;
- Info2 = Info1,
+ TypeBody0 = foreign_type(ForeignTypeBody0)
+ ->
+ intermod__resolve_foreign_type_body_overloading(ModuleInfo,
+ TypeCtor, ForeignTypeBody0, ForeignTypeBody,
+ Info1, Info3),
+ TypeBody = foreign_type(ForeignTypeBody),
+ hlds_data__set_type_defn_body(TypeDefn0, TypeBody, TypeDefn)
+ ;
+ Info3 = Info1,
TypeDefn = TypeDefn0
),
- intermod_info_get_types(Types0, Info2, Info3),
+ intermod_info_get_types(Types0, Info3, Info4),
intermod_info_set_types([TypeCtor - TypeDefn | Types0],
- Info3, Info)
+ Info4, Info)
;
Info = Info1
).
+:- pred intermod__resolve_foreign_type_body_overloading(module_info::in,
+ type_ctor::in, foreign_type_body::in, foreign_type_body::out,
+ intermod_info::in, intermod_info::out) is det.
+
+intermod__resolve_foreign_type_body_overloading(ModuleInfo,
+ TypeCtor, foreign_type_body(MaybeIL0, MaybeC0),
+ foreign_type_body(MaybeIL, MaybeC), Info0, Info) :-
+ intermod__resolve_foreign_type_body_overloading_2(ModuleInfo, TypeCtor,
+ MaybeC0, MaybeC, Info0, Info1),
+ intermod__resolve_foreign_type_body_overloading_2(ModuleInfo, TypeCtor,
+ MaybeIL0, MaybeIL, Info1, Info).
+
+:- pred intermod__resolve_foreign_type_body_overloading_2(module_info::in,
+ type_ctor::in, foreign_type_lang_body(T)::in,
+ foreign_type_lang_body(T)::out, intermod_info::in,
+ intermod_info::out) is det.
+
+intermod__resolve_foreign_type_body_overloading_2(_, _, no, no, Info, Info).
+intermod__resolve_foreign_type_body_overloading_2(ModuleInfo, TypeCtor,
+ yes(Body - MaybeEqComp0), yes(Body - MaybeEqComp),
+ Info0, Info) :-
+ intermod__resolve_unify_compare_overloading(ModuleInfo, TypeCtor,
+ MaybeEqComp0, MaybeEqComp, Info0, Info).
+
+:- pred intermod__resolve_unify_compare_overloading(module_info::in,
+ type_ctor::in, maybe(unify_compare)::in, maybe(unify_compare)::out,
+ intermod_info::in, intermod_info::out) is det.
+
+intermod__resolve_unify_compare_overloading(_, _, no, no, Info, Info).
+intermod__resolve_unify_compare_overloading(ModuleInfo, TypeCtor,
+ yes(unify_compare(MaybeUserEq0, MaybeUserCompare0)),
+ yes(unify_compare(MaybeUserEq, MaybeUserCompare)),
+ Info0, Info) :-
+ intermod__resolve_user_special_pred_overloading(ModuleInfo,
+ unify, TypeCtor, MaybeUserEq0, MaybeUserEq, Info0, Info1),
+ intermod__resolve_user_special_pred_overloading(ModuleInfo,
+ compare, TypeCtor, MaybeUserCompare0, MaybeUserCompare,
+ Info1, Info).
+
+:- pred intermod__resolve_user_special_pred_overloading(module_info::in,
+ special_pred_id::in, type_ctor::in, maybe(sym_name)::in,
+ maybe(sym_name)::out, intermod_info::in, intermod_info::out) is det.
+
+intermod__resolve_user_special_pred_overloading(_, _, _, no, no, Info, Info).
+intermod__resolve_user_special_pred_overloading(ModuleInfo, SpecialId,
+ TypeCtor, yes(Pred0), yes(Pred), Info0, Info) :-
+ module_info_get_special_pred_map(ModuleInfo, SpecialPreds),
+ map__lookup(SpecialPreds, SpecialId - TypeCtor, UnifyPredId),
+ module_info_pred_info(ModuleInfo, UnifyPredId, UnifyPredInfo),
+ pred_info_arg_types(UnifyPredInfo, TVarSet, _, ArgTypes),
+ typecheck__resolve_pred_overloading(ModuleInfo, ArgTypes,
+ TVarSet, Pred0, Pred, UserEqPredId),
+ intermod__add_proc(UserEqPredId, _, Info0, Info).
+
:- pred intermod__should_write_type(module_name::in,
type_ctor::in, hlds_type_defn::in) is semidet.
@@ -1206,18 +1276,18 @@
},
{ ForeignTypeBody = foreign_type_body(MaybeIL, MaybeC) }
->
- ( { MaybeIL = yes(ILForeignType) },
+ ( { MaybeIL = yes(ILForeignType - ILUserEqComp) },
mercury_output_item(pragma(
foreign_type(il(ILForeignType), VarSet,
- Name, Args)),
+ Name, Args, ILUserEqComp)),
Context)
; { MaybeIL = no },
[]
),
- ( { MaybeC = yes(CForeignType) },
+ ( { MaybeC = yes(CForeignType - CUserEqComp) },
mercury_output_item(pragma(
foreign_type(c(CForeignType), VarSet,
- Name, Args)),
+ Name, Args, CUserEqComp)),
Context)
; { MaybeC = no },
[]
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.415
diff -u -u -r1.415 make_hlds.m
--- compiler/make_hlds.m 30 Jun 2002 17:06:20 -0000 1.415
+++ compiler/make_hlds.m 9 Jul 2002 16:56:51 -0000
@@ -120,7 +120,7 @@
:- import_module bag, term, varset, getopt, assoc_list, term_io.
parse_tree_to_hlds(module(Name, Items), MQInfo0, EqvMap, Module, QualInfo,
- UndefTypes, UndefModes) -->
+ TypeErrors, UndefModes) -->
globals__io_get_globals(Globals),
{ mq_info_get_partial_qualifier_info(MQInfo0, PQInfo) },
{ module_info_init(Name, Items, Globals, PQInfo, no, Module0) },
@@ -128,13 +128,27 @@
item_status(local, may_be_unqualified), Module0, Module1),
globals__io_lookup_bool_option(statistics, Statistics),
maybe_report_stats(Statistics),
- add_item_list_decls_pass_2(Items,
- item_status(local, may_be_unqualified), Module1, Module2),
- % Add constructors and special preds. This must be done after
- % adding all type and `:- pragma foreign_type' declarations.
- { module_info_types(Module2, Types) },
- map__foldl2(process_type_defn, Types, Module2, Module3),
+ check_for_errors(
+ add_item_list_decls_pass_2(Items,
+ item_status(local, may_be_unqualified)),
+ TypeErrors1, Module1, Module2),
+
+ % Add constructors and special preds to the HLDS.
+ % This must be done after adding all type and
+ % `:- pragma foreign_type' declarations.
+ % If there were errors in foreign type type declarations,
+ % doing this may cause a compiler abort.
+ (
+ { TypeErrors1 = no },
+ { module_info_types(Module2, Types) },
+ map__foldl2(process_type_defn, Types,
+ {no, Module2}, {TypeErrors2, Module3})
+ ;
+ { TypeErrors1 = yes },
+ { TypeErrors2 = yes },
+ { Module3 = Module2 }
+ ),
maybe_report_stats(Statistics),
% balance the binary trees
@@ -143,17 +157,40 @@
{ init_qual_info(MQInfo0, EqvMap, QualInfo0) },
add_item_list_clauses(Items, local, Module4, Module5,
QualInfo0, QualInfo),
+
{ qual_info_get_mq_info(QualInfo, MQInfo) },
- { mq_info_get_type_error_flag(MQInfo, UndefTypes) },
+ { mq_info_get_type_error_flag(MQInfo, TypeErrors3) },
+ { TypeErrors = TypeErrors1 `or` TypeErrors2 `or` TypeErrors3 },
{ mq_info_get_mode_error_flag(MQInfo, UndefModes) },
{ mq_info_get_num_errors(MQInfo, MQ_NumErrors) },
- { module_info_num_errors(Module4, NumErrors0) },
- { NumErrors is NumErrors0 + MQ_NumErrors },
+
+ { module_info_num_errors(Module5, NumErrors5) },
+ { NumErrors is NumErrors5 + MQ_NumErrors },
{ module_info_set_num_errors(Module5, NumErrors, Module6) },
% the predid list is constructed in reverse order, for
% efficiency, so we return it to the correct order here.
{ module_info_reverse_predids(Module6, Module) }.
+:- pred check_for_errors(pred(module_info, module_info, io__state, io__state),
+ bool, module_info, module_info, io__state, io__state).
+:- mode check_for_errors((pred(in, out, di, uo) is det),
+ out, in, out, di, uo) is det.
+
+check_for_errors(P, FoundError, Module0, Module) -->
+ io__get_exit_status(BeforeStatus),
+ io__set_exit_status(0),
+ { module_info_num_errors(Module0, BeforeNumErrors) },
+ P(Module0, Module),
+ { module_info_num_errors(Module, AfterNumErrors) },
+ io__get_exit_status(AfterStatus),
+ { FoundError =
+ (AfterStatus = 0, BeforeNumErrors = AfterNumErrors -> no ; yes) },
+ ( { BeforeStatus \= 0 } ->
+ io__set_exit_status(BeforeStatus)
+ ;
+ []
+ ).
+
%-----------------------------------------------------------------------------%
% When adding an item to the HLDS we need to know both its
@@ -414,12 +451,13 @@
{ Pragma = foreign_proc(_, _, _, _, _, _) },
{ Module = Module0 }
;
- % Note that we check during add_item_clause that we have
+ % Note that we check during process_type_defn that we have
% defined a foreign_type which is usable by the back-end
% we are compiling on.
- { Pragma = foreign_type(ForeignType, TVarSet, Name, Args) },
+ { Pragma = foreign_type(ForeignType, TVarSet, Name, Args,
+ UserEqComp) },
add_pragma_foreign_type(Context, Status, ForeignType,
- TVarSet, Name, Args, Module0, Module)
+ TVarSet, Name, Args, UserEqComp, Module0, Module)
;
% Handle pragma tabled decls later on (when we process
% clauses).
@@ -777,12 +815,6 @@
Module0, Module),
{ Info = Info0 }
;
- { Pragma = foreign_type(_, _, Name, Args) }
- ->
- check_foreign_type(Name, list__length(Args),
- Context, Module0, Module),
- { Info = Info0 }
- ;
% don't worry about any pragma declarations other than the
% clause-like pragmas (c_code, tabling and fact_table),
% foreign_type and the termination_info pragma here,
@@ -914,16 +946,19 @@
:- pred add_pragma_foreign_type(prog_context, item_status,
foreign_language_type, tvarset, sym_name, list(type_param),
- module_info, module_info, io__state, io__state).
-:- mode add_pragma_foreign_type(in, in, in, in, in, in,
+ maybe(unify_compare), module_info, module_info, io__state, io__state).
+:- mode add_pragma_foreign_type(in, in, in, in, in, in, in,
in, out, di, uo) is det.
add_pragma_foreign_type(Context, item_status(ImportStatus, NeedQual),
- ForeignType, TVarSet, Name, Args, Module0, Module) -->
+ ForeignType, TVarSet, Name, Args,
+ UserEqComp, Module0, Module) -->
{ ForeignType = il(ILForeignType),
- Body = foreign_type(foreign_type_body(yes(ILForeignType), no))
+ Body = foreign_type(foreign_type_body(
+ yes(ILForeignType - UserEqComp), no))
; ForeignType = c(CForeignType),
- Body = foreign_type(foreign_type_body(no, yes(CForeignType)))
+ Body = foreign_type(foreign_type_body(no,
+ yes(CForeignType - UserEqComp)))
},
{ Cond = true },
@@ -2055,106 +2090,122 @@
).
% Add the constructors and special preds for a type to the HLDS.
-:- pred process_type_defn(type_ctor::in, hlds_type_defn::in, module_info::in,
- module_info::out, io__state::di, io__state::uo) is det.
+:- pred process_type_defn(type_ctor::in, hlds_type_defn::in,
+ {bool, module_info}::in, {bool, module_info}::out,
+ io__state::di, io__state::uo) is det.
-process_type_defn(TypeCtor, TypeDefn, Module0, Module) -->
+process_type_defn(TypeCtor, TypeDefn, {FoundError0, Module0},
+ {FoundError, Module}) -->
{ hlds_data__get_type_defn_context(TypeDefn, Context) },
{ hlds_data__get_type_defn_tvarset(TypeDefn, TVarSet) },
{ hlds_data__get_type_defn_tparams(TypeDefn, Args) },
{ hlds_data__get_type_defn_body(TypeDefn, Body) },
{ hlds_data__get_type_defn_status(TypeDefn, Status) },
{ hlds_data__get_type_defn_need_qualifier(TypeDefn, NeedQual) },
+
(
- { Body = du_type(ConsList, _, _, _, _) }
- ->
- { module_info_ctors(Module0, Ctors0) },
+ { Body = du_type(ConsList, _, _, _, _) },
{ module_info_get_partial_qualifier_info(Module0, PQInfo) },
- { module_info_ctor_field_table(Module0, CtorFields0) },
- ctors_add(ConsList, TypeCtor, TVarSet, NeedQual,
- PQInfo, Context, Status,
- CtorFields0, CtorFields, Ctors0, Ctors),
- { module_info_set_ctors(Module0, Ctors, Module1) },
- { module_info_set_ctor_field_table(Module1,
- CtorFields, Module2) },
+ check_for_errors(
+ (pred(M0::in, M::out, di, uo) is det -->
+ { module_info_ctors(M0, Ctors0) },
+ { module_info_ctor_field_table(M0, CtorFields0) },
+ ctors_add(ConsList, TypeCtor, TVarSet, NeedQual,
+ PQInfo, Context, Status,
+ CtorFields0, CtorFields, Ctors0, Ctors),
+ { module_info_set_ctors(M0, Ctors, M1) },
+ { module_info_set_ctor_field_table(M1,
+ CtorFields, M) }
+ ), FoundError1, Module0, Module1),
+
globals__io_get_globals(Globals),
{
type_constructors_should_be_no_tag(ConsList,
Globals, Name, CtorArgType, _)
->
NoTagType = no_tag_type(Args, Name, CtorArgType),
- module_info_no_tag_types(Module2, NoTagTypes0),
+ module_info_no_tag_types(Module1, NoTagTypes0),
map__set(NoTagTypes0, TypeCtor, NoTagType, NoTagTypes),
- module_info_set_no_tag_types(Module2,
- NoTagTypes, Module3)
+ module_info_set_no_tag_types(Module1,
+ NoTagTypes, Module2)
;
- Module3 = Module2
+ Module2 = Module1
}
;
- { Module3 = Module0 }
+ { Body = abstract_type },
+ { FoundError1 = no },
+ { Module2 = Module0 }
+ ;
+ { Body = eqv_type(_) },
+ { FoundError1 = no },
+ { Module2 = Module0 }
+ ;
+ { Body = foreign_type(ForeignTypeBody) },
+ check_foreign_type(TypeCtor, ForeignTypeBody,
+ Context, FoundError1, Module0, Module2)
),
- { construct_type(TypeCtor, Args, Type) },
- { add_special_preds(Module3, TVarSet, Type, TypeCtor,
- Body, Context, Status, Module) }.
+ { FoundError = FoundError0 `and` FoundError1 },
+ { FoundError = no ->
+ construct_type(TypeCtor, Args, Type),
+ add_special_preds(Module2, TVarSet, Type, TypeCtor,
+ Body, Context, Status, Module)
+ ;
+ Module = Module2
+ }.
% check_foreign_type ensures that if we are generating code for
% a specific backend that the foreign type has a representation
% on that backend.
-:- pred check_foreign_type(sym_name::in, arity::in, prog_context::in,
- module_info::in, module_info::out, io::di, io::uo) is det.
+:- pred check_foreign_type(type_ctor::in, foreign_type_body::in,
+ prog_context::in, bool::out, module_info::in, module_info::out,
+ io::di, io::uo) is det.
-check_foreign_type(Name, Arity, Context, Module0, Module) -->
+check_foreign_type(TypeCtor, ForeignTypeBody, Context, FoundError,
+ Module0, Module) -->
{ TypeCtor = Name - Arity },
- { module_info_types(Module0, Types) },
- { TypeStr = error_util__describe_sym_name_and_arity(Name/Arity) },
- (
- { map__search(Types, TypeCtor, Defn) },
- { hlds_data__get_type_defn_body(Defn, Body) },
- { Body = foreign_type(ForeignTypeBody) }
- ->
- { module_info_globals(Module0, Globals) },
- generating_code(GeneratingCode),
- ( { GeneratingCode = yes } ->
- io_lookup_bool_option(very_verbose, VeryVerbose),
- { VeryVerbose = yes ->
- VerboseErrorPieces = [
- nl,
- words("There are representations for"),
- words("this type on other back-ends,"),
- words("but none for this back-end.")
- ]
- ;
- VerboseErrorPieces = []
- },
- { globals__get_target(Globals, Target) },
- (
- { have_foreign_type_for_backend(Target,
- ForeignTypeBody, yes) }
- ->
- { Module = Module0 }
- ;
-
- { Target = c, LangStr = "C"
- ; Target = il, LangStr = "IL"
- % Foreign types aren't yet supported for Java.
- ; Target = java, LangStr = "Mercury"
- ; Target = asm, LangStr = "C"
- },
- { ErrorPieces = [
- words("Error: no"), words(LangStr),
- words(
- "`pragma foreign_type' declaration for"),
- fixed(TypeStr) | VerboseErrorPieces
- ] },
- error_util__write_error_pieces(Context,
- 0, ErrorPieces),
- { module_info_incr_errors(Module0, Module) }
- )
+ { module_info_globals(Module0, Globals) },
+ generating_code(GeneratingCode),
+ { globals__get_target(Globals, Target) },
+ ( { have_foreign_type_for_backend(Target, ForeignTypeBody, yes) } ->
+ { FoundError = no },
+ { Module = Module0 }
+ ; { GeneratingCode = yes } ->
+ %
+ % If we're not generating code the error may only have
+ % occurred because the grade options weren't passed.
+ %
+ io_lookup_bool_option(very_verbose, VeryVerbose),
+ { VeryVerbose = yes ->
+ VerboseErrorPieces = [
+ nl,
+ words("There are representations for"),
+ words("this type on other back-ends,"),
+ words("but none for this back-end.")
+ ]
;
- { Module = Module0 }
- )
+ VerboseErrorPieces = []
+ },
+ { Target = c, LangStr = "C"
+ ; Target = il, LangStr = "IL"
+ % Foreign types aren't yet supported for Java.
+ ; Target = java, LangStr = "Mercury"
+ ; Target = asm, LangStr = "C"
+ },
+ { TypeStr =
+ error_util__describe_sym_name_and_arity(
+ Name/Arity) },
+ { ErrorPieces = [
+ words("Error: no"), words(LangStr),
+ words(
+ "`pragma foreign_type' declaration for"),
+ fixed(TypeStr) | VerboseErrorPieces
+ ] },
+ error_util__write_error_pieces(Context,
+ 0, ErrorPieces),
+ { FoundError = yes },
+ { module_info_incr_errors(Module0, Module) }
;
- % We probably chose a Mercury implementation for this type.
+ { FoundError = yes },
{ Module = Module0 }
).
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.217
diff -u -u -r1.217 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 30 Jun 2002 17:06:24 -0000 1.217
+++ compiler/mercury_to_mercury.m 8 Jul 2002 09:36:31 -0000
@@ -509,7 +509,8 @@
PredOrFunc, Vars, VarSet, PragmaCode)
;
{ Pragma = foreign_type(ForeignType, TVarSet,
- MercuryTypeSymName, MercuryTypeArgs) },
+ MercuryTypeSymName, MercuryTypeArgs,
+ MaybeEqCompare) },
io__write_string(":- pragma foreign_type("),
( { ForeignType = il(_) },
@@ -520,6 +521,12 @@
{ construct_qualified_term(MercuryTypeSymName,
MercuryTypeArgs, MercuryType) },
mercury_output_term(MercuryType, TVarSet, no),
+ ( { MaybeEqCompare = yes(_) } ->
+ io__write_string(" ")
+ ;
+ []
+ ),
+ mercury_output_equality_compare_preds(MaybeEqCompare),
io__write_string(", \""),
{ ForeignType = il(il(RefOrVal,
ForeignLocStr, ForeignTypeName)),
@@ -1616,19 +1623,44 @@
io__write_string(".\n").
mercury_output_type_defn(VarSet, Name, Args,
- du_type(Ctors, MaybeEqualityPred), Context) -->
+ du_type(Ctors, MaybeEqCompare), Context) -->
io__write_string(":- type "),
{ construct_qualified_term(Name, Args, Context, TypeTerm) },
mercury_output_term(TypeTerm, VarSet, no),
io__write_string("\n\t--->\t"),
mercury_output_ctors(Ctors, VarSet),
- ( { MaybeEqualityPred = yes(EqualityPredName) } ->
- io__write_string("\n\twhere equality is "),
- mercury_output_bracketed_sym_name(EqualityPredName)
+ ( { MaybeEqCompare = yes(_) } ->
+ io__write_string("\n\t")
;
[]
),
+ mercury_output_equality_compare_preds(MaybeEqCompare),
io__write_string("\n\t.\n").
+
+:- pred mercury_output_equality_compare_preds(maybe(unify_compare)::in,
+ io__state::di, io__state::uo) is det.
+
+mercury_output_equality_compare_preds(no) --> [].
+mercury_output_equality_compare_preds(
+ yes(unify_compare(MaybeEqualityPred, MaybeComparisonPred))) -->
+ io__write_string("where "),
+ ( { MaybeEqualityPred = yes(EqualityPredName) } ->
+ io__write_string("equality is "),
+ mercury_output_bracketed_sym_name(EqualityPredName),
+ ( { MaybeComparisonPred = yes(_) } ->
+ io__write_string(", ")
+ ;
+ []
+ )
+ ;
+ []
+ ),
+ ( { MaybeComparisonPred = yes(ComparisonPredName) } ->
+ io__write_string("comparison is "),
+ mercury_output_bracketed_sym_name(ComparisonPredName)
+ ;
+ []
+ ).
:- pred mercury_output_ctors(list(constructor), tvarset,
io__state, io__state).
Index: compiler/ml_code_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_code_gen.m,v
retrieving revision 1.120
diff -u -u -r1.120 ml_code_gen.m
--- compiler/ml_code_gen.m 30 Jun 2002 17:06:26 -0000 1.120
+++ compiler/ml_code_gen.m 8 Jul 2002 09:36:31 -0000
@@ -877,7 +877,7 @@
foreign_type_required_imports(il, TypeDefn) = Imports :-
hlds_data__get_type_defn_body(TypeDefn, Body),
( Body = foreign_type(foreign_type_body(MaybeIL, _MaybeC)) ->
- ( MaybeIL = yes(il(_, Location, _)) ->
+ ( MaybeIL = yes(il(_, Location, _) - _) ->
Name = il_assembly_name(mercury_module_name_to_mlds(
unqualified(Location))),
Imports = [foreign_import(Name)]
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.29
diff -u -u -r1.29 ml_type_gen.m
--- compiler/ml_type_gen.m 1 Jul 2002 14:37:31 -0000 1.29
+++ compiler/ml_type_gen.m 8 Jul 2002 09:36:31 -0000
@@ -122,9 +122,9 @@
ml_gen_type_2(eqv_type(_EqvType), _, _, _) --> []. % XXX Fixme!
% For a description of the problems with equivalence types,
% see our BABEL'01 paper "Compiling Mercury to the .NET CLR".
-ml_gen_type_2(du_type(Ctors, TagValues, IsEnum, MaybeEqualityPred, _),
+ml_gen_type_2(du_type(Ctors, TagValues, IsEnum, MaybeUserEqCompare, _),
ModuleInfo, TypeCtor, TypeDefn) -->
- { ml_gen_equality_members(MaybeEqualityPred, MaybeEqualityMembers) },
+ { ml_gen_equality_members(MaybeUserEqCompare, MaybeEqualityMembers) },
( { IsEnum = yes } ->
ml_gen_enum_type(TypeCtor, TypeDefn, Ctors, TagValues,
MaybeEqualityMembers)
@@ -916,7 +916,7 @@
% For interoperability, we ought to generate an `==' member
% for types which have a user-defined equality, if the target
% language supports it (as do e.g. C++, Java).
-:- pred ml_gen_equality_members(maybe(sym_name), list(mlds__defn)).
+:- pred ml_gen_equality_members(maybe(unify_compare), list(mlds__defn)).
:- mode ml_gen_equality_members(in, out) is det.
ml_gen_equality_members(_, []). % XXX generation of `==' members
% is not yet implemented.
Index: compiler/mlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mlds.m,v
retrieving revision 1.96
diff -u -u -r1.96 mlds.m
--- compiler/mlds.m 1 Jul 2002 09:03:52 -0000 1.96
+++ compiler/mlds.m 8 Jul 2002 09:36:31 -0000
@@ -1699,7 +1699,7 @@
module_info_globals(ModuleInfo, Globals),
globals__get_target(Globals, Target),
( Target = c,
- ( MaybeC = yes(CForeignType),
+ ( MaybeC = yes(CForeignType - _),
ForeignType = c(CForeignType)
; MaybeC = no,
% This is checked by check_foreign_type
@@ -1708,7 +1708,7 @@
"mercury_type_to_mlds_type: No C foreign type")
)
; Target = il,
- ( MaybeIL = yes(ILForeignType),
+ ( MaybeIL = yes(ILForeignType - _),
ForeignType = il(ILForeignType)
; MaybeIL = no,
% This is checked by check_foreign_type
@@ -1719,7 +1719,7 @@
; Target = java,
sorry(this_file, "foreign types on the java backend")
; Target = asm,
- ( MaybeC = yes(CForeignType),
+ ( MaybeC = yes(CForeignType - _),
ForeignType = c(CForeignType)
; MaybeC = no,
% XXX This ought to be checked by the
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.80
diff -u -u -r1.80 module_qual.m
--- compiler/module_qual.m 30 Jun 2002 17:06:32 -0000 1.80
+++ compiler/module_qual.m 9 Jul 2002 07:51:43 -0000
@@ -883,7 +883,7 @@
qualify_pragma(X at source_file(_), X, Info, Info) --> [].
qualify_pragma(X at foreign_decl(_, _), X, Info, Info) --> [].
qualify_pragma(X at foreign_code(_, _), X, Info, Info) --> [].
-qualify_pragma(X at foreign_type(_, _, _, _), X, Info, Info) --> [].
+qualify_pragma(X at foreign_type(_, _, _, _, _), X, Info, Info) --> [].
qualify_pragma(X at foreign_import_module(_, _), X, Info, Info) --> [].
qualify_pragma(
foreign_proc(Rec, SymName, PredOrFunc, PragmaVars0, Varset, Code),
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.239
diff -u -u -r1.239 modules.m
--- compiler/modules.m 30 Jun 2002 17:06:33 -0000 1.239
+++ compiler/modules.m 8 Jul 2002 09:36:31 -0000
@@ -1224,7 +1224,7 @@
pragma_allowed_in_interface(foreign_import_module(_, _), no).
pragma_allowed_in_interface(foreign_code(_, _), no).
pragma_allowed_in_interface(foreign_proc(_, _, _, _, _, _), no).
-pragma_allowed_in_interface(foreign_type(_, _, _, _), yes).
+pragma_allowed_in_interface(foreign_type(_, _, _, _, _), yes).
pragma_allowed_in_interface(inline(_, _), no).
pragma_allowed_in_interface(no_inline(_, _), no).
pragma_allowed_in_interface(obsolete(_, _), yes).
Index: compiler/pragma_c_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/pragma_c_gen.m,v
retrieving revision 1.53
diff -u -u -r1.53 pragma_c_gen.m
--- compiler/pragma_c_gen.m 30 Jun 2002 17:06:36 -0000 1.53
+++ compiler/pragma_c_gen.m 8 Jul 2002 09:36:31 -0000
@@ -1209,7 +1209,7 @@
hlds_data__get_type_defn_body(Defn, Body),
Body = foreign_type(foreign_type_body(_MaybeIL, MaybeC))
->
- ( MaybeC = yes(c(Name)),
+ ( MaybeC = yes(c(Name) - _),
MaybeForeignType = yes(Name)
; MaybeC = no,
% This is ensured by check_foreign_type in
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.84
diff -u -u -r1.84 prog_data.m
--- compiler/prog_data.m 30 Jun 2002 17:06:36 -0000 1.84
+++ compiler/prog_data.m 8 Jul 2002 09:36:31 -0000
@@ -173,9 +173,9 @@
% VarNames, Foreign Code Implementation Info
; foreign_type(foreign_language_type, tvarset,
- sym_name, list(type_param))
+ sym_name, list(type_param), maybe(unify_compare))
% ForeignType, TVarSet, MercuryTypeName,
- % MercuryTypeParams
+ % MercuryTypeParams, UnifyAndCompare
; foreign_import_module(foreign_language, module_name)
% Equivalent to
@@ -760,7 +760,7 @@
% type_defn/3 is defined above as a constructor for item/0
:- type type_defn
- ---> du_type(list(constructor), maybe(equality_pred))
+ ---> du_type(list(constructor), maybe(unify_compare))
; eqv_type(type)
; abstract_type.
@@ -780,10 +780,19 @@
:- type ctor_field_name == sym_name.
+:- type unify_compare
+ ---> unify_compare(
+ unify :: maybe(equality_pred),
+ compare :: maybe(comparison_pred)
+ ).
+
% An equality_pred specifies the name of a user-defined predicate
% used for equality on a type. See the chapter on them in the
% Mercury Language Reference Manual.
:- type equality_pred == sym_name.
+
+ % The name of a user-defined comparison predicate.
+:- type comparison_pred == sym_name.
% probably type parameters should be variables not terms.
:- type type_param == term(tvar_type).
Index: compiler/prog_io.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io.m,v
retrieving revision 1.209
diff -u -u -r1.209 prog_io.m
--- compiler/prog_io.m 30 Jun 2002 17:06:37 -0000 1.209
+++ compiler/prog_io.m 8 Jul 2002 09:36:31 -0000
@@ -183,6 +183,20 @@
:- pred parse_type_defn_head(module_name, term, term, maybe_functor).
:- mode parse_type_defn_head(in, in, in, out) is det.
+ % get_maybe_equality_compare_preds(Body0, Body, MaybeEqualPred):
+ % Checks if `Body0' is a term of the form
+ % `<body> where equality is <symname>'
+ % `<body> where comparison is <symname>'
+ % or `<body> where equality is <symname>,
+ % comparison is <sym_name>'
+ % If so, returns the `<body>' in Body and the <symname>s in
+ % MaybeEqualPred. If not, returns Body = Body0
+ % and `no' in MaybeEqualPred.
+
+:- pred get_maybe_equality_compare_preds(term, term,
+ maybe1(maybe(unify_compare))).
+:- mode get_maybe_equality_compare_preds(in, out, out) is det.
+
%-----------------------------------------------------------------------------%
% A QualifiedTerm is one of
@@ -1497,8 +1511,8 @@
parse_type_decl_type(ModuleName, "--->", [H, B], Condition, R) :-
/* get_condition(...), */
Condition = true,
- get_maybe_equality_pred(B, Body, EqualityPred),
- process_du_type(ModuleName, H, Body, EqualityPred, R).
+ get_maybe_equality_compare_preds(B, Body, EqCompare),
+ process_du_type(ModuleName, H, Body, EqCompare, R).
parse_type_decl_type(ModuleName, "==", [H, B], Condition, R) :-
get_condition(B, Body, Condition),
@@ -1620,41 +1634,72 @@
%-----------------------------------------------------------------------------%
- % get_maybe_equality_pred(Body0, Body, MaybeEqualPred):
- % Checks if `Body0' is a term of the form
- % `<body> where equality is <symname>'
- % If so, returns the `<body>' in Body and the <symname> in
- % MaybeEqualPred. If not, returns Body = Body0
- % and `no' in MaybeEqualPred.
-
-:- pred get_maybe_equality_pred(term, term, maybe1(maybe(sym_name))).
-:- mode get_maybe_equality_pred(in, out, out) is det.
-
-get_maybe_equality_pred(B, Body, MaybeEqualityPred) :-
+get_maybe_equality_compare_preds(B, Body, MaybeEqComp) :-
(
B = term__functor(term__atom("where"), Args, _Context1),
- Args = [Body1, Equality_Is_PredName]
+ Args = [Body1, EqCompTerm]
->
Body = Body1,
(
- Equality_Is_PredName = term__functor(term__atom("is"),
- [Equality, PredName], _),
- Equality = term__functor(term__atom("equality"), [], _)
+ parse_equality_or_comparison_pred_term("equality",
+ EqCompTerm, PredName)
->
- parse_symbol_name(PredName, MaybeEqualityPred0),
- process_maybe1(make_yes, MaybeEqualityPred0,
- MaybeEqualityPred)
+ parse_symbol_name(PredName, MaybeEqComp0),
+ process_maybe1(make_equality, MaybeEqComp0,
+ MaybeEqComp)
;
- MaybeEqualityPred = error("syntax error after `where'",
+ parse_equality_or_comparison_pred_term("comparison",
+ EqCompTerm, PredName)
+ ->
+ parse_symbol_name(PredName, MaybeEqComp0),
+ process_maybe1(make_comparison, MaybeEqComp0,
+ MaybeEqComp)
+ ;
+ EqCompTerm = term__functor(term__atom(","),
+ [EqTerm, CompTerm], _),
+ parse_equality_or_comparison_pred_term("equality",
+ EqTerm, EqPredNameTerm),
+ parse_equality_or_comparison_pred_term("comparison",
+ CompTerm, CompPredNameTerm)
+ ->
+ parse_symbol_name(EqPredNameTerm, EqPredNameResult),
+ parse_symbol_name(CompPredNameTerm,
+ CompPredNameResult),
+ (
+ EqPredNameResult = ok(EqPredName),
+ CompPredNameResult = ok(CompPredName),
+ MaybeEqComp = ok(yes(
+ unify_compare(yes(EqPredName),
+ yes(CompPredName))))
+ ;
+ EqPredNameResult = ok(_),
+ CompPredNameResult = error(M, T),
+ MaybeEqComp = error(M, T)
+ ;
+ EqPredNameResult = error(M, T),
+ MaybeEqComp = error(M, T)
+ )
+ ;
+ MaybeEqComp = error("syntax error after `where'",
Body)
)
;
Body = B,
- MaybeEqualityPred = ok(no)
+ MaybeEqComp = ok(no)
).
-:- pred make_yes(T::in, maybe(T)::out) is det.
-make_yes(T, yes(T)).
+:- pred parse_equality_or_comparison_pred_term(string::in, term::in,
+ term::out) is semidet.
+
+parse_equality_or_comparison_pred_term(EqOrComp, Term, PredNameTerm) :-
+ Term = term__functor(term__atom("is"),
+ [term__functor(term__atom(EqOrComp), [], _), PredNameTerm], _).
+
+:- pred make_equality(sym_name::in, maybe(unify_compare)::out) is det.
+make_equality(Pred, yes(unify_compare(yes(Pred), no))).
+
+:- pred make_comparison(sym_name::in, maybe(unify_compare)::out) is det.
+make_comparison(Pred, yes(unify_compare(no, yes(Pred)))).
% get_determinism(Term0, Term, Determinism) binds Determinism
% to a representation of the determinism condition of Term0, if any,
@@ -1804,7 +1849,7 @@
% binds Result to a representation of the type information about the
% TypeHead.
% This is for "Head ---> Body" (constructor) definitions.
-:- pred process_du_type(module_name, term, term, maybe1(maybe(equality_pred)),
+:- pred process_du_type(module_name, term, term, maybe1(maybe(unify_compare)),
maybe1(processed_type_body)).
:- mode process_du_type(in, in, in, in, out) is det.
process_du_type(ModuleName, Head, Body, EqualityPred, Result) :-
@@ -1812,7 +1857,7 @@
process_du_type_2(ModuleName, Result0, Body, EqualityPred, Result).
:- pred process_du_type_2(module_name, maybe_functor, term,
- maybe1(maybe(equality_pred)), maybe1(processed_type_body)).
+ maybe1(maybe(unify_compare)), maybe1(processed_type_body)).
:- mode process_du_type_2(in, in, in, in, out) is det.
process_du_type_2(_, error(Error, Term), _, _, error(Error, Term)).
process_du_type_2(ModuleName, ok(Functor, Args0), Body, MaybeEqualityPred,
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.51
diff -u -u -r1.51 prog_io_pragma.m
--- compiler/prog_io_pragma.m 30 Jun 2002 17:06:38 -0000 1.51
+++ compiler/prog_io_pragma.m 9 Jul 2002 17:15:08 -0000
@@ -30,13 +30,38 @@
parse_pragma(ModuleName, VarSet, PragmaTerms, Result) :-
(
% new syntax: `:- pragma foo(...).'
- PragmaTerms = [SinglePragmaTerm],
+ PragmaTerms = [SinglePragmaTerm0],
+ get_maybe_equality_compare_preds(SinglePragmaTerm0,
+ SinglePragmaTerm, UnifyCompareResult),
SinglePragmaTerm = term__functor(term__atom(PragmaType),
PragmaArgs, _),
parse_pragma_type(ModuleName, PragmaType, PragmaArgs,
SinglePragmaTerm, VarSet, Result0)
->
- Result = Result0
+ (
+ UnifyCompareResult = ok(MaybeUserEqCompare),
+ (
+ MaybeUserEqCompare = yes(_),
+ Result0 = ok(Pragma)
+ ->
+ (
+ Pragma = pragma(foreign_type(A,
+ B, C, D, _))
+ ->
+ Result = ok(pragma(foreign_type(A,
+ B, C, D, MaybeUserEqCompare)))
+ ;
+ Result = error(
+ "unexpected `where equality/comparison is'",
+ SinglePragmaTerm0)
+ )
+ ;
+ Result = Result0
+ )
+ ;
+ UnifyCompareResult = error(Msg, Term),
+ Result = error(Msg, Term)
+ )
;
% old syntax: `:- pragma(foo, ...).'
% XXX we should issue a warning; this syntax is deprecated.
@@ -86,7 +111,8 @@
varset__coerce(VarSet, TVarSet),
MercuryArgs = list__map(term__coerce, MercuryArgs0),
Result = ok(pragma(foreign_type(ForeignType,
- TVarSet, MercuryTypeSymName, MercuryArgs)))
+ TVarSet, MercuryTypeSymName,
+ MercuryArgs, no)))
;
MaybeTypeDefnHead = error(String, Term),
Result = error(String, Term)
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.2
diff -u -u -r1.2 recompilation.version.m
--- compiler/recompilation.version.m 30 Jun 2002 17:06:39 -0000 1.2
+++ compiler/recompilation.version.m 8 Jul 2002 09:36:31 -0000
@@ -538,7 +538,7 @@
is_pred_pragma(foreign_proc(_, Name, PredOrFunc, Args, _, _),
yes(yes(PredOrFunc) - Name / Arity)) :-
adjust_func_arity(PredOrFunc, Arity, list__length(Args)).
-is_pred_pragma(foreign_type(_, _, _, _), no).
+is_pred_pragma(foreign_type(_, _, _, _, _), no).
is_pred_pragma(type_spec(Name, _, Arity, MaybePredOrFunc, _, _, _, _),
yes(MaybePredOrFunc - Name / Arity)).
is_pred_pragma(inline(Name, Arity), yes(no - Name / Arity)).
Index: compiler/special_pred.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/special_pred.m,v
retrieving revision 1.33
diff -u -u -r1.33 special_pred.m
--- compiler/special_pred.m 30 Jun 2002 17:06:40 -0000 1.33
+++ compiler/special_pred.m 8 Jul 2002 13:42:19 -0000
@@ -93,8 +93,8 @@
% or (b) it is the unification or comparison predicate for an
% existially quantified type.
%
-:- pred special_pred_for_type_needs_typecheck(hlds_type_body).
-:- mode special_pred_for_type_needs_typecheck(in) is semidet.
+:- pred special_pred_for_type_needs_typecheck(module_info, hlds_type_body).
+:- mode special_pred_for_type_needs_typecheck(in, in) is semidet.
% Succeed if the type can have clauses generated for
% its special predicates. This will fail for abstract
@@ -129,9 +129,7 @@
special_pred_info(compare, Type,
"__Compare__", [ResType, Type, Type], [Uo, In, In], det) :-
- mercury_public_builtin_module(PublicBuiltin),
- construct_type(qualified(PublicBuiltin, "comparison_result") - 0,
- [], ResType),
+ ResType = comparison_result_type,
in_mode(In),
uo_mode(Uo).
@@ -207,13 +205,13 @@
% The special predicates for types with user-defined
% equality or existentially typed constructors are always
% generated immediately by make_hlds.m.
- \+ special_pred_for_type_needs_typecheck(Body).
+ \+ special_pred_for_type_needs_typecheck(ModuleInfo, Body).
-special_pred_for_type_needs_typecheck(Body) :-
- Body = du_type(Ctors, _, _, MaybeEqualityPred, _),
+special_pred_for_type_needs_typecheck(ModuleInfo, Body) :-
(
- MaybeEqualityPred = yes(_)
+ type_body_has_user_defined_equality_pred(ModuleInfo, Body, _)
;
+ Body = du_type(Ctors, _, _, _, _),
list__member(Ctor, Ctors),
Ctor = ctor(ExistQTVars, _, _, _),
ExistQTVars \= []
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.108
diff -u -u -r1.108 type_util.m
--- compiler/type_util.m 30 Jun 2002 17:06:41 -0000 1.108
+++ compiler/type_util.m 8 Jul 2002 13:45:40 -0000
@@ -60,9 +60,13 @@
% return true iff there was a `where equality is <predname>'
% declaration for the specified type, and return the name of
% the equality predicate and the context of the type declaration.
-:- pred type_has_user_defined_equality_pred(module_info, (type), sym_name).
+:- pred type_has_user_defined_equality_pred(module_info,
+ (type), unify_compare).
:- mode type_has_user_defined_equality_pred(in, in, out) is semidet.
+:- pred type_body_has_user_defined_equality_pred(module_info::in,
+ hlds_type_body::in, unify_compare::out) is semidet.
+
% Certain types, e.g. io__state and store__store(S),
% are just dummy types used to ensure logical semantics;
% there is no need to actually pass them, and so when
@@ -174,6 +178,7 @@
:- func float_type = (type).
:- func char_type = (type).
:- func c_pointer_type = (type).
+:- func comparison_result_type = (type).
:- func heap_pointer_type = (type).
:- func sample_type_info_type = (type).
:- func sample_typeclass_info_type = (type).
@@ -488,6 +493,7 @@
:- import_module parse_tree__prog_io, parse_tree__prog_io_goal.
:- import_module parse_tree__prog_util, libs__options, libs__globals.
+:- import_module backend_libs__foreign.
:- import_module bool, char, int, string.
:- import_module assoc_list, require, varset.
@@ -640,12 +646,22 @@
type_ctor_is_tuple(unqualified("{}") - _).
-type_has_user_defined_equality_pred(ModuleInfo, Type, SymName) :-
+type_has_user_defined_equality_pred(ModuleInfo, Type, UserEqComp) :-
module_info_types(ModuleInfo, TypeTable),
type_to_ctor_and_args(Type, TypeCtor, _TypeArgs),
map__search(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
- TypeBody ^ du_type_usereq = yes(SymName).
+ type_body_has_user_defined_equality_pred(ModuleInfo, TypeBody,
+ UserEqComp).
+
+type_body_has_user_defined_equality_pred(ModuleInfo, TypeBody, UserEqComp) :-
+ (
+ TypeBody ^ du_type_usereq = yes(UserEqComp)
+ ;
+ TypeBody = foreign_type(ForeignTypeBody),
+ UserEqComp = foreign_type_body_has_user_defined_equality_pred(
+ ModuleInfo, ForeignTypeBody)
+ ).
% Certain types, e.g. io__state and store__store(S),
% are just dummy types used to ensure logical semantics;
@@ -808,6 +824,11 @@
c_pointer_type = Type :-
mercury_public_builtin_module(BuiltinModule),
construct_type(qualified(BuiltinModule, "c_pointer") - 0, [], Type).
+
+comparison_result_type = Type :-
+ mercury_public_builtin_module(BuiltinModule),
+ construct_type(qualified(BuiltinModule, "comparison_result") - 0,
+ [], Type).
heap_pointer_type = Type :-
mercury_private_builtin_module(BuiltinModule),
Index: compiler/typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/typecheck.m,v
retrieving revision 1.320
diff -u -u -r1.320 typecheck.m
--- compiler/typecheck.m 30 Jun 2002 17:06:42 -0000 1.320
+++ compiler/typecheck.m 8 Jul 2002 09:36:31 -0000
@@ -794,7 +794,7 @@
module_info_types(ModuleInfo, TypeTable),
map__lookup(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, Body),
- special_pred_for_type_needs_typecheck(Body).
+ special_pred_for_type_needs_typecheck(ModuleInfo, Body).
%-----------------------------------------------------------------------------%
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.111
diff -u -u -r1.111 unify_proc.m
--- compiler/unify_proc.m 30 Jun 2002 17:06:45 -0000 1.111
+++ compiler/unify_proc.m 8 Jul 2002 13:45:40 -0000
@@ -679,14 +679,15 @@
unify_proc__make_fresh_named_vars_from_types(ArgTypes, "HeadVar__", 1,
Args, VarTypeInfo0, VarTypeInfo1),
( SpecialPredId = unify, Args = [H1, H2] ->
- unify_proc__generate_unify_clauses(TypeBody, H1, H2,
- Context, Clauses, VarTypeInfo1, VarTypeInfo)
+ unify_proc__generate_unify_clauses(ModuleInfo, TypeBody,
+ H1, H2, Context, Clauses, VarTypeInfo1, VarTypeInfo)
; SpecialPredId = index, Args = [X, Index] ->
- unify_proc__generate_index_clauses(TypeBody,
+ unify_proc__generate_index_clauses(ModuleInfo, TypeBody,
X, Index, Context, Clauses, VarTypeInfo1, VarTypeInfo)
; SpecialPredId = compare, Args = [Res, X, Y] ->
- unify_proc__generate_compare_clauses(Type, TypeBody,
- Res, X, Y, Context, Clauses, VarTypeInfo1, VarTypeInfo)
+ unify_proc__generate_compare_clauses(ModuleInfo, Type,
+ TypeBody, Res, X, Y, Context, Clauses,
+ VarTypeInfo1, VarTypeInfo)
;
error("unknown special pred")
),
@@ -699,32 +700,22 @@
Types, Args, Clauses, TI_VarMap, TCI_VarMap,
HasForeignClauses).
-:- pred unify_proc__generate_unify_clauses(hlds_type_body::in,
+:- pred unify_proc__generate_unify_clauses(module_info::in, hlds_type_body::in,
prog_var::in, prog_var::in, prog_context::in, list(clause)::out,
unify_proc_info::in, unify_proc_info::out) is det.
-unify_proc__generate_unify_clauses(TypeBody, H1, H2, Context, Clauses) -->
+unify_proc__generate_unify_clauses(ModuleInfo, TypeBody,
+ H1, H2, Context, Clauses) -->
+ (
+ { type_body_has_user_defined_equality_pred(ModuleInfo,
+ TypeBody, UserEqCompare) }
+ ->
+ unify_proc__generate_user_defined_unify_clauses(
+ UserEqCompare, H1, H2, Context, Clauses)
+ ;
(
- { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred, _) },
- ( { MaybeEqPred = yes(PredName) } ->
- %
- % Just generate a call to the specified predicate,
- % which is the user-defined equality pred for this
- % type.
- % (The pred_id and proc_id will be figured
- % out by type checking and mode analysis.)
- %
- { invalid_pred_id(PredId) },
- { invalid_proc_id(ModeId) },
- { Call = call(PredId, ModeId, [H1, H2], not_builtin,
- no, PredName) },
- { goal_info_init(GoalInfo0) },
- { goal_info_set_context(GoalInfo0, Context,
- GoalInfo) },
- { Goal = Call - GoalInfo },
- unify_proc__quantify_clauses_body([H1, H2], Goal,
- Context, Clauses)
- ; { IsEnum = yes } ->
+ { TypeBody = du_type(Ctors, _, IsEnum, _, _) },
+ ( { IsEnum = yes } ->
%
% Enumerations are atomic types, so modecheck_unify.m
% will treat this unification as a simple_test, not
@@ -743,15 +734,68 @@
generate_unify_clauses_eqv_type(EqvType, H1, H2,
Context, Clauses)
;
- % We treat foreign_type as if they were an equivalent to
- % the builtin type c_pointer.
{ TypeBody = foreign_type(_) },
+ % If no user defined equality predicate is given,
+ % we treat foreign_type as if they were an equivalent
+ % to the builtin type c_pointer.
generate_unify_clauses_eqv_type(c_pointer_type,
H1, H2, Context, Clauses)
;
{ TypeBody = abstract_type },
{ error("trying to create unify proc for abstract type") }
- ).
+ )
+ ).
+
+:- pred unify_proc__generate_user_defined_unify_clauses(unify_compare::in,
+ prog_var::in, prog_var::in, prog_context::in, list(clause)::out,
+ unify_proc_info::in, unify_proc_info::out) is det.
+
+unify_proc__generate_user_defined_unify_clauses(UserEqCompare, H1, H2,
+ Context, Clauses) -->
+ { UserEqCompare = unify_compare(MaybeUnify, MaybeCompare) },
+ (
+ { MaybeUnify = yes(UnifyPredName) }
+ ->
+ %
+ % Just generate a call to the specified predicate,
+ % which is the user-defined equality pred for this
+ % type.
+ % (The pred_id and proc_id will be figured
+ % out by type checking and mode analysis.)
+ %
+ { invalid_pred_id(PredId) },
+ { invalid_proc_id(ModeId) },
+ { Call = call(PredId, ModeId, [H1, H2], not_builtin,
+ no, UnifyPredName) },
+ { goal_info_init(Context, GoalInfo) },
+ { Goal = Call - GoalInfo }
+ ;
+ { MaybeCompare = yes(ComparePredName) }
+ ->
+ %
+ % Just generate a call to the specified predicate,
+ % which is the user-defined comparison pred for this
+ % type, and unify the result with `='.
+ % (The pred_id and proc_id will be figured
+ % out by type checking and mode analysis.)
+ %
+ unify_proc__info_new_var(comparison_result_type, ResultVar),
+ { invalid_pred_id(PredId) },
+ { invalid_proc_id(ModeId) },
+ { Call = call(PredId, ModeId, [ResultVar, H1, H2],
+ not_builtin, no, ComparePredName) },
+ { goal_info_init(Context, GoalInfo) },
+ { CallGoal = Call - GoalInfo },
+
+ { mercury_public_builtin_module(Builtin) },
+ { create_atomic_unification(ResultVar,
+ functor(cons(qualified(Builtin, "="), 0), []),
+ Context, explicit, [], UnifyGoal) },
+ { Goal = conj([CallGoal, UnifyGoal]) - GoalInfo }
+ ;
+ { error("unify_proc__generate_user_defined_unify_clauses") }
+ ),
+ unify_proc__quantify_clauses_body([H1, H2], Goal, Context, Clauses).
:- pred generate_unify_clauses_eqv_type((type)::in, prog_var::in, prog_var::in,
prog_context::in, list(clause)::out,
@@ -789,22 +833,25 @@
% of special preds to define only for the kinds of types which do not
% lead this predicate to abort.
-:- pred unify_proc__generate_index_clauses(hlds_type_body::in,
+:- pred unify_proc__generate_index_clauses(module_info::in, hlds_type_body::in,
prog_var::in, prog_var::in, prog_context::in, list(clause)::out,
unify_proc_info::in, unify_proc_info::out) is det.
-unify_proc__generate_index_clauses(TypeBody, X, Index, Context, Clauses) -->
+unify_proc__generate_index_clauses(ModuleInfo, TypeBody,
+ X, Index, Context, Clauses) -->
+ ( { type_body_has_user_defined_equality_pred(ModuleInfo, TypeBody, _) } ->
+ %
+ % For non-canonical types, the generated comparison
+ % predicate either calls a user-specified comparison
+ % predicate or returns an error, and does not call the
+ % type's index predicate, so do not generate an index
+ % predicate for such types.
+ %
+ { error("trying to create index proc for non-canonical type") }
+ ;
(
- { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred, _) },
- ( { MaybeEqPred = yes(_) } ->
- %
- % For non-canonical types, the generated comparison
- % predicate returns an error, and does not call the
- % type's index predicate, so do not generate an index
- % predicate for such types.
- %
- { error("trying to create index proc for non-canonical type") }
- ; { IsEnum = yes } ->
+ { TypeBody = du_type(Ctors, _, IsEnum, _, _) },
+ ( { IsEnum = yes } ->
%
% For enum types, the generated comparison predicate
% performs an integer comparison, and does not call the
@@ -833,27 +880,26 @@
;
{ TypeBody = abstract_type },
{ error("trying to create index proc for abstract type") }
- ).
+ )
+ ).
-:- pred unify_proc__generate_compare_clauses((type)::in, hlds_type_body::in,
- prog_var::in, prog_var::in, prog_var::in, prog_context::in,
- list(clause)::out, unify_proc_info::in, unify_proc_info::out) is det.
+:- pred unify_proc__generate_compare_clauses(module_info::in, (type)::in,
+ hlds_type_body::in, prog_var::in, prog_var::in, prog_var::in,
+ prog_context::in, list(clause)::out,
+ unify_proc_info::in, unify_proc_info::out) is det.
-unify_proc__generate_compare_clauses(Type, TypeBody, Res, H1, H2, Context,
- Clauses) -->
+unify_proc__generate_compare_clauses(ModuleInfo, Type, TypeBody, Res,
+ H1, H2, Context, Clauses) -->
+ (
+ { type_body_has_user_defined_equality_pred(ModuleInfo,
+ TypeBody, UserEqComp) }
+ ->
+ generate_user_defined_compare_clauses(UserEqComp,
+ Res, H1, H2, Context, Clauses)
+ ;
(
- { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred, _) },
- ( { MaybeEqPred = yes(_) } ->
- %
- % just generate code that will call error/1
- %
- { ArgVars = [Res, H1, H2] },
- unify_proc__build_call(
- "builtin_compare_non_canonical_type",
- ArgVars, Context, Goal),
- unify_proc__quantify_clauses_body(ArgVars, Goal,
- Context, Clauses)
- ; { IsEnum = yes } ->
+ { TypeBody = du_type(Ctors, _, IsEnum, _, _) },
+ ( { IsEnum = yes } ->
{ IntType = int_type },
unify_proc__make_fresh_named_var_from_type(IntType,
"Cast_HeadVar", 1, CastVar1),
@@ -889,7 +935,40 @@
;
{ TypeBody = abstract_type },
{ error("trying to create compare proc for abstract type") }
- ).
+ )
+ ).
+
+:- pred generate_user_defined_compare_clauses(unify_compare::in,
+ prog_var::in, prog_var::in, prog_var::in,
+ prog_context::in, list(clause)::out,
+ unify_proc_info::in, unify_proc_info::out) is det.
+
+generate_user_defined_compare_clauses(unify_compare(_, MaybeCompare),
+ Res, H1, H2, Context, Clauses) -->
+ { ArgVars = [Res, H1, H2] },
+ ( { MaybeCompare = yes(ComparePredName) } ->
+ %
+ % Just generate a call to the specified predicate,
+ % which is the user-defined comparison pred for this
+ % type.
+ % (The pred_id and proc_id will be figured
+ % out by type checking and mode analysis.)
+ %
+ { invalid_pred_id(PredId) },
+ { invalid_proc_id(ModeId) },
+ { Call = call(PredId, ModeId, ArgVars, not_builtin,
+ no, ComparePredName) },
+ { goal_info_init(Context, GoalInfo) },
+ { Goal = Call - GoalInfo }
+ ;
+ %
+ % just generate code that will call error/1
+ %
+ unify_proc__build_call(
+ "builtin_compare_non_canonical_type",
+ ArgVars, Context, Goal)
+ ),
+ unify_proc__quantify_clauses_body(ArgVars, Goal, Context, Clauses).
:- pred generate_compare_clauses_eqv_type((type)::in,
prog_var::in, prog_var::in, prog_var::in,
@@ -1220,12 +1299,9 @@
unify_proc__generate_du_linear_compare_clauses_2(Type, Ctors, Res, X, Y,
Context, Goal) -->
{ IntType = int_type },
- { mercury_public_builtin_module(MercuryBuiltin) },
- { construct_type(qualified(MercuryBuiltin, "comparison_result") - 0,
- [], ResType) },
unify_proc__info_new_var(IntType, X_Index),
unify_proc__info_new_var(IntType, Y_Index),
- unify_proc__info_new_var(ResType, R),
+ unify_proc__info_new_var(comparison_result_type, R),
{ goal_info_init(GoalInfo0) },
{ goal_info_set_context(GoalInfo0, Context, GoalInfo) },
@@ -1436,11 +1512,7 @@
( { Xs = [], Ys = [] } ->
unify_proc__build_call(ComparePred, [R, X, Y], Context, Goal)
;
- { mercury_public_builtin_module(MercuryBuiltin) },
- { construct_type(
- qualified(MercuryBuiltin, "comparison_result") - 0,
- [], ResType) },
- unify_proc__info_new_var(ResType, R1),
+ unify_proc__info_new_var(comparison_result_type, R1),
unify_proc__build_call(ComparePred, [R1, X, Y], Context,
Do_Comparison),
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.250
diff -u -u -r1.250 reference_manual.texi
--- doc/reference_manual.texi 30 Jun 2002 17:06:58 -0000 1.250
+++ doc/reference_manual.texi 9 Jul 2002 17:31:48 -0000
@@ -88,8 +88,9 @@
safely use destructive update to modify that value.
* Determinism:: Determinism declarations let you specify that a predicate
should never fail or should never succeed more than once.
-* Equality preds:: User-defined types can have user-defined equality
- predicates.
+* User-defined equality and comparison::
+ User-defined types can have user-defined equality and
+ comparison predicates.
* Higher-order:: Mercury supports higher-order predicates and functions,
with closures, lambda expressions, and currying.
* Modules:: Modules allow you to divide a program into smaller parts.
@@ -99,7 +100,7 @@
* Semantics:: Declarative and operational semantics of Mercury
programs.
* Foreign language interface:: Calling code written in other programming
- languages from Mercury code
+ languages from Mercury code
* C interface:: The C interface allows C code to be called
from Mercury code, and vice versa.
* Impurity:: Users can write impure Mercury code.
@@ -2049,7 +2050,7 @@
@end example
As for type declarations, a predicate or function can be defined
-to have a given higher-order inst (@pxref{Higher-order modes} by using
+to have a given higher-order inst (@pxref{Higher-order modes}) by using
`with_inst` in the mode declaration.
For example,
@@ -2982,7 +2983,8 @@
satisfied, then the behaviour is undefined.
Note that specifying a user-defined equivalence relation
-as the equality predicate for user-defined types (@pxref{Equality preds})
+as the equality predicate for user-defined types
+(@pxref{User-defined equality and comparison})
means that the @samp{promise_only_solution/1} function
can be used to express more general forms of equivalence.
For example, if you define a set type which represents sets as unsorted lists,
@@ -3055,7 +3057,7 @@
Another reason is for doing I/O, which is allowed only in @samp{det}
or @samp{cc_multi} predicates, not in @samp{multi} predicates.
Another is for dealing with types that use non-canonical representations
-(@pxref{Equality preds}).
+(@pxref{User-defined equality and comparison}).
And there are a variety of other applications.
@c XXX fix semantics for I/O + committed choice + mode inference
@@ -3100,8 +3102,8 @@
@c ).
@c @end example
- at node Equality preds
- at chapter User-defined equality predicates
+ at node User-defined equality and comparison
+ at chapter User-defined equality and comparison
When defining abstract data types,
often it is convenient to use a non-canonical representation ---
@@ -3148,29 +3150,67 @@
subset(S2, S1).
@end example
+A comparison predicate can also be supplied.
+
+ at example
+:- type set(T) ---> set(list(T))
+ where equality is set_equals, comparison is set_compare.
+
+:- pred set_compare(comparison_result::uo, set(T)::in, set(T)::in) is det.
+set_compare(promise_only_solution(set_compare_2(Set1, Set2)), Set1, Set2).
+
+:- pred set_compare_2(set(T)::in, set(T)::in,
+ comparison_result::uo) is cc_mulit.
+set_compare_2(set(List1), set(List2), Result) :-
+ compare(Result, list__sort(List1), list__sort(List2)).
+ at end example
+
+If a comparison predicate is supplied and the unification predicate
+is omitted, a unification predicate is generated by the compiler
+in terms of the comparison predicate. For the @samp{set} example,
+the generated predicate would be:
+
+ at example
+set_equals(S1, S2) :-
+ set_compare((=), S1, S2).
+ at end example
+
+If a unification predicate is supplied without a comparison predicate,
+the compiler will generate a comparison predicate which throws an
+exception when called.
+
A type declaration for a type @samp{foo(T1, @dots{}, TN)} may contain a
- at samp{where equality is @var{equalitypred}} specification only
-if the following conditions are satisfied:
+ at samp{where equality is @var{equalitypred}, comparison is @var{comparepred}}
+specification only if the following conditions are satisfied:
@itemize @bullet
@item
-The type @samp{foo(T1, @dots{}, TN)} must be a discriminated union type;
+The type @samp{foo(T1, @dots{}, TN)} must be a discriminated union
+type or a foreign type (@pxref{Using foreign types from Mercury});
it may not be an equivalence type
@item
- at var{equalitypred} must be the name of a predicate which can
-be called with two ground arguments of type @samp{pred(foo(T1, @dots{}, TN))},
-and whose determinism in that mode is @samp{semidet}.
-Typically the equality predicate would have type
- at samp{pred(foo(T1, @dots{}, TN), foo(T1, @dots{}, TN)}
-and mode @samp{(in, in) is semidet}, but it is also legal
-for the type, mode and determinism to be more permissive:
+ at var{equalitypred} must be the name of a predicate with signature
+ at example
+:- pred @var{equalitypred}(foo(T1, @dots{}, TN)::in,
+ foo(T1, @dots{}, TN)::in) is semidet.
+ at end example
+
+ at var{comparepred} must be the name of a predicate with signature
+ at example
+:- pred @var{comparepred}(comparison_result::uo, foo(T1, @dots{}, TN)::in,
+ foo(T1, @dots{}, TN)::in) is det.
+ at end example
+
+It is legal for the type, mode and determinism to be more permissive:
the type or the mode's initial insts may be more general
-(e.g. the type could be just the polymorphic type @samp{pred(T, T)})
-and the mode's final insts or the determinism may be more
-specific (e.g. the determinism could be any of @samp{det},
- at samp{failure} or @samp{erroneous}).
-The equality predicate must also be ``pure'' (@pxref{Impurity}).
+(e.g. the type of the equality predicate could be just the polymorphic
+type @samp{pred(T, T)}) and the mode's final insts or the determinism
+may be more specific (e.g. the determinism of the equality predicate
+could be any of @samp{det}, @samp{failure} or @samp{erroneous}).
+
+The equality and comparison predicates must also be ``pure''
+(@pxref{Impurity}).
@end itemize
@@ -3220,6 +3260,15 @@
implementation may compute any answer at all (@pxref{Semantics}),
i.e. the behaviour of the program is undefined.}.
+ at item
+Any comparisons of type @var{T} are computed using the specified predicate
+ at var{comparepred}.
+
+ at item
+ at var{comparepred} should be a partial order relation: that is
+it must be antisymmetric, reflexive and transitive. The
+compiler is not required to check this.
+
@end itemize
@node Higher-order
@@ -5230,6 +5279,15 @@
type will only be visible in Mercury clauses for predicates or functions with
@samp{pragma foreign_proc} clauses for all of the languages for which there
are @samp{foreign_type} declarations for the type.
+
+As with discriminated union types, programmers can specify the unification
+and comparison predicates to use for values of the type using the following
+syntax (@pxref{User-defined equality and comparison}):
+
+ at example
+:- pragma foreign_type(@var{Lang}, @var{MercuryTypeName}, @var{ForeignTypeDescriptor})
+ where equality is @var{EqualityPred}, comparison is @var{ComparePred}.
+ at end example
You can use Mercury foreign language interfacing declarations
which specify language @var{X} to interface to types that are actually
Index: library/builtin.m
===================================================================
RCS file: /home/mercury1/repository/mercury/library/builtin.m,v
retrieving revision 1.74
diff -u -u -r1.74 builtin.m
--- library/builtin.m 14 Jun 2002 10:18:46 -0000 1.74
+++ library/builtin.m 9 Jul 2002 17:32:51 -0000
@@ -154,7 +154,9 @@
:- func promise_only_solution(pred(T)) = T.
:- mode promise_only_solution(pred(out) is cc_multi) = out is det.
+:- mode promise_only_solution(pred(uo) is cc_multi) = uo is det.
:- mode promise_only_solution(pred(out) is cc_nondet) = out is semidet.
+:- mode promise_only_solution(pred(uo) is cc_nondet) = uo is semidet.
% `promise_only_solution_io' is like `promise_only_solution', but
% for procedures with unique modes (e.g. those that do IO).
@@ -191,6 +193,9 @@
% unify(X, Y) is true iff X = Y.
:- pred unify(T::in, T::in) is semidet.
+:- type unify(T) == pred(T, T).
+:- inst unify == (pred(in, in) is semidet).
+
:- type comparison_result ---> (=) ; (<) ; (>).
% compare(Res, X, Y) binds Res to =, <, or >
@@ -204,6 +209,9 @@
:- mode compare(uo, ui, in) is det.
:- mode compare(uo, in, ui) is det.
+:- type compare(T) == pred(comparison_result, T, T).
+:- inst compare == (pred(uo, in, in) is det).
+
% In addition, the following predicate-like constructs are builtin:
%
% :- pred (T = T).
@@ -256,9 +264,19 @@
%-----------------------------------------------------------------------------%
+% XXX The calls to unsafe_promise_unique below work around
+% mode checker limitations.
:- pragma promise_pure(promise_only_solution/1).
-promise_only_solution(CCPred) = OutVal :-
+promise_only_solution(CCPred::(pred(out) is cc_multi)) = (OutVal::out) :-
+ impure OutVal = get_one_solution(CCPred).
+promise_only_solution(CCPred::(pred(uo) is cc_multi)) = (OutVal::uo) :-
+ impure OutVal0 = get_one_solution(CCPred),
+ OutVal = unsafe_promise_unique(OutVal0).
+promise_only_solution(CCPred::(pred(out) is cc_nondet)) = (OutVal::out) :-
impure OutVal = get_one_solution(CCPred).
+promise_only_solution(CCPred::(pred(uo) is cc_nondet)) = (OutVal::uo) :-
+ impure OutVal0 = get_one_solution(CCPred),
+ OutVal = unsafe_promise_unique(OutVal0).
get_one_solution(CCPred) = OutVal :-
impure Pred = cc_cast(CCPred),
Index: tests/hard_coded/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/hard_coded/Mmakefile,v
retrieving revision 1.157
diff -u -u -r1.157 Mmakefile
--- tests/hard_coded/Mmakefile 30 Jun 2002 17:07:15 -0000 1.157
+++ tests/hard_coded/Mmakefile 8 Jul 2002 16:51:32 -0000
@@ -147,6 +147,7 @@
unify_expression \
unify_typeinfo_bug \
unused_float_box_test \
+ user_compare \
user_defined_equality2 \
write \
write_reg1 \
Index: tests/hard_coded/user_compare.exp
===================================================================
RCS file: tests/hard_coded/user_compare.exp
diff -N tests/hard_coded/user_compare.exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/user_compare.exp 8 Jul 2002 16:54:25 -0000
@@ -0,0 +1,5 @@
+'>'
+succeeded
+succeeded
+succeeded
+'<'
Index: tests/hard_coded/user_compare.m
===================================================================
RCS file: tests/hard_coded/user_compare.m
diff -N tests/hard_coded/user_compare.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/hard_coded/user_compare.m 8 Jul 2002 16:53:52 -0000
@@ -0,0 +1,80 @@
+:- module user_compare.
+
+:- interface.
+
+:- import_module io.
+
+:- pred main(io__state::di, io__state::uo) is det.
+
+:- implementation.
+
+:- import_module int.
+
+main -->
+ { compare(Result, foo(1), foo(2)) },
+ io__write(Result),
+ io__nl,
+ ( { unify(foo(1), foo(1)) } ->
+ io__write_string("succeeded\n")
+ ;
+ io__write_string("failed\n")
+ ),
+ ( { foreign(1) = foreign(1) } ->
+ io__write_string("succeeded\n")
+ ;
+ io__write_string("failed\n")
+ ),
+ ( { foreign(2) = foreign(3) } ->
+ io__write_string("failed\n")
+ ;
+ io__write_string("succeeded\n")
+ ),
+ { compare(Result2, foreign(3), foreign(2)) },
+ io__write(Result2),
+ io__nl.
+
+:- type foo
+ ---> foo(int)
+ where comparison is compare_foo.
+
+ % Reverse the comparison of the integers.
+:- pred compare_foo(comparison_result::uo, foo::in, foo::in) is det.
+
+compare_foo(Res, Foo1, Foo2) :-
+ Res1 = promise_only_solution(
+ (pred(Res0::uo) is cc_multi :-
+ Foo1 = foo(Int1),
+ Foo2 = foo(Int2),
+ compare(Res0, Int2, Int1)
+ )
+ ),
+ Res = Res1.
+
+:- type foreign.
+:- pragma foreign_type(c, foreign, "int") where
+ equality is foreign_equals, comparison is foreign_compare.
+
+:- pred foreign_equals(foreign::in, foreign::in) is semidet.
+:- pragma foreign_proc(c, foreign_equals(Foreign1::in, Foreign2::in),
+ [will_not_call_mercury, promise_pure],
+"SUCCESS_INDICATOR = (Foreign1 == Foreign2);"
+).
+
+:- pred foreign_compare `with_type` compare(foreign) `with_inst` compare.
+foreign_compare(Result, Foreign1, Foreign2) :-
+ foreign_compare_2(Result0, Foreign1, Foreign2),
+ Result = ( Result0 < 0 -> (<) ; Result0 = 0 -> (=) ; (>) ).
+
+ % Reverse the comparison of the integers.
+:- pred foreign_compare_2(int::out, foreign::in, foreign::in) is det.
+:- pragma foreign_proc(c, foreign_compare_2(Result::out, Foreign1::in,
+ Foreign2::in),
+ [will_not_call_mercury, promise_pure],
+"Result = (Foreign1 < Foreign2 ? 1 : (Foreign1 == Foreign2 ? 0 : -1));"
+).
+
+:- func foreign(int) = foreign.
+:- pragma foreign_proc(c, foreign(Int::in) = (Foreign::out),
+ [will_not_call_mercury, promise_pure],
+"Foreign = Int;"
+).
Index: tests/invalid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/Mmakefile,v
retrieving revision 1.114
diff -u -u -r1.114 Mmakefile
--- tests/invalid/Mmakefile 30 Jun 2002 17:07:19 -0000 1.114
+++ tests/invalid/Mmakefile 9 Jul 2002 08:25:25 -0000
@@ -117,6 +117,7 @@
typeclass_test_5.m \
typeclass_test_7.m \
typeclass_test_9.m \
+ typeclass_test_10.m \
types.m \
type_spec.m \
unbound_type_vars.m \
Index: tests/invalid/typeclass_test_10.err_exp
===================================================================
RCS file: tests/invalid/typeclass_test_10.err_exp
diff -N tests/invalid/typeclass_test_10.err_exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/typeclass_test_10.err_exp 9 Jul 2002 08:28:18 -0000
@@ -0,0 +1,11 @@
+typeclass_test_10.m:001: In module `typeclass_test_10':
+typeclass_test_10.m:001: warning: module `std_util'
+typeclass_test_10.m:001: is imported in the interface, but is not
+typeclass_test_10.m:001: used in the interface.
+typeclass_test_10.m:006: In instance declaration for `typeclass_test_10:bar/1':
+typeclass_test_10.m:006: incorrect method name(s): predicate
+typeclass_test_10.m:006: `typeclass_test_10:p/0' .
+typeclass_test_10.m:011: In instance declaration for `typeclass_test_10:baz/1':
+typeclass_test_10.m:011: incorrect method name(s): predicate
+typeclass_test_10.m:011: `typeclass_test_10:r/0' .
+For more information, try recompiling with `-E'.
Index: tests/invalid/typeclass_test_10.m
===================================================================
RCS file: tests/invalid/typeclass_test_10.m
diff -N tests/invalid/typeclass_test_10.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/typeclass_test_10.m 9 Jul 2002 08:27:58 -0000
@@ -0,0 +1,12 @@
+:- module typeclass_test_10.
+:- interface.
+:- import_module std_util.
+:- typeclass bar(T) where [].
+:- typeclass baz(T) where [pred q(T::in) is semidet].
+:- instance bar(int) where [
+ pred(p/0) is semidet_fail
+].
+:- instance baz(int) where [
+ pred(r/0) is semidet_fail,
+ q(_) :- semidet_fail
+].
Index: tests/invalid/typeclass_test_9.err_exp
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/typeclass_test_9.err_exp,v
retrieving revision 1.3
diff -u -u -r1.3 typeclass_test_9.err_exp
--- tests/invalid/typeclass_test_9.err_exp 20 Sep 2000 11:59:46 -0000 1.3
+++ tests/invalid/typeclass_test_9.err_exp 9 Jul 2002 08:29:39 -0000
@@ -13,10 +13,4 @@
typeclass_test_9.m:010: Error: multiply defined (or overlapping) instance
typeclass_test_9.m:010: declarations for class `typeclass_test_9:foo/1'.
typeclass_test_9.m:007: Previous instance declaration was here.
-typeclass_test_9.m:013: In instance declaration for `typeclass_test_9:bar/1':
-typeclass_test_9.m:013: incorrect method name(s): predicate
-typeclass_test_9.m:013: `typeclass_test_9:p/0' .
-typeclass_test_9.m:018: In instance declaration for `typeclass_test_9:baz/1':
-typeclass_test_9.m:018: incorrect method name(s): predicate
-typeclass_test_9.m:018: `typeclass_test_9:r/0' .
For more information, try recompiling with `-E'.
--------------------------------------------------------------------------
mercury-reviews mailing list
post: mercury-reviews at cs.mu.oz.au
administrative address: owner-mercury-reviews at cs.mu.oz.au
unsubscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: unsubscribe
subscribe: Address: mercury-reviews-request at cs.mu.oz.au Message: subscribe
--------------------------------------------------------------------------
More information about the reviews
mailing list