[m-rev.] for review: pragma reserve_tag
Fergus Henderson
fjh at cs.mu.OZ.AU
Sat Jan 11 03:08:54 AEDT 2003
Estimated hours taken: 6
Branches: main
Implement `:- pragma reserve_tag(<TypeName>/<Arity>).'.
This has the same effect as the `--reserve-tag' option,
except that it only applies to specified type, rather than
to all types.
doc/reference_manual.texi:
Document the new feature.
(However, the documentation is currently commented out.)
compiler/prog_data.m:
Add `reserve_tag(sym_name, arity)' to the `pragma_type' type.
compiler/hlds_data.m:
Add a new boolean field to the representation of discriminated union
type bodies to record whether or not the type has a reserved tag.
compiler/prog_io_pragma.m:
Add code to parse the new pragma.
compiler/make_hlds.m:
Add code to process the new pragma:
- check all the appropriate semantic restrictions:
- the pragma must have the same visibility as the type
- the type must be defined
- the type must be a discriminated union type
- warn if there are multiple such pragmas for the same type
- call make_tags.m to recompute the tags used for the constructor.
- record the presence of the reserve_tag pragma in the HLDS type
definition body
compiler/make_tags.m:
compiler/type_util.m:
Add an extra argument to assign_constructor_tags (in make_tags.m)
and type_constructors_should_be_no_tag (in type_util.m)
to specify whether or not there was a `reserve_tag' pragma.
Reserve a tag if either this argument or the global `reserve_tag'
option is set.
compiler/intermod.m:
Output a `:- reserve_tag' pragma whenever outputting a type
to which such a pragma applies.
compiler/ml_type_gen.m:
compiler/ml_unify_gen.m:
Ignore the reserved_tag field.
XXX This means that the `reserve_tag' pragma (or the compiler
option) won't have much effect if --high-level-data is set.
compiler/code_util.m:
compiler/det_report.m:
compiler/hlds_out.m:
compiler/magic_util.m:
compiler/mercury_to_mercury.m:
compiler/mode_util.m:
compiler/module_qual.m:
compiler/modules.m:
compiler/post_typecheck.m:
compiler/recompilation.usage.m:
compiler/recompilation.version.m:
compiler/special_pred.m:
compiler/stack_opt.m:
compiler/switch_util.m:
compiler/table_gen.m:
compiler/term_util.m:
compiler/type_ctor_info.m:
compiler/unify_gen.m:
compiler/unify_proc.m:
Trivial changes to handle the new reserved_tag field of
hlds_type_defn_body.
tests/valid/Mmakefile:
tests/valid/reserve_tag.m:
tests/invalid/Mmakefile:
tests/invalid/reserve_tag.m:
tests/invalid/reserve_tag.err_exp:
Some tests of the new feature.
Workspace: /home/ceres/fjh/mercury
Index: compiler/code_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/code_util.m,v
retrieving revision 1.139
diff -u -d -r1.139 code_util.m
--- compiler/code_util.m 1 Nov 2002 09:56:53 -0000 1.139
+++ compiler/code_util.m 10 Jan 2003 12:20:33 -0000
@@ -735,7 +735,7 @@
map__lookup(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
(
- TypeBody = du_type(_, ConsTable0, _, _, _)
+ TypeBody = du_type(_, ConsTable0, _, _, _, _)
->
ConsTable = ConsTable0
;
Index: compiler/det_report.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/det_report.m,v
retrieving revision 1.74
diff -u -d -r1.74 det_report.m
--- compiler/det_report.m 26 Jul 2002 04:18:11 -0000 1.74
+++ compiler/det_report.m 10 Jan 2003 12:20:39 -0000
@@ -564,7 +564,7 @@
{ det_lookup_var_type(ModuleInfo, ProcInfo, Var,
TypeDefn) },
{ hlds_data__get_type_defn_body(TypeDefn, TypeBody) },
- { TypeBody = du_type(_, ConsTable, _, _, _) }
+ { TypeBody = du_type(_, ConsTable, _, _, _, _) }
->
{ map__keys(ConsTable, ConsIds) },
{ det_diagnose_missing_consids(ConsIds, Cases,
Index: compiler/hlds_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_data.m,v
retrieving revision 1.71
diff -u -d -r1.71 hlds_data.m
--- compiler/hlds_data.m 26 Jul 2002 06:33:01 -0000 1.71
+++ compiler/hlds_data.m 10 Jan 2003 12:02:21 -0000
@@ -299,14 +299,22 @@
---> du_type(
% the ctors for this type
du_type_ctors :: list(constructor),
+
% their tag values
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),
+
+ % is there a `:- pragma reserve_tag'
+ % pragma for this type?
+ du_type_reserved_tag :: bool,
+
% are there `:- pragma foreign' type
- % declarations for this type.
+ % declarations for this type?
du_type_is_foreign_type :: maybe(foreign_type_body)
)
; eqv_type(type)
Index: compiler/hlds_out.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/hlds_out.m,v
retrieving revision 1.290
diff -u -d -r1.290 hlds_out.m
--- compiler/hlds_out.m 24 Oct 2002 04:36:41 -0000 1.290
+++ compiler/hlds_out.m 10 Jan 2003 12:21:49 -0000
@@ -2887,11 +2887,17 @@
:- mode hlds_out__write_type_body(in, in, in, di, uo) is det.
hlds_out__write_type_body(Indent, Tvarset, du_type(Ctors, Tags, Enum,
- MaybeEqualityPred, Foreign)) -->
+ MaybeEqualityPred, ReservedTag, Foreign)) -->
io__write_string(" --->\n"),
( { Enum = yes } ->
hlds_out__write_indent(Indent),
io__write_string("/* enumeration */\n")
+ ;
+ []
+ ),
+ ( { ReservedTag = yes } ->
+ hlds_out__write_indent(Indent),
+ io__write_string("/* reserved_tag */\n")
;
[]
),
Index: compiler/intermod.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/intermod.m,v
retrieving revision 1.125
diff -u -d -r1.125 intermod.m
--- compiler/intermod.m 7 Aug 2002 13:11:50 -0000 1.125
+++ compiler/intermod.m 10 Jan 2003 13:31:57 -0000
@@ -13,7 +13,9 @@
% - The clauses for exported preds that have higher-order pred arguments.
% - The pred/mode declarations for local predicates that the
% above clauses use.
-% - Non-exported types, insts and modes used by the above.
+% - Non-exported types, insts and modes used by the above
+% - Pragma reserve_tag or foreign_type declarations for any types
+% output due to the line above
% - :- import_module declarations to import stuff used by the above.
% - pragma declarations for the exported preds.
% - pragma foreign_header declarations if any pragma_foreign_code
@@ -999,7 +1001,8 @@
->
(
hlds_data__get_type_defn_body(TypeDefn0, TypeBody0),
- TypeBody0 = du_type(Ctors, Tags, Enum, MaybeUserEq0, Foreign),
+ TypeBody0 = du_type(Ctors, Tags, Enum, MaybeUserEq0,
+ ReservedTag, Foreign),
MaybeUserEq0 = yes(UserEq0)
->
module_info_get_special_pred_map(ModuleInfo, SpecialPreds),
@@ -1008,7 +1011,8 @@
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),
+ TypeBody = du_type(Ctors, Tags, Enum, yes(UserEq),
+ ReservedTag, Foreign),
hlds_data__set_type_defn_body(TypeDefn0, TypeBody, TypeDefn),
intermod__add_proc(UserEqPredId, _, Info1, Info2)
;
@@ -1178,9 +1182,9 @@
{ hlds_data__get_type_defn_tparams(TypeDefn, Args) },
{ hlds_data__get_type_defn_body(TypeDefn, Body) },
{ hlds_data__get_type_defn_context(TypeDefn, Context) },
- { TypeCtor = Name - _Arity },
+ { TypeCtor = Name - Arity },
(
- { Body = du_type(Ctors, _, _, MaybeEqualityPred, _) },
+ { Body = du_type(Ctors, _, _, MaybeEqualityPred, _, _) },
{ TypeBody = du_type(Ctors, MaybeEqualityPred) }
;
{ Body = eqv_type(EqvType) },
@@ -1197,7 +1201,7 @@
(
{ Body = foreign_type(ForeignTypeBody)
- ; Body = du_type(_, _, _, _, yes(ForeignTypeBody))
+ ; Body = du_type(_, _, _, _, _, yes(ForeignTypeBody))
},
{ ForeignTypeBody = foreign_type_body(MaybeIL, MaybeC) }
->
@@ -1217,6 +1221,15 @@
; { MaybeC = no },
[]
)
+ ;
+ []
+ ),
+ (
+ { Body = du_type(_, _, _, _, ReservedTag, _) },
+ { ReservedTag = yes }
+ ->
+ mercury_output_item(pragma(reserve_tag(Name, Arity)),
+ Context)
;
[]
).
Index: compiler/magic_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/magic_util.m,v
retrieving revision 1.23
diff -u -d -r1.23 magic_util.m
--- compiler/magic_util.m 22 Jul 2002 06:29:36 -0000 1.23
+++ compiler/magic_util.m 10 Jan 2003 12:28:35 -0000
@@ -1374,7 +1374,7 @@
set(argument_error)::in, set(argument_error)::out,
magic_info::in, magic_info::out) is det.
-magic_util__check_type_defn(du_type(Ctors, _, _, _, _),
+magic_util__check_type_defn(du_type(Ctors, _, _, _, _, _),
Parents, Errors0, Errors) -->
list__foldl2(magic_util__check_ctor(Parents), Ctors, Errors0, Errors).
magic_util__check_type_defn(eqv_type(_), _, _, _) -->
Index: compiler/make_hlds.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_hlds.m,v
retrieving revision 1.428
diff -u -d -r1.428 make_hlds.m
--- compiler/make_hlds.m 10 Dec 2002 11:35:06 -0000 1.428
+++ compiler/make_hlds.m 10 Jan 2003 15:19:54 -0000
@@ -487,10 +487,16 @@
{ Module = Module0 }
;
% Handle pragma fact_table decls later on (when we process
- % clauses).
+ % clauses -- since these decls take the place of clauses).
{ Pragma = fact_table(_, _, _) },
{ Module = Module0 }
;
+ % Handle pragma reserve_tag decls later on (when we process
+ % clauses -- they need to be handled after the type definitions
+ % have been added).
+ { Pragma = reserve_tag(_, _) },
+ { Module = Module0 }
+ ;
{ Pragma = aditi(PredName, Arity) },
maybe_enable_aditi_compilation(Status, Context,
Module0, Module1),
@@ -803,6 +809,12 @@
Context, Module0, Module),
{ Info = Info0 }
;
+ { Pragma = reserve_tag(TypeName, TypeArity) }
+ ->
+ add_pragma_reserve_tag(TypeName, TypeArity, Status,
+ 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,
@@ -990,6 +1002,115 @@
%-----------------------------------------------------------------------------%
+:- pred add_pragma_reserve_tag(sym_name, arity, import_status, prog_context,
+ module_info, module_info, io__state, io__state).
+:- mode add_pragma_reserve_tag(in, in, in, in, in, out, di, uo) is det.
+
+add_pragma_reserve_tag(TypeName, TypeArity, PragmaStatus, Context,
+ Module0, Module) -->
+ { TypeCtor = TypeName - TypeArity },
+ { module_info_types(Module0, Types0) },
+ { TypeStr = error_util__describe_sym_name_and_arity(
+ TypeName / TypeArity) },
+ { ErrorPieces1 = [
+ words("In"),
+ fixed("`pragma reserve_tag'"),
+ words("declaration for"),
+ fixed(TypeStr ++ ":")
+ ] },
+ (
+ { map__search(Types0, TypeCtor, TypeDefn0) }
+ ->
+ { hlds_data__get_type_defn_body(TypeDefn0, TypeBody0) },
+ { hlds_data__get_type_defn_status(TypeDefn0, TypeStatus) },
+ (
+ not {
+ TypeStatus = PragmaStatus
+ ;
+ TypeStatus = abstract_exported,
+ ( PragmaStatus = local
+ ; PragmaStatus = exported_to_submodules
+ )
+ }
+ ->
+ error_util__write_error_pieces(Context, 0,
+ ErrorPieces1),
+ { ErrorPieces2 = [
+ words("error: `reserve_tag' declaration must"),
+ words("have the same visibility as the"),
+ words("type definition.")
+ ] },
+ error_util__write_error_pieces_not_first_line(Context,
+ 0, ErrorPieces2),
+ io__set_exit_status(1),
+ { module_info_incr_errors(Module0, Module) }
+
+ ;
+ { TypeBody0 = du_type(Body, _CtorTags0, _IsEnum0,
+ EqualityPred, ReservedTag0, IsForeign) }
+ ->
+ (
+ { ReservedTag0 = yes },
+ % make doubly sure that we don't get any
+ % spurious warnings with intermodule
+ % optimization...
+ { TypeStatus \= opt_imported }
+ ->
+ error_util__write_error_pieces(Context, 0,
+ ErrorPieces1),
+ { ErrorPieces2 = [
+ words("warning: multiple"),
+ fixed("`pragma reserved_tag'"),
+ words("declarations for the same type.")
+ ] },
+ error_util__write_error_pieces_not_first_line(
+ Context, 0, ErrorPieces2)
+ ;
+ []
+ ),
+ %
+ % We passed all the semantic checks.
+ % Mark the type has having a reserved tag,
+ % and recompute the constructor tags.
+ %
+ { ReservedTag = yes },
+ { module_info_globals(Module0, Globals) },
+ { assign_constructor_tags(Body, TypeCtor, ReservedTag,
+ Globals, CtorTags, IsEnum) },
+ { TypeBody = du_type(Body, CtorTags, IsEnum,
+ EqualityPred, ReservedTag, IsForeign) },
+ { hlds_data__set_type_defn_body(TypeDefn0, TypeBody,
+ TypeDefn) },
+ { map__set(Types0, TypeCtor, TypeDefn, Types) },
+ { module_info_set_types(Module0, Types, Module) }
+ ;
+ error_util__write_error_pieces(Context, 0,
+ ErrorPieces1),
+ { ErrorPieces2 = [
+ words("error:"),
+ fixed(TypeStr),
+ words("is not a discriminated union type.")
+ ] },
+ error_util__write_error_pieces_not_first_line(Context,
+ 0, ErrorPieces2),
+ io__set_exit_status(1),
+ { module_info_incr_errors(Module0, Module) }
+ )
+ ;
+ error_util__write_error_pieces(Context, 0,
+ ErrorPieces1),
+ { ErrorPieces2 = [
+ words("error: undefined type"),
+ fixed(TypeStr ++ ".")
+ ] },
+ error_util__write_error_pieces_not_first_line(Context,
+ 0, ErrorPieces2),
+ io__set_exit_status(1),
+ { module_info_incr_errors(Module0, Module) }
+ ).
+
+%-----------------------------------------------------------------------------%
+
:- pred add_pragma_unused_args(pred_or_func, sym_name, arity, mode_num,
list(int), prog_context, module_info, module_info,
io__state, io__state).
@@ -2201,7 +2322,7 @@
{ hlds_data__get_type_defn_status(TypeDefn, Status) },
{ hlds_data__get_type_defn_need_qualifier(TypeDefn, NeedQual) },
(
- { Body = du_type(ConsList, _, _, _, _) }
+ { Body = du_type(ConsList, _, _, _, ReservedTag, _) }
->
{ module_info_ctors(Module0, Ctors0) },
{ module_info_get_partial_qualifier_info(Module0, PQInfo) },
@@ -2215,7 +2336,7 @@
globals__io_get_globals(Globals),
{
type_constructors_should_be_no_tag(ConsList,
- Globals, Name, CtorArgType, _)
+ ReservedTag, Globals, Name, CtorArgType, _)
->
NoTagType = no_tag_type(Args, Name, CtorArgType),
module_info_no_tag_types(Module2, NoTagTypes0),
@@ -2347,7 +2468,7 @@
% output in the .opt file.
merge_foreign_type_bodies(Target, MakeOptInterface,
foreign_type(ForeignTypeBody0),
- Body1 @ du_type(_, _, _, _, MaybeForeignTypeBody1), Body) :-
+ Body1 @ du_type(_, _, _, _, _, MaybeForeignTypeBody1), Body) :-
( MaybeForeignTypeBody1 = yes(ForeignTypeBody1)
; MaybeForeignTypeBody1 = no,
ForeignTypeBody1 = foreign_type_body(no, no)
@@ -2363,7 +2484,7 @@
Body = Body1 ^ du_type_is_foreign_type := yes(ForeignTypeBody)
).
merge_foreign_type_bodies(Target, MakeOptInterface,
- Body0 @ du_type(_, _, _, _, _),
+ Body0 @ du_type(_, _, _, _, _, _),
Body1 @ foreign_type(_), Body) :-
merge_foreign_type_bodies(Target, MakeOptInterface, Body1, Body0, Body).
merge_foreign_type_bodies(_, _, foreign_type(Body0), foreign_type(Body1),
@@ -2473,9 +2594,18 @@
:- mode convert_type_defn(in, in, in, out) is det.
convert_type_defn(du_type(Body, EqualityPred), TypeCtor, Globals,
- du_type(Body, CtorTags, IsEnum, EqualityPred, IsForeign)) :-
- IsForeign = no,
- assign_constructor_tags(Body, TypeCtor, Globals, CtorTags, IsEnum).
+ du_type(Body, CtorTags, IsEnum, EqualityPred,
+ ReservedTagPragma, IsForeign)) :-
+ % Initially, when we first see the `:- type' definition,
+ % we assign the constructor tags assuming that there is no
+ % `:- pragma reserve_tag' declaration for this type.
+ % (If it turns out that there was one, then we will recompute the
+ % constructor tags by callling assign_constructor_tags again,
+ % with ReservedTagPragma = yes, when processing the pragma.)
+ ReservedTagPragma = no,
+ assign_constructor_tags(Body, TypeCtor, ReservedTagPragma, Globals,
+ CtorTags, IsEnum),
+ IsForeign = no.
convert_type_defn(eqv_type(Body), _, _, eqv_type(Body)).
convert_type_defn(abstract_type, _, _, abstract_type).
@@ -3485,7 +3615,7 @@
status_defined_in_this_module(Status, yes)
->
(
- Body = du_type(Ctors, _, IsEnum,
+ Body = du_type(Ctors, _, IsEnum, _,
UserDefinedEquality, _),
IsEnum = no,
UserDefinedEquality = no,
@@ -3561,7 +3691,7 @@
Module = Module0
;
SpecialPredId = compare,
- ( TypeBody = du_type(_, _, _, yes(_), _) ->
+ ( TypeBody = du_type(_, _, _, yes(_), _, _) ->
% The compiler generated comparison
% procedure prints an error message,
% since comparisons of types with
@@ -3604,7 +3734,7 @@
->
pred_info_set_import_status(PredInfo0, Status, PredInfo1)
;
- TypeBody = du_type(_, _, _, yes(_), _),
+ TypeBody = du_type(_, _, _, yes(_), _, _),
pred_info_import_status(PredInfo0, OldStatus),
OldStatus = pseudo_imported,
status_is_imported(Status, no)
@@ -3704,7 +3834,7 @@
import_status::out) is det.
add_special_pred_unify_status(TypeBody, Status0, Status) :-
- ( TypeBody = du_type(_, _, _, yes(_), _) ->
+ ( TypeBody = du_type(_, _, _, yes(_), _, _) ->
% If the type has user-defined equality,
% then we create a real __Unify__ predicate
% for it, whose body calls the user-specified
Index: compiler/make_tags.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/make_tags.m,v
retrieving revision 1.37
diff -u -d -r1.37 make_tags.m
--- compiler/make_tags.m 20 Mar 2002 12:36:40 -0000 1.37
+++ compiler/make_tags.m 10 Jan 2003 15:12:17 -0000
@@ -45,6 +45,13 @@
% constants are distinguished by a secondary tag, if there are more
% than one of them.
+ % If there is a `pragma reserve_tag' declaration for the type,
+ % or if the `--reserve-tag' option is set,
+ % then we reserve the first primary tag (for representing
+ % unbound variables). This is used by HAL, for Herbrand constraints
+ % (i.e. Prolog-style logic variables).
+ % This also disables enumerations and no_tag types.
+
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -54,15 +61,16 @@
:- import_module parse_tree__prog_data, hlds__hlds_data, libs__globals.
:- import_module bool, list.
-% assign_constructor_tags(Constructors, TypeCtor, Globals, TagValues, IsEnum):
+% assign_constructor_tags(Constructors, TypeCtor, ReservedTagPragma, Globals,
+% TagValues, IsEnum):
% Assign a constructor tag to each constructor for a discriminated
% union type, and determine whether the type is an enumeration
% type or not. (`Globals' is passed because exact way in which
% this is done is dependent on a compilation option.)
-:- pred assign_constructor_tags(list(constructor), type_ctor, globals,
+:- pred assign_constructor_tags(list(constructor), type_ctor, bool, globals,
cons_tag_values, bool).
-:- mode assign_constructor_tags(in, in, in, out, out) is det.
+:- mode assign_constructor_tags(in, in, in, in, out, out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -75,7 +83,8 @@
%-----------------------------------------------------------------------------%
-assign_constructor_tags(Ctors, TypeCtor, Globals, CtorTags, IsEnum) :-
+assign_constructor_tags(Ctors, TypeCtor, ReservedTagPragma, Globals,
+ CtorTags, IsEnum) :-
% work out how many tag bits and reserved addresses
% we've got to play with
@@ -88,8 +97,9 @@
% determine if we need to reserve a tag for use by HAL's
% Herbrand constraint solver
- % (this also disables enumerations and no_tag types)
- globals__lookup_bool_option(Globals, reserve_tag, ReserveTag),
+ % (This also disables enumerations and no_tag types.)
+ globals__lookup_bool_option(Globals, reserve_tag, GlobalReserveTag),
+ ReserveTag = GlobalReserveTag `or` ReservedTagPragma,
% We do not bother reserving a tag for type_infos --- these
% types are implemented in C, and there is no way (at present)
@@ -117,7 +127,8 @@
IsEnum = no,
(
% Try representing it as a no-tag type
- type_constructors_should_be_no_tag(Ctors, Globals,
+ type_constructors_should_be_no_tag(Ctors,
+ ReserveTag, Globals,
SingleFunc, SingleArg, _)
->
make_cons_id_from_qualified_sym_name(SingleFunc,
Index: compiler/mercury_to_mercury.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mercury_to_mercury.m,v
retrieving revision 1.221
diff -u -d -r1.221 mercury_to_mercury.m
--- compiler/mercury_to_mercury.m 10 Jan 2003 10:36:27 -0000 1.221
+++ compiler/mercury_to_mercury.m 10 Jan 2003 13:10:21 -0000
@@ -596,6 +596,14 @@
{ Pragma = fact_table(Pred, Arity, FileName) },
mercury_format_pragma_fact_table(Pred, Arity, FileName)
;
+ { Pragma = reserve_tag(TypeName, TypeArity) },
+ add_string(":- pragma reserve_tag("),
+ mercury_format_bracketed_sym_name(TypeName,
+ next_to_graphic_token),
+ add_string("/"),
+ add_int(TypeArity),
+ add_string(").\n")
+ ;
{ Pragma = aditi(Pred, Arity) },
mercury_output_pragma_decl(Pred, Arity, predicate, "aditi")
;
Index: compiler/ml_type_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_type_gen.m,v
retrieving revision 1.29
diff -u -d -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 10 Jan 2003 14:06:17 -0000
@@ -122,8 +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, _),
- ModuleInfo, TypeCtor, TypeDefn) -->
+ml_gen_type_2(du_type(Ctors, TagValues, IsEnum, MaybeEqualityPred,
+ _ReservedTag, _), ModuleInfo, TypeCtor, TypeDefn) -->
+ % XXX we probably shouldn't ignore _ReservedTag
{ ml_gen_equality_members(MaybeEqualityPred, MaybeEqualityMembers) },
( { IsEnum = yes } ->
ml_gen_enum_type(TypeCtor, TypeDefn, Ctors, TagValues,
Index: compiler/ml_unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/ml_unify_gen.m,v
retrieving revision 1.59
diff -u -d -r1.59 ml_unify_gen.m
--- compiler/ml_unify_gen.m 12 Sep 2002 13:18:27 -0000 1.59
+++ compiler/ml_unify_gen.m 10 Jan 2003 12:33:05 -0000
@@ -1887,7 +1887,8 @@
module_info_types(ModuleInfo, TypeTable),
TypeDefn = map__lookup(TypeTable, TypeCtor),
hlds_data__get_type_defn_body(TypeDefn, TypeDefnBody),
- ( TypeDefnBody = du_type(Ctors, TagValues, _, _, _) ->
+ ( TypeDefnBody = du_type(Ctors, TagValues, _, _, _ReservedTag, _) ->
+ % XXX we probably shouldn't ignore ReservedTag here
(
(some [Ctor] (
list__member(Ctor, Ctors),
Index: compiler/mode_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/mode_util.m,v
retrieving revision 1.146
diff -u -d -r1.146 mode_util.m
--- compiler/mode_util.m 12 Aug 2002 02:37:12 -0000 1.146
+++ compiler/mode_util.m 10 Jan 2003 12:33:12 -0000
@@ -896,7 +896,7 @@
map__search(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_tparams(TypeDefn, TypeParams0),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
- TypeBody = du_type(Constructors, _, _, _, _)
+ TypeBody = du_type(Constructors, _, _, _, _, _)
->
term__term_list_to_var_list(TypeParams0, TypeParams),
map__from_corresponding_lists(TypeParams, TypeArgs, ArgSubst),
Index: compiler/module_qual.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/module_qual.m,v
retrieving revision 1.81
diff -u -d -r1.81 module_qual.m
--- compiler/module_qual.m 9 Jul 2002 01:29:32 -0000 1.81
+++ compiler/module_qual.m 10 Jan 2003 11:20:10 -0000
@@ -930,6 +930,7 @@
),
qualify_type_spec_subst(Subst0, Subst, Info1, Info).
qualify_pragma(X at fact_table(_, _, _), X, Info, Info) --> [].
+qualify_pragma(X at reserve_tag(_, _), X, Info, Info) --> [].
qualify_pragma(X at aditi(_, _), X, Info, Info) --> [].
qualify_pragma(X at base_relation(_, _), X, Info, Info) --> [].
qualify_pragma(X at aditi_index(_, _, _), X, Info, Info) --> [].
Index: compiler/modules.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/modules.m,v
retrieving revision 1.258
diff -u -d -r1.258 modules.m
--- compiler/modules.m 2 Jan 2003 06:53:55 -0000 1.258
+++ compiler/modules.m 10 Jan 2003 13:11:08 -0000
@@ -1474,9 +1474,9 @@
).
% pragma `obsolete', `terminates', `does_not_terminate'
-% `termination_info', `check_termination', `aditi', `base_relation'
-% and `owner' pragma declarations are supposed to go in the interface,
-% but all other pragma declarations are implementation
+% `termination_info', `check_termination', `aditi', `base_relation',
+% `owner', and `reserve_tag' pragma declarations are supposed to go
+% in the interface, but all other pragma declarations are implementation
% details only, and should go in the implementation.
% XXX we should allow c_header_code;
@@ -1497,6 +1497,9 @@
% yes, but the parser will strip out `source_file' pragmas anyway...
pragma_allowed_in_interface(fact_table(_, _, _), no).
pragma_allowed_in_interface(tabled(_, _, _, _, _), no).
+ % `reserve_tag' must be in the interface iff the corresponding
+ % type definition is in the interface. This is checked in make_hlds.m.
+pragma_allowed_in_interface(reserve_tag(_, _), yes).
pragma_allowed_in_interface(promise_pure(_, _), no).
pragma_allowed_in_interface(promise_semipure(_, _), no).
pragma_allowed_in_interface(unused_args(_, _, _, _, _), no).
Index: compiler/post_typecheck.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/post_typecheck.m,v
retrieving revision 1.41
diff -u -d -r1.41 post_typecheck.m
--- compiler/post_typecheck.m 22 Jul 2002 06:29:45 -0000 1.41
+++ compiler/post_typecheck.m 10 Jan 2003 12:33:22 -0000
@@ -1619,7 +1619,7 @@
module_info_types(ModuleInfo, Types),
map__lookup(Types, TermTypeCtor, TermTypeDefn),
hlds_data__get_type_defn_body(TermTypeDefn, TermTypeBody),
- ( TermTypeBody = du_type(Ctors, _, _, _, _) ->
+ ( TermTypeBody = du_type(Ctors, _, _, _, _, _) ->
get_constructor_containing_field_2(Ctors, FieldName, ConsId,
FieldNumber)
;
Index: compiler/prog_data.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_data.m,v
retrieving revision 1.88
diff -u -d -r1.88 prog_data.m
--- compiler/prog_data.m 10 Jan 2003 10:58:17 -0000 1.88
+++ compiler/prog_data.m 10 Jan 2003 11:00:39 -0000
@@ -244,6 +244,9 @@
; fact_table(sym_name, arity, string)
% Predname, Arity, Fact file name.
+ ; reserve_tag(sym_name, arity)
+ % Typename, Arity
+
%
% Aditi pragmas
Index: compiler/prog_io_pragma.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/prog_io_pragma.m,v
retrieving revision 1.53
diff -u -d -r1.53 prog_io_pragma.m
--- compiler/prog_io_pragma.m 23 Dec 2002 12:32:57 -0000 1.53
+++ compiler/prog_io_pragma.m 10 Jan 2003 11:16:33 -0000
@@ -837,6 +837,13 @@
ErrorTerm)
).
+parse_pragma_type(ModuleName, "reserve_tag", PragmaTerms, ErrorTerm,
+ _VarSet, Result) :-
+ parse_simple_type_pragma(ModuleName, "reserve_tag",
+ lambda([Name::in, Arity::in, Pragma::out] is det,
+ Pragma = reserve_tag(Name, Arity)),
+ PragmaTerms, ErrorTerm, Result).
+
parse_pragma_type(ModuleName, "fact_table", PragmaTerms, ErrorTerm,
_VarSet, Result) :-
(
@@ -1060,6 +1067,7 @@
Pragma = check_termination(Name, Arity)),
PragmaTerms, ErrorTerm, Result).
+ % This parses a pragma that refers to a predicate or function.
:- pred parse_simple_pragma(module_name, string,
pred(sym_name, int, pragma_type),
list(term), term, maybe1(item)).
@@ -1068,8 +1076,33 @@
parse_simple_pragma(ModuleName, PragmaType, MakePragma,
PragmaTerms, ErrorTerm, Result) :-
+ parse_simple_pragma_base(ModuleName, PragmaType,
+ "predicate or function", MakePragma, PragmaTerms, ErrorTerm,
+ Result).
+
+ % This parses a pragma that refers to type.
+:- pred parse_simple_type_pragma(module_name, string,
+ pred(sym_name, int, pragma_type),
+ list(term), term, maybe1(item)).
+:- mode parse_simple_type_pragma(in, in, pred(in, in, out) is det,
+ in, in, out) is det.
+
+parse_simple_type_pragma(ModuleName, PragmaType, MakePragma,
+ PragmaTerms, ErrorTerm, Result) :-
+ parse_simple_pragma_base(ModuleName, PragmaType, "type", MakePragma,
+ PragmaTerms, ErrorTerm, Result).
+
+ % This parses a pragma that refers to symbol name / arity.
+:- pred parse_simple_pragma_base(module_name, string, string,
+ pred(sym_name, int, pragma_type),
+ list(term), term, maybe1(item)).
+:- mode parse_simple_pragma_base(in, in, in, pred(in, in, out) is det,
+ in, in, out) is det.
+
+parse_simple_pragma_base(ModuleName, PragmaType, NameKind, MakePragma,
+ PragmaTerms, ErrorTerm, Result) :-
( PragmaTerms = [PredAndArityTerm] ->
- parse_pred_name_and_arity(ModuleName, PragmaType,
+ parse_simple_name_and_arity(ModuleName, PragmaType, NameKind,
PredAndArityTerm, ErrorTerm, NameArityResult),
(
NameArityResult = ok(PredName, Arity),
@@ -1089,15 +1122,25 @@
maybe2(sym_name, arity)).
:- mode parse_pred_name_and_arity(in, in, in, in, out) is det.
-parse_pred_name_and_arity(ModuleName, PragmaType, PredAndArityTerm,
- ErrorTerm, Result) :-
+parse_pred_name_and_arity(ModuleName, PragmaType, NameAndArityTerm, ErrorTerm,
+ Result) :-
+ parse_simple_name_and_arity(ModuleName, PragmaType,
+ "predicate or function", NameAndArityTerm, ErrorTerm, Result).
+
+:- pred parse_simple_name_and_arity(module_name, string, string, term, term,
+ maybe2(sym_name, arity)).
+:- mode parse_simple_name_and_arity(in, in, in, in, in, out) is det.
+
+parse_simple_name_and_arity(ModuleName, PragmaType, NameKind,
+ NameAndArityTerm, ErrorTerm, Result) :-
(
- parse_name_and_arity(ModuleName, PredAndArityTerm,
- PredName, Arity)
+ parse_name_and_arity(ModuleName, NameAndArityTerm,
+ Name, Arity)
->
- Result = ok(PredName, Arity)
+ Result = ok(Name, Arity)
;
- string__append_list(["expected predname/arity for `pragma ",
+ string__append_list(["expected ", NameKind,
+ " name/arity for `pragma ",
PragmaType, "' declaration"], ErrorMsg),
Result = error(ErrorMsg, ErrorTerm)
).
Index: compiler/recompilation.usage.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.usage.m,v
retrieving revision 1.3
diff -u -d -r1.3 recompilation.usage.m
--- compiler/recompilation.usage.m 30 Jun 2002 17:06:39 -0000 1.3
+++ compiler/recompilation.usage.m 10 Jan 2003 12:34:01 -0000
@@ -1031,7 +1031,7 @@
recompilation_usage_info::in, recompilation_usage_info::out) is det.
recompilation__usage__find_items_used_by_type_body(
- du_type(Ctors, _, _, _, _)) -->
+ du_type(Ctors, _, _, _, _, _)) -->
list__foldl(
(pred(Ctor::in, in, out) is det -->
{ Ctor = ctor(_, Constraints, _, CtorArgs) },
Index: compiler/recompilation.version.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/recompilation.version.m,v
retrieving revision 1.2
diff -u -d -r1.2 recompilation.version.m
--- compiler/recompilation.version.m 30 Jun 2002 17:06:39 -0000 1.2
+++ compiler/recompilation.version.m 10 Jan 2003 14:01:17 -0000
@@ -554,6 +554,7 @@
is_pred_pragma(unused_args(PredOrFunc, Name, Arity, _, _),
yes(yes(PredOrFunc) - Name / Arity)).
is_pred_pragma(fact_table(Name, Arity, _), yes(no - Name / Arity)).
+is_pred_pragma(reserve_tag(_TypeName, _TypeArity), no).
is_pred_pragma(aditi(Name, Arity), yes(no - Name / Arity)).
is_pred_pragma(base_relation(Name, Arity), yes(no - Name / Arity)).
is_pred_pragma(aditi_index(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 -d -r1.33 special_pred.m
--- compiler/special_pred.m 30 Jun 2002 17:06:40 -0000 1.33
+++ compiler/special_pred.m 10 Jan 2003 12:34:18 -0000
@@ -210,7 +210,7 @@
\+ special_pred_for_type_needs_typecheck(Body).
special_pred_for_type_needs_typecheck(Body) :-
- Body = du_type(Ctors, _, _, MaybeEqualityPred, _),
+ Body = du_type(Ctors, _, _, MaybeEqualityPred, _, _),
(
MaybeEqualityPred = yes(_)
;
Index: compiler/stack_opt.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/stack_opt.m,v
retrieving revision 1.4
diff -u -d -r1.4 stack_opt.m
--- compiler/stack_opt.m 30 Jul 2002 08:25:11 -0000 1.4
+++ compiler/stack_opt.m 10 Jan 2003 12:34:25 -0000
@@ -1077,7 +1077,7 @@
{ module_info_types(ModuleInfo, TypeTable) },
{ map__lookup(TypeTable, TypeCtor, TypeDefn) },
{ hlds_data__get_type_defn_body(TypeDefn, TypeBody) },
- { TypeBody = du_type(_, ConsTable, _, _, _) }
+ { TypeBody = du_type(_, ConsTable, _, _, _, _) }
->
{ map__lookup(ConsTable, ConsId, ConsTag) },
{ ConsTag = no_tag ->
Index: compiler/switch_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/switch_util.m,v
retrieving revision 1.9
diff -u -d -r1.9 switch_util.m
--- compiler/switch_util.m 30 Jun 2002 17:06:40 -0000 1.9
+++ compiler/switch_util.m 10 Jan 2003 12:57:11 -0000
@@ -317,7 +317,7 @@
module_info_types(ModuleInfo, TypeTable),
map__lookup(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
- ( TypeBody = du_type(_, ConsTable, _, _, _) ->
+ ( TypeBody = du_type(_, ConsTable, _, _, _, _) ->
map__count(ConsTable, TypeRange),
MaxEnum = TypeRange - 1
;
@@ -338,7 +338,7 @@
module_info_types(ModuleInfo, TypeTable),
map__lookup(TypeTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, Body),
- ( Body = du_type(_, ConsTable, _, _, _) ->
+ ( Body = du_type(_, ConsTable, _, _, _, _) ->
map__to_assoc_list(ConsTable, ConsList),
switch_util__cons_list_to_tag_list(ConsList, TagList)
;
Index: compiler/table_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/table_gen.m,v
retrieving revision 1.42
diff -u -d -r1.42 table_gen.m
--- compiler/table_gen.m 15 Nov 2002 04:50:30 -0000 1.42
+++ compiler/table_gen.m 10 Jan 2003 12:34:38 -0000
@@ -1343,7 +1343,7 @@
map__lookup(TypeDefnTable, TypeCtor, TypeDefn),
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
(
- TypeBody = du_type(Ctors, _, yes, no, _)
+ TypeBody = du_type(Ctors, _, yes, no, _, _)
->
list__length(Ctors, EnumRange)
;
Index: compiler/term_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/term_util.m,v
retrieving revision 1.21
diff -u -d -r1.21 term_util.m
--- compiler/term_util.m 30 Jun 2002 17:06:41 -0000 1.21
+++ compiler/term_util.m 10 Jan 2003 12:34:42 -0000
@@ -255,7 +255,7 @@
find_weights_for_type(TypeCtor, TypeDefn, Weights0, Weights) :-
hlds_data__get_type_defn_body(TypeDefn, TypeBody),
(
- TypeBody = du_type(Constructors, _, _, _, _),
+ TypeBody = du_type(Constructors, _, _, _, _, _),
hlds_data__get_type_defn_tparams(TypeDefn, TypeParams),
find_weights_for_cons_list(Constructors, TypeCtor, TypeParams,
Weights0, Weights)
Index: compiler/type_ctor_info.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_ctor_info.m,v
retrieving revision 1.31
diff -u -d -r1.31 type_ctor_info.m
--- compiler/type_ctor_info.m 10 Nov 2002 15:57:59 -0000 1.31
+++ compiler/type_ctor_info.m 10 Jan 2003 15:11:16 -0000
@@ -135,7 +135,8 @@
;
SpecialPreds = no,
hlds_data__get_type_defn_body(TypeDefn, Body),
- Body = du_type(_, _, _, yes(_UserDefinedEquality), _)
+ Body = du_type(_, _, _, yes(_UserDefinedEquality),
+ _, _)
)
->
map__lookup(SpecMap, unify - TypeCtor, UnifyPredId),
@@ -229,7 +230,8 @@
UnivTvars, ExistTvars, MaybePseudoTypeInfo),
Details = eqv(MaybePseudoTypeInfo)
;
- TypeBody = du_type(Ctors, ConsTagMap, Enum, EqualityPred, _),
+ TypeBody = du_type(Ctors, ConsTagMap, Enum, EqualityPred,
+ ReservedTag, _),
(
EqualityPred = yes(_),
EqualityAxioms = user_defined
@@ -237,16 +239,16 @@
EqualityPred = no,
EqualityAxioms = standard
),
- globals__lookup_bool_option(Globals, reserve_tag, ReserveTag),
(
Enum = yes,
type_ctor_info__make_enum_details(Ctors, ConsTagMap,
- ReserveTag, EqualityAxioms, Details)
+ ReservedTag, EqualityAxioms, Details)
;
Enum = no,
(
type_constructors_should_be_no_tag(Ctors,
- Globals, Name, ArgType, MaybeArgName)
+ ReservedTag, Globals, Name, ArgType,
+ MaybeArgName)
->
type_ctor_info__make_notag_details(TypeArity,
Name, ArgType, MaybeArgName,
@@ -391,7 +393,7 @@
type_ctor_info__make_enum_details(Ctors, ConsTagMap, ReserveTag,
EqualityAxioms, Details) :-
( ReserveTag = yes ->
- unexpected("type_ctor_info", "enum in .rt grade")
+ unexpected("type_ctor_info", "enum with reserved tag")
;
true
),
Index: compiler/type_util.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/type_util.m,v
retrieving revision 1.112
diff -u -d -r1.112 type_util.m
--- compiler/type_util.m 5 Dec 2002 03:52:29 -0000 1.112
+++ compiler/type_util.m 10 Jan 2003 15:20:53 -0000
@@ -20,8 +20,9 @@
:- import_module hlds__hlds_module, hlds__hlds_pred, hlds__hlds_data.
:- import_module parse_tree__prog_data, libs__globals.
+
:- import_module term.
-:- import_module std_util, list, map.
+:- import_module bool, std_util, list, map.
%-----------------------------------------------------------------------------%
@@ -305,11 +306,15 @@
:- pred type_constructors_are_type_info(list(constructor)).
:- mode type_constructors_are_type_info(in) is semidet.
+ % type_constructors_should_be_no_tag(Ctors, ReservedTag, Globals,
+ % FunctorName, FunctorArgType, MaybeFunctorArgName):
% Check whether some constructors are a no_tag type, and that this
- % is compatible with the grade options set in the globals.
-:- pred type_constructors_should_be_no_tag(list(constructor), globals,
+ % is compatible with the ReservedTag setting for this type and
+ % the grade options set in the globals.
+:- pred type_constructors_should_be_no_tag(list(constructor), bool, globals,
sym_name, type, maybe(string)).
-:- mode type_constructors_should_be_no_tag(in, in, out, out, out) is semidet.
+:- mode type_constructors_should_be_no_tag(in, in, in, out, out, out)
+ is semidet.
% Unify (with occurs check) two types with respect to a type
% substitution and update the type bindings.
@@ -489,7 +494,7 @@
:- import_module parse_tree__prog_io, parse_tree__prog_io_goal.
:- import_module parse_tree__prog_util, libs__options, libs__globals.
-:- import_module bool, char, int, string.
+:- import_module char, int, string.
:- import_module assoc_list, require, varset.
type_util__type_ctor_module(_ModuleInfo, TypeName - _Arity, ModuleName) :-
@@ -1117,11 +1122,12 @@
% assign single functor of arity one a `no_tag' tag
% (unless it is type_info/1 or we are reserving a tag,
% or if it is one of the dummy types)
-type_constructors_should_be_no_tag(Ctors, Globals,
+type_constructors_should_be_no_tag(Ctors, ReserveTagPragma, Globals,
SingleFunc, SingleArg, MaybeArgName) :-
type_constructors_are_no_tag_type(Ctors, SingleFunc, SingleArg,
MaybeArgName),
(
+ ReserveTagPragma = no,
globals__lookup_bool_option(Globals, reserve_tag, no),
globals__lookup_bool_option(Globals, unboxed_no_tag_types, yes)
;
Index: compiler/unify_gen.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_gen.m,v
retrieving revision 1.121
diff -u -d -r1.121 unify_gen.m
--- compiler/unify_gen.m 30 Jun 2002 17:06:45 -0000 1.121
+++ compiler/unify_gen.m 10 Jan 2003 12:37:57 -0000
@@ -164,7 +164,7 @@
code_info__lookup_type_defn(Type, TypeDefn),
{ hlds_data__get_type_defn_body(TypeDefn, TypeBody) },
{
- TypeBody = du_type(_, ConsTable, _, _, _)
+ TypeBody = du_type(_, ConsTable, _, _, _, _)
->
map__to_assoc_list(ConsTable, ConsList),
(
Index: compiler/unify_proc.m
===================================================================
RCS file: /home/mercury1/repository/mercury/compiler/unify_proc.m,v
retrieving revision 1.112
diff -u -d -r1.112 unify_proc.m
--- compiler/unify_proc.m 22 Jul 2002 06:29:52 -0000 1.112
+++ compiler/unify_proc.m 10 Jan 2003 12:59:57 -0000
@@ -544,11 +544,12 @@
ConsId = cons(CtorSymName, TupleArity),
map__from_assoc_list([ConsId - single_functor],
ConsTagValues),
+ TypeBody = du_type([Ctor], ConsTagValues, IsEnum,
+ UnifyPred, ReservedTag, IsForeign),
UnifyPred = no,
IsEnum = no,
IsForeign = no,
- TypeBody = du_type([Ctor], ConsTagValues, IsEnum,
- UnifyPred, IsForeign),
+ ReservedTag = no,
construct_type(TypeCtor, TupleArgTypes, Type),
term__context_init(Context)
@@ -705,7 +706,7 @@
unify_proc__generate_unify_clauses(TypeBody, H1, H2, Context, Clauses) -->
(
- { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred, _) },
+ { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred, _, _) },
( { MaybeEqPred = yes(PredName) } ->
%
% Just generate a call to the specified predicate,
@@ -795,7 +796,7 @@
unify_proc__generate_index_clauses(TypeBody, X, Index, Context, Clauses) -->
(
- { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred, _) },
+ { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred, _, _) },
( { MaybeEqPred = yes(_) } ->
%
% For non-canonical types, the generated comparison
@@ -842,7 +843,7 @@
unify_proc__generate_compare_clauses(Type, TypeBody, Res, H1, H2, Context,
Clauses) -->
(
- { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred, _) },
+ { TypeBody = du_type(Ctors, _, IsEnum, MaybeEqPred, _, _) },
( { MaybeEqPred = yes(_) } ->
%
% just generate code that will call error/1
Index: doc/reference_manual.texi
===================================================================
RCS file: /home/mercury1/repository/mercury/doc/reference_manual.texi,v
retrieving revision 1.264
diff -u -d -r1.264 reference_manual.texi
--- doc/reference_manual.texi 23 Dec 2002 12:32:58 -0000 1.264
+++ doc/reference_manual.texi 10 Jan 2003 16:00:12 -0000
@@ -7854,6 +7854,11 @@
Support for bottom-up evaluation of Mercury
predicates.
@end menu
+ at c XXX The `reserved tag' pragma is not documented because it is intended to
+ at c be used with `any' insts, which are themselves not yet documented.
+ at c Also, it is a quite low-level facility, and very
+ at c implementation-specific...
+ at c * Reserved tag:: Support for Herbrand constraint solvers.
@node Fact tables
@section Fact tables
@@ -8845,6 +8850,50 @@
@end ifset
@c aditi
+
+ at c XXX The `reserved tag' pragma is not documented because it is intended to
+ at c be used with `any' insts, which are themselves not yet documented.
+ at c Also, it is a quite low-level facility, and very
+ at c implementation-specific...
+ at c
+ at c @node Reserved tag
+ at c @section Reserved tag
+ at c
+ at c The University of Melbourne Mercury implementation includes some fairly
+ at c low-level support for implementing Herbrand constraint solvers
+ at c (i.e. Prolog-style logic variables).
+ at c
+ at c In particular, you can use the @samp{reserve_tag} pragma
+ at c to tell the compiler to reserve a tag in the data representation
+ at c for a type. The intent is for this tag to be used to represent
+ at c unbound variables with inst @samp{any}.
+ at c
+ at c The @samp{reserve_tag} pragma declaration has the following form:
+ at c @example
+ at c :- pragma reserve_tag(@var{type-name}, @var{type-arity}).
+ at c @end example
+ at c
+ at c The @var{type-name} and @var{type-arity} must specify the name
+ at c and arity of a discriminated union type defined in the same module,
+ at c and the @samp{reserve_tag} pragma must occur in the same section
+ at c (interface or implementation) of the module as the type definition.
+ at c
+ at c The effect of this declaration is that values whose primary
+ at c tag is zero are reserved for use in representing unbound variables.
+ at c Note that to actually create an unbound variable, you need to
+ at c use the foreign language interface code, and the code will probably
+ at c need to be aware of the Mercury compiler's data representation.
+ at c
+ at c The @samp{reserve_tag} pragma has the same effect to the
+ at c @samp{--reserve-tag} compiler option (which is documented
+ at c in the Mercury user's guide),
+ at c except that the pragma applies just to the specified type,
+ at c whereas the compiler option applies to discriminated union types
+ at c in the program.
+ at c
+ at c Note that neither the @samp{reserve_tag} pragma nor the @samp{--reserve-tag}
+ at c compiler option will have any useful effect if the @samp{--high-level-data}
+ at c option is used (e.g. for the .NET or Java back-ends).
@node Bibliography
@chapter Bibliography
Index: tests/invalid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/invalid/Mmakefile,v
retrieving revision 1.131
diff -u -d -r1.131 Mmakefile
--- tests/invalid/Mmakefile 22 Nov 2002 13:41:58 -0000 1.131
+++ tests/invalid/Mmakefile 10 Jan 2003 14:53:59 -0000
@@ -100,6 +100,7 @@
qual_basic_test2 \
qualified_cons_id2 \
record_syntax_errors \
+ reserve_tag \
some \
spurious_mode_error \
state_vars_test1 \
Index: tests/invalid/reserve_tag.err_exp
===================================================================
RCS file: tests/invalid/reserve_tag.err_exp
diff -N tests/invalid/reserve_tag.err_exp
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/reserve_tag.err_exp 10 Jan 2003 16:02:20 -0000
@@ -0,0 +1,18 @@
+reserve_tag.m:023: Error: expected type name/arity for `pragma reserve_tag' declaration: list__list / 1.
+reserve_tag.m:021: In `pragma reserve_tag' declaration for
+reserve_tag.m:021: `reserve_tag:undefined_type/1':
+reserve_tag.m:021: error: undefined type `reserve_tag:undefined_type/1'.
+reserve_tag.m:024: In `pragma reserve_tag' declaration for
+reserve_tag.m:024: `reserve_tag:list/1':
+reserve_tag.m:024: error: undefined type `reserve_tag:list/1'.
+reserve_tag.m:025: In `pragma reserve_tag' declaration for
+reserve_tag.m:025: `reserve_tag:exported_type/0':
+reserve_tag.m:025: error: `reserve_tag' declaration must have the same
+reserve_tag.m:025: visibility as the type definition.
+reserve_tag.m:032: In `pragma reserve_tag' declaration for
+reserve_tag.m:032: `reserve_tag:invalid_arity/1':
+reserve_tag.m:032: error: undefined type `reserve_tag:invalid_arity/1'.
+reserve_tag.m:044: In `pragma reserve_tag' declaration for `reserve_tag:foo/0':
+reserve_tag.m:044: warning: multiple `pragma reserved_tag' declarations for
+reserve_tag.m:044: the same type.
+For more information, try recompiling with `-E'.
Index: tests/invalid/reserve_tag.m
===================================================================
RCS file: tests/invalid/reserve_tag.m
diff -N tests/invalid/reserve_tag.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/invalid/reserve_tag.m 10 Jan 2003 16:02:53 -0000
@@ -0,0 +1,45 @@
+% tests/invalid/reserve_tag.m:
+% test some invalid uses of the `:- reserve_tag' pragma.
+
+:- module reserve_tag.
+:- interface.
+:- import_module int.
+
+:- type exported_type ---> foo(int).
+:- type abstract_type.
+
+:- type exported_type2 ---> foo(int).
+:- pragma reserve_tag(exported_type2/0). % OK
+
+:- func mkfoo(int) = exported_type2.
+
+:- implementation.
+:- import_module list.
+
+mkfoo(X) = foo(X).
+
+:- pragma reserve_tag(undefined_type/1). % error: undefined type
+
+:- pragma reserve_tag(list__list / 1). % error: syntax error
+:- pragma reserve_tag(list / 1). % error: undefined type
+:- pragma reserve_tag(exported_type/0). % error: visibility mismatch
+
+:- type abstract_type ---> foo(int).
+:- pragma reserve_tag(abstract_type/0). % OK
+
+:- type invalid_arity ---> invalid_arity.
+:- type invalid_arity(T1, T2) ---> another_invalid_arity.
+:- pragma reserve_tag(invalid_arity/1). % error: undef type (incorrect arity)
+
+:- pragma reserve_tag(expr/0). % OK
+:- type expr
+ ---> number(int)
+ ; plus(expr, expr)
+ ; minus(expr, expr)
+ ; times(expr, expr)
+ ; div(expr, expr).
+
+:- pragma reserve_tag(foo/0). % OK.
+:- type foo ---> foo.
+:- pragma reserve_tag(foo/0). % warning: duplicate pragma
+
Index: tests/valid/Mmakefile
===================================================================
RCS file: /home/mercury1/repository/tests/valid/Mmakefile,v
retrieving revision 1.119
diff -u -d -r1.119 Mmakefile
--- tests/valid/Mmakefile 22 Nov 2002 08:50:43 -0000 1.119
+++ tests/valid/Mmakefile 10 Jan 2003 15:36:12 -0000
@@ -148,6 +148,7 @@
record_syntax_bug_5 \
recursive_no_tag_type \
reg_bug \
+ reserve_tag \
same_length_2 \
semidet_disj \
shape_type \
Index: tests/valid/reserve_tag.m
===================================================================
RCS file: tests/valid/reserve_tag.m
diff -N tests/valid/reserve_tag.m
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/valid/reserve_tag.m 10 Jan 2003 16:01:48 -0000
@@ -0,0 +1,34 @@
+% tests/valid/reserve_tag.m:
+% test some valid uses of the `:- reserve_tag' pragma.
+
+:- module reserve_tag.
+:- interface.
+:- import_module int.
+
+:- type exported_type ---> foo(int).
+:- type exported_type2 ---> foo2(int).
+:- type abstract_type.
+
+:- pragma reserve_tag(exported_type2/0). % OK
+
+:- func mkfoo(int) = exported_type.
+:- func mkfoo2(int) = exported_type2.
+:- func mkfoo3(int) = abstract_type.
+
+:- implementation.
+:- import_module list.
+
+:- type abstract_type ---> foo3(int).
+:- pragma reserve_tag(abstract_type/0). % OK
+
+mkfoo(X) = foo(X).
+mkfoo2(X) = foo2(X).
+mkfoo3(X) = foo3(X).
+
+:- pragma reserve_tag(expr/0). % OK
+:- type expr
+ ---> number(int)
+ ; plus(expr, expr)
+ ; minus(expr, expr)
+ ; times(expr, expr)
+ ; div(expr, expr).
--
Fergus Henderson <fjh at cs.mu.oz.au> | "I have always known that the pursuit
The University of Melbourne | of excellence is a lethal habit"
WWW: <http://www.cs.mu.oz.au/~fjh> | -- the last words of T. S. Garp.
--------------------------------------------------------------------------
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