[m-rev.] for review: direct argument functor type representation
Peter Wang
novalazy at gmail.com
Thu Jun 16 16:45:59 AEST 2011
On 2011-06-13, Julien Fischer <juliensf at csse.unimelb.edu.au> wrote:
>
> On Tue, 31 May 2011, Peter Wang wrote:
> >
> >I think the `where' block attached to the type is cleaner than a
> >separate pragma, so eventually I will change the `:- pragma direct_arg'
> >to something like:
> >
> > :- type maybe_foo
> > ---> yes(foo)
> > ; no
> > where direct_arg is [yes/1].
>
> I agree.
Committed with the following additional changes to replace the
`pragma direct_arg' with the `where direct_arg' syntax.
diff --git a/compiler/add_pragma.m b/compiler/add_pragma.m
index bb64399..c7c4581 100644
--- a/compiler/add_pragma.m
+++ b/compiler/add_pragma.m
@@ -38,11 +38,6 @@
prog_context::in, module_info::in, module_info::out,
list(error_spec)::in, list(error_spec)::out) is det.
-:- pred add_pragma_direct_arg(sym_name::in, arity::in,
- list(sym_name_and_arity)::in, import_status::in,
- prog_context::in, module_info::in, module_info::out,
- list(error_spec)::in, list(error_spec)::out) is det.
-
:- pred add_pragma_foreign_export_enum(foreign_language::in, sym_name::in,
arity::in, export_enum_attributes::in, assoc_list(sym_name, string)::in,
import_status::in, prog_context::in, module_info::in, module_info::out,
@@ -317,11 +312,6 @@ add_pragma(ItemPragma, !Status, !ModuleInfo, !Specs) :-
% have been added).
Pragma = pragma_reserve_tag(_, _)
;
- % Handle pragma direct_arg decls later on (when we process clauses
- % -- they need to be handled after the type definitions
- % have been added).
- Pragma = pragma_direct_arg(_, _, _)
- ;
Pragma = pragma_promise_pure(Name, Arity),
add_pred_marker("promise_pure", Name, Arity, ImportStatus,
Context, marker_promised_pure, [], !ModuleInfo, !Specs)
@@ -556,8 +546,8 @@ add_pragma_reserve_tag(TypeName, TypeArity, PragmaStatus, Context, !ModuleInfo,
;
(
TypeBody0 = hlds_du_type(Body, _CtorTags0, _CheaperTagTest,
- _DuTypeKind, MaybeUserEqComp, ReservedTag0, _ReservedAddr,
- IsForeign),
+ _DuTypeKind, MaybeUserEqComp, MaybeDirectArgCtors,
+ ReservedTag0, _ReservedAddr, IsForeign),
(
ReservedTag0 = uses_reserved_tag,
% Make doubly sure that we don't get any spurious warnings
@@ -582,8 +572,8 @@ add_pragma_reserve_tag(TypeName, TypeArity, PragmaStatus, Context, !ModuleInfo,
assign_constructor_tags(Body, MaybeUserEqComp, TypeCtor,
ReservedTag, Globals, CtorTags, ReservedAddr, DuTypeKind),
TypeBody = hlds_du_type(Body, CtorTags, no_cheaper_tag_test,
- DuTypeKind, MaybeUserEqComp, ReservedTag, ReservedAddr,
- IsForeign),
+ DuTypeKind, MaybeUserEqComp, MaybeDirectArgCtors,
+ ReservedTag, ReservedAddr, IsForeign),
hlds_data.set_type_defn_body(TypeBody, TypeDefn0, TypeDefn),
replace_type_ctor_defn(TypeCtor, TypeDefn,
TypeTable0, TypeTable),
@@ -625,162 +615,6 @@ add_pragma_reserve_tag(TypeName, TypeArity, PragmaStatus, Context, !ModuleInfo,
%-----------------------------------------------------------------------------%
-add_pragma_direct_arg(TypeName, TypeArity, PragmaCtors, PragmaStatus, Context,
- !ModuleInfo, !Specs) :-
- TypeCtor = type_ctor(TypeName, TypeArity),
- module_info_get_type_table(!.ModuleInfo, TypeTable),
- ContextPieces = [
- words("In"), quote("pragma direct_arg"), words("declaration for"),
- sym_name_and_arity(TypeName / TypeArity), suffix(":"), nl
- ],
- ( search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn) ->
- hlds_data.get_type_defn_body(TypeDefn, TypeBody),
- hlds_data.get_type_defn_status(TypeDefn, TypeStatus),
- (
- not (
- TypeStatus = PragmaStatus
- ;
- TypeStatus = status_abstract_exported,
- ( PragmaStatus = status_local
- ; PragmaStatus = status_exported_to_submodules
- )
- ;
- % When the pragma and type are opt-imported, the type status
- % may not match exactly. The visibility requirements are
- % already checked when the .opt file is created anyway.
- PragmaStatus = status_opt_imported,
- ( TypeStatus = status_imported(_)
- ; TypeStatus = status_abstract_imported
- )
- )
- ->
- MaybeSeverity = yes(severity_error),
- ErrorPieces = [
- words("error:"), quote("pragma direct_arg"),
- words("declaration must have"),
- words("the same visibility as the type definition.")
- ]
- ;
- (
- TypeBody = hlds_du_type(Body, CtorTags, _CheaperTagTest,
- _DuTypeKind, _MaybeUserEqComp, _ReservedTag, _ReservedAddr,
- _IsForeign),
- list.map_foldl(check_pragma_direct_arg_ctors(TypeTable,
- TypeCtor, Body, CtorTags),
- PragmaCtors, ErrorPieces0, set.init, PragmaConsIds),
- list.condense(ErrorPieces0, ErrorPieces),
- (
- ErrorPieces = [],
- MaybeSeverity = no,
- module_info_get_pragma_direct_arg_functors(!.ModuleInfo,
- DirectArgCtors0),
- set.union(PragmaConsIds, DirectArgCtors0, DirectArgCtors),
- module_info_set_pragma_direct_arg_functors(DirectArgCtors,
- !ModuleInfo)
- ;
- ErrorPieces = [_ | _],
- MaybeSeverity = yes(severity_error)
- )
- ;
- ( TypeBody = hlds_eqv_type(_)
- ; TypeBody = hlds_foreign_type(_)
- ; TypeBody = hlds_solver_type(_, _)
- ; TypeBody = hlds_abstract_type(_)
- ),
- MaybeSeverity = yes(severity_error),
- ErrorPieces = [
- words("error:"), sym_name_and_arity(TypeName / TypeArity),
- words("is not a discriminated union type."), nl
- ]
- )
- )
- ;
- MaybeSeverity = yes(severity_error),
- ErrorPieces = [
- words("error: undefined type"),
- sym_name_and_arity(TypeName / TypeArity), suffix("."), nl
- ]
- ),
- (
- ErrorPieces = []
- ;
- ErrorPieces = [_ | _],
- (
- MaybeSeverity = yes(Severity)
- ;
- MaybeSeverity = no,
- unexpected($module, $pred, "no severity")
- ),
- Msg = simple_msg(Context, [always(ContextPieces ++ ErrorPieces)]),
- Spec = error_spec(Severity, phase_parse_tree_to_hlds, [Msg]),
- !:Specs = [Spec | !.Specs]
- ).
-
-:- pred check_pragma_direct_arg_ctors(type_table::in, type_ctor::in,
- list(constructor)::in, cons_tag_values::in, sym_name_and_arity::in,
- format_components::out, set(cons_id)::in, set(cons_id)::out) is det.
-
-check_pragma_direct_arg_ctors(TypeTable, TypeCtor, ActualCtors, ConsTagValues,
- PragmaCtor, ErrorPieces, !DirectArgCtors) :-
- % NOTE: changes here may require corresponding changes in
- % is_direct_arg_ctor.
-
- PragmaCtor = SymName / Arity,
- PragmaConsId = cons(SymName, Arity, TypeCtor),
- (
- map.search(ConsTagValues, PragmaConsId, ConsTag),
- find_constructor(ActualCtors, SymName, Arity, MatchingCtor)
- ->
- (
- % Don't warn if the constructor requires a secondary tag, as it
- % may not on an architecture with more tag bits available.
- ( ConsTag = unshared_tag(_)
- ; ConsTag = shared_remote_tag(_, _)
- ),
- MatchingCtor = ctor(_, _, _, [CtorArg], _),
- CtorArg = ctor_arg(_, ArgType, _),
- type_to_ctor_and_args(ArgType, ArgTypeCtor, _),
- (
- type_ctor_is_tuple(ArgTypeCtor)
- ;
- search_type_ctor_defn(TypeTable, ArgTypeCtor, ArgTypeDefn),
- get_type_defn_body(ArgTypeDefn, ArgTypeBody),
- ArgConsTagValues = ArgTypeBody ^ du_type_cons_tag_values,
- map.to_assoc_list(ArgConsTagValues, [_ - ArgConsTag]),
- ArgConsTag = single_functor_tag
- )
- ->
- set.insert(PragmaConsId, !DirectArgCtors),
- ErrorPieces = []
- ;
- ErrorPieces = [
- sym_name_and_arity(SymName / Arity),
- words("cannot be represented as a direct pointer to its"),
- words("sole argument."), nl
- ]
- )
- ;
- ErrorPieces = [
- sym_name_and_arity(SymName / Arity),
- words("does not match any constructor."), nl
- ]
- ).
-
-:- pred find_constructor(list(constructor)::in, sym_name::in, arity::in,
- constructor::out) is semidet.
-
-find_constructor([H | T], SymName, Arity, Ctor) :-
- (
- H = ctor(_, _, SymName, Args, _),
- list.length(Args, Arity)
- ->
- Ctor = H
- ;
- find_constructor(T, SymName, Arity, Ctor)
- ).
-
-%-----------------------------------------------------------------------------%
-
add_pragma_foreign_export_enum(Lang, TypeName, TypeArity, Attributes,
Overrides, _ImportStatus, Context, !ModuleInfo, !Specs) :-
TypeCtor = type_ctor(TypeName, TypeArity),
@@ -826,8 +660,8 @@ add_pragma_foreign_export_enum(Lang, TypeName, TypeArity, Attributes,
;
% XXX How should we handle IsForeignType here?
TypeBody = hlds_du_type(Ctors, _TagValues, _CheaperTagTest,
- DuTypeKind, _MaybeUserEq, _ReservedTag, _ReservedAddr,
- _IsForeignType),
+ DuTypeKind, _MaybeUserEq, _MaybeDirectArgCtors,
+ _ReservedTag, _ReservedAddr, _IsForeignType),
(
( DuTypeKind = du_type_kind_mercury_enum
; DuTypeKind = du_type_kind_foreign_enum(_)
@@ -1180,8 +1014,8 @@ add_pragma_foreign_enum(Lang, TypeName, TypeArity, ForeignTagValues,
words("is not an enumeration type"), suffix(".")]
;
TypeBody0 = hlds_du_type(Ctors, OldTagValues, CheaperTagTest,
- DuTypeKind0, MaybeUserEq, ReservedTag, ReservedAddr,
- IsForeignType),
+ DuTypeKind0, MaybeUserEq, MaybeDirectArgCtors,
+ ReservedTag, ReservedAddr, IsForeignType),
% Work out what language's foreign_enum pragma we should be
% looking at for the the current compilation target language.
module_info_get_globals(!.ModuleInfo, Globals),
@@ -1225,7 +1059,8 @@ add_pragma_foreign_enum(Lang, TypeName, TypeArity, ForeignTagValues,
UnmappedCtors = [],
TypeBody = hlds_du_type(Ctors, TagValues,
CheaperTagTest, DuTypeKind, MaybeUserEq,
- ReservedTag, ReservedAddr, IsForeignType),
+ MaybeDirectArgCtors, ReservedTag, ReservedAddr,
+ IsForeignType),
set_type_defn_body(TypeBody, TypeDefn0, TypeDefn),
replace_type_ctor_defn(TypeCtor, TypeDefn,
TypeTable0, TypeTable),
diff --git a/compiler/add_type.m b/compiler/add_type.m
index ea4dcba..6aa632d 100644
--- a/compiler/add_type.m
+++ b/compiler/add_type.m
@@ -87,7 +87,7 @@ module_add_type_defn(TVarSet, Name, Args, TypeDefn, _Cond, Context,
(
Body0 = hlds_abstract_type(_)
;
- Body0 = hlds_du_type(_, _, _, _, _, _, _, _),
+ Body0 = hlds_du_type(_, _, _, _, _, _, _, _, _),
string.suffix(term.context_file(Context), ".int2")
% If the type definition comes from a .int2 file then we must
% treat it as abstract. The constructors may only be used
@@ -103,7 +103,7 @@ module_add_type_defn(TVarSet, Name, Args, TypeDefn, _Cond, Context,
% zero-arity constructor are dummy types. Dummy types are not allowed
% to have user-defined equality or comparison.
- TypeDefn = parse_tree_du_type(Ctors, MaybeUserUC),
+ TypeDefn = parse_tree_du_type(Ctors, MaybeUserUC, _MaybeDirectArg),
Ctors = [Constructor],
list.length(Constructor ^ cons_args, 0),
MaybeUserUC = yes(_),
@@ -360,7 +360,8 @@ process_type_defn(TypeCtor, TypeDefn, !FoundError, !ModuleInfo, !Specs) :-
get_type_defn_need_qualifier(TypeDefn, NeedQual),
module_info_get_globals(!.ModuleInfo, Globals),
(
- Body = hlds_du_type(ConsList, _, _, _, UserEqCmp, ReservedTag, _, _),
+ Body = hlds_du_type(ConsList, _, _, _, UserEqCmp, _DirectArgCtors,
+ ReservedTag, _, _),
module_info_get_cons_table(!.ModuleInfo, Ctors0),
module_info_get_partial_qualifier_info(!.ModuleInfo, PQInfo),
module_info_get_ctor_field_table(!.ModuleInfo, CtorFields0),
@@ -491,7 +492,7 @@ merge_foreign_type_bodies(Target, MakeOptInterface,
Body = Body1 ^ du_type_is_foreign_type := yes(ForeignTypeBody)
).
merge_foreign_type_bodies(Target, MakeOptInterface,
- Body0 @ hlds_du_type(_, _, _, _, _, _, _, _),
+ Body0 @ hlds_du_type(_, _, _, _, _, _, _, _, _),
Body1 @ hlds_foreign_type(_), Body) :-
merge_foreign_type_bodies(Target, MakeOptInterface, Body1, Body0, Body).
merge_foreign_type_bodies(_, _, hlds_foreign_type(Body0),
@@ -603,8 +604,8 @@ combine_status_abstract_imported(Status2, Status) :-
:- pred convert_type_defn(type_defn::in, type_ctor::in, globals::in,
hlds_type_body::out) is det.
-convert_type_defn(parse_tree_du_type(Body, MaybeUserEqComp), TypeCtor, Globals,
- HLDSBody) :-
+convert_type_defn(parse_tree_du_type(Body, MaybeUserEqComp,
+ MaybeDirectArgCtors), TypeCtor, Globals, HLDSBody) :-
% 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.
@@ -621,7 +622,8 @@ convert_type_defn(parse_tree_du_type(Body, MaybeUserEqComp), TypeCtor, Globals,
CheaperTagTest = no_cheaper_tag_test
),
HLDSBody = hlds_du_type(Body, CtorTagMap, CheaperTagTest, IsEnum,
- MaybeUserEqComp, ReservedTagPragma, ReservedAddr, IsForeign).
+ MaybeUserEqComp, MaybeDirectArgCtors, ReservedTagPragma, ReservedAddr,
+ IsForeign).
convert_type_defn(parse_tree_eqv_type(Body), _, _, hlds_eqv_type(Body)).
convert_type_defn(parse_tree_solver_type(SolverTypeDetails, MaybeUserEqComp),
_, _, hlds_solver_type(SolverTypeDetails, MaybeUserEqComp)).
diff --git a/compiler/check_typeclass.m b/compiler/check_typeclass.m
index 48789b8..0026424 100644
--- a/compiler/check_typeclass.m
+++ b/compiler/check_typeclass.m
@@ -1365,7 +1365,7 @@ is_valid_instance_type(ModuleInfo, ClassId, InstanceDefn, Type,
is_valid_instance_type(ModuleInfo, ClassId, InstanceDefn,
EqvType, N, _, !SeenTypes, !Specs)
;
- ( TypeBody = hlds_du_type(_, _, _, _, _, _, _, _)
+ ( TypeBody = hlds_du_type(_, _, _, _, _, _, _, _, _)
; TypeBody = hlds_foreign_type(_)
; TypeBody = hlds_solver_type(_, _)
; TypeBody = hlds_abstract_type(_)
@@ -1601,7 +1601,7 @@ check_pred_type_ambiguities(PredInfo, !ModuleInfo, !Specs) :-
check_ctor_constraints(TypeCtor - TypeDefn, !ModuleInfo, !Specs) :-
get_type_defn_body(TypeDefn, Body),
(
- Body = hlds_du_type(Ctors, _, _, _, _, _, _, _),
+ Body = hlds_du_type(Ctors, _, _, _, _, _, _, _, _),
list.foldl2(check_ctor_type_ambiguities(TypeCtor, TypeDefn), Ctors,
!ModuleInfo, !Specs)
;
diff --git a/compiler/code_info.m b/compiler/code_info.m
index c15002c..9351292 100644
--- a/compiler/code_info.m
+++ b/compiler/code_info.m
@@ -1045,7 +1045,7 @@ lookup_cheaper_tag_test(CI, Type) = CheaperTagTest :-
(
search_type_defn(CI, Type, TypeDefn),
get_type_defn_body(TypeDefn, TypeBody),
- TypeBody = hlds_du_type(_, _, CheaperTagTestPrime, _, _, _, _, _)
+ TypeBody = hlds_du_type(_, _, CheaperTagTestPrime, _, _, _, _, _, _)
->
CheaperTagTest = CheaperTagTestPrime
;
diff --git a/compiler/equiv_type.m b/compiler/equiv_type.m
index ad3a765..a4802bf 100644
--- a/compiler/equiv_type.m
+++ b/compiler/equiv_type.m
@@ -649,7 +649,6 @@ replace_in_pragma_info(ModuleName, Location, EqvMap, _EqvInstMap,
; Pragma0 = pragma_promise_semipure(_, _)
; Pragma0 = pragma_require_feature_set(_)
; Pragma0 = pragma_reserve_tag(_, _)
- ; Pragma0 = pragma_direct_arg(_, _, _)
; Pragma0 = pragma_source_file(_)
; Pragma0 = pragma_structure_reuse(_, _, _, _, _, _)
; Pragma0 = pragma_structure_sharing(_, _, _, _, _, _)
@@ -780,11 +779,11 @@ replace_in_type_defn(Location, EqvMap, EqvInstMap, TypeCtor, TypeDefn0, TypeDefn
!UsedModules),
TypeDefn = parse_tree_eqv_type(TypeBody)
;
- TypeDefn0 = parse_tree_du_type(TypeBody0, EqPred),
+ TypeDefn0 = parse_tree_du_type(TypeBody0, EqPred, DirectArgFunctors),
replace_in_ctors_location(Location, EqvMap, TypeBody0, TypeBody,
!VarSet, !EquivTypeInfo, !UsedModules),
ContainsCirc = no,
- TypeDefn = parse_tree_du_type(TypeBody, EqPred)
+ TypeDefn = parse_tree_du_type(TypeBody, EqPred, DirectArgFunctors)
;
TypeDefn0 = parse_tree_solver_type(SolverDetails0, MaybeUserEqComp),
SolverDetails0 = solver_type_details(RepresentationType0, InitPred,
diff --git a/compiler/equiv_type_hlds.m b/compiler/equiv_type_hlds.m
index ef3e19d..4a798d1 100644
--- a/compiler/equiv_type_hlds.m
+++ b/compiler/equiv_type_hlds.m
@@ -107,7 +107,7 @@ add_type_to_eqv_map(TypeCtor, Defn, !EqvMap, !EqvExportTypes) :-
IsExported = no
)
;
- ( Body = hlds_du_type(_, _, _, _, _, _, _, _)
+ ( Body = hlds_du_type(_, _, _, _, _, _, _, _, _)
; Body = hlds_foreign_type(_)
; Body = hlds_solver_type(_, _)
; Body = hlds_abstract_type(_)
@@ -155,7 +155,7 @@ replace_in_type_defn(ModuleName, EqvMap, TypeCtor, !Defn, !MaybeRecompInfo) :-
maybe_start_recording_expanded_items(ModuleName, TypeCtorSymName,
!.MaybeRecompInfo, EquivTypeInfo0),
(
- Body0 = hlds_du_type(Ctors0, _, _, _, _, _, _, _),
+ Body0 = hlds_du_type(Ctors0, _, _, _, _, _, _, _, _),
equiv_type.replace_in_ctors(EqvMap, Ctors0, Ctors,
TVarSet0, TVarSet, EquivTypeInfo0, EquivTypeInfo),
Body = Body0 ^ du_type_ctors := Ctors
diff --git a/compiler/export.m b/compiler/export.m
index bafa781..9087f0a 100644
--- a/compiler/export.m
+++ b/compiler/export.m
@@ -829,8 +829,8 @@ output_exported_enum_2(ModuleInfo, ExportedEnumInfo, !IO) :-
unexpected($module, $pred, "invalid type for foreign_export_enum")
;
TypeBody = hlds_du_type(Ctors, TagValues, _CheaperTagTest,
- DuTypeKind, _MaybeUserEq, _ReservedTag, _ReservedAddr,
- _IsForeignType),
+ DuTypeKind, _MaybeUserEq, _MaybeDirectArgCtors,
+ _ReservedTag, _ReservedAddr, _IsForeignType),
(
( DuTypeKind = du_type_kind_general
; DuTypeKind = du_type_kind_notag(_, _, _)
diff --git a/compiler/foreign.m b/compiler/foreign.m
index af13336..d8525e1 100644
--- a/compiler/foreign.m
+++ b/compiler/foreign.m
@@ -419,7 +419,7 @@ to_exported_type(ModuleInfo, Type) = ExportType :-
ForeignTypeName, _, Assertions),
ExportType = exported_type_foreign(ForeignTypeName, Assertions)
;
- ( TypeBody = hlds_du_type(_, _, _, _, _, _, _, _)
+ ( TypeBody = hlds_du_type(_, _, _, _, _, _, _, _, _)
; TypeBody = hlds_eqv_type(_)
; TypeBody = hlds_solver_type(_, _)
; TypeBody = hlds_abstract_type(_)
diff --git a/compiler/hlds_code_util.m b/compiler/hlds_code_util.m
index da888ba..e6d25aa 100644
--- a/compiler/hlds_code_util.m
+++ b/compiler/hlds_code_util.m
@@ -1,7 +1,7 @@
%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
-% Copyright (C) 2002-2010 The University of Melbourne.
+% Copyright (C) 2002-2011 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
@@ -115,7 +115,7 @@ cons_id_to_tag(ModuleInfo, ConsId) = Tag:-
lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
(
- TypeBody = hlds_du_type(_, ConsTagTable, _, _, _, _, _, _),
+ TypeBody = hlds_du_type(_, ConsTagTable, _, _, _, _, _, _, _),
map.lookup(ConsTagTable, ConsId, Tag)
;
( TypeBody = hlds_eqv_type(_)
diff --git a/compiler/hlds_data.m b/compiler/hlds_data.m
index 1c41ea4..c93b806 100644
--- a/compiler/hlds_data.m
+++ b/compiler/hlds_data.m
@@ -225,6 +225,9 @@
% User-defined equality and comparison preds.
du_type_usereq :: maybe(unify_compare),
+ % Direct argument functors.
+ du_direct_arg_ctors :: maybe(list(sym_name_and_arity)),
+
% Is there a `:- pragma reserve_tag' pragma for this type?
du_type_reserved_tag :: uses_reserved_tag,
@@ -554,7 +557,7 @@ get_secondary_tag(Tag) = MaybeSecondaryTag :-
get_maybe_cheaper_tag_test(TypeBody) = CheaperTagTest :-
(
- TypeBody = hlds_du_type(_, _, CheaperTagTest, _, _, _, _, _)
+ TypeBody = hlds_du_type(_, _, CheaperTagTest, _, _, _, _, _, _)
;
( TypeBody = hlds_eqv_type(_)
; TypeBody = hlds_foreign_type(_)
diff --git a/compiler/hlds_module.m b/compiler/hlds_module.m
index abddf7d..85ded86 100644
--- a/compiler/hlds_module.m
+++ b/compiler/hlds_module.m
@@ -459,12 +459,6 @@
:- pred module_info_set_no_tag_types(no_tag_type_table::in,
module_info::in, module_info::out) is det.
-:- pred module_info_get_pragma_direct_arg_functors(module_info::in,
- set(cons_id)::out) is det.
-
-:- pred module_info_set_pragma_direct_arg_functors(set(cons_id)::in,
- module_info::in, module_info::out) is det.
-
:- pred module_info_get_analysis_info(module_info::in, analysis_info::out)
is det.
@@ -798,10 +792,6 @@
% faster.
msi_no_tag_type_table :: no_tag_type_table,
- % The functors which are listed in `:- pragma direct_arg'
- % directives.
- msi_pragma_direct_arg_functors :: set(cons_id),
-
% Information about the procedures we are performing
% complexity experiments on.
msi_maybe_complexity_proc_map :: maybe(pair(int,
@@ -891,7 +881,6 @@ module_info_init(Name, DumpBaseFileName, Items, Globals, QualifierInfo,
SpecMap, PragmaMap),
map.init(NoTagTypes),
- set.init(DirectArgFunctors),
MaybeComplexityMap = no,
ComplexityProcInfos = [],
@@ -918,7 +907,7 @@ module_info_init(Name, DumpBaseFileName, Items, Globals, QualifierInfo,
ExceptionInfo, TrailingInfo, TablingStructMap, MM_TablingInfo,
LambdasPerContext, AtomicsPerContext, ModelNonPragmaCounter,
ImportedModules,
- IndirectlyImportedModules, TypeSpecInfo, NoTagTypes, DirectArgFunctors,
+ IndirectlyImportedModules, TypeSpecInfo, NoTagTypes,
MaybeComplexityMap, ComplexityProcInfos,
AnalysisInfo, UserInitPredCNames, UserFinalPredCNames,
StructureReusePredIds, UsedModules, InterfaceModuleSpecs,
@@ -1043,8 +1032,6 @@ module_info_get_indirectly_imported_module_specifiers(MI,
MI ^ mi_sub_info ^ msi_indirectly_imported_module_specifiers).
module_info_get_type_spec_info(MI, MI ^ mi_sub_info ^ msi_type_spec_info).
module_info_get_no_tag_types(MI, MI ^ mi_sub_info ^ msi_no_tag_type_table).
-module_info_get_pragma_direct_arg_functors(MI,
- MI ^ mi_sub_info ^ msi_pragma_direct_arg_functors).
module_info_get_analysis_info(MI, MI ^ mi_sub_info ^ msi_analysis_info).
module_info_get_maybe_complexity_proc_map(MI,
MI ^ mi_sub_info ^ msi_maybe_complexity_proc_map).
@@ -1205,8 +1192,6 @@ module_info_set_type_spec_info(NewVal, !MI) :-
!MI ^ mi_sub_info ^ msi_type_spec_info := NewVal.
module_info_set_no_tag_types(NewVal, !MI) :-
!MI ^ mi_sub_info ^ msi_no_tag_type_table := NewVal.
-module_info_set_pragma_direct_arg_functors(NewVal, !MI) :-
- !MI ^ mi_sub_info ^ msi_pragma_direct_arg_functors := NewVal.
module_info_set_analysis_info(NewVal, !MI) :-
!MI ^ mi_sub_info ^ msi_analysis_info := NewVal.
module_info_set_maybe_complexity_proc_map(NewVal, !MI) :-
diff --git a/compiler/hlds_out_module.m b/compiler/hlds_out_module.m
index 26be9ec..f3bfa12 100644
--- a/compiler/hlds_out_module.m
+++ b/compiler/hlds_out_module.m
@@ -255,7 +255,8 @@ write_type_params_2(TVarSet, [P | Ps], !IO) :-
write_type_body(Info, TypeCtor, TypeBody, Indent, TVarSet, !IO) :-
(
TypeBody = hlds_du_type(Ctors, ConsTagMap, CheaperTagTest, DuTypeKind,
- MaybeUserEqComp, ReservedTag, ReservedAddr, Foreign),
+ MaybeUserEqComp, MaybeDirectArgCtors, ReservedTag, ReservedAddr,
+ Foreign),
io.write_string(" --->\n", !IO),
(
CheaperTagTest = no_cheaper_tag_test
@@ -324,7 +325,7 @@ write_type_body(Info, TypeCtor, TypeBody, Indent, TVarSet, !IO) :-
write_constructors(TypeCtor, Indent, TVarSet, Ctors, ConsTagMap, !IO),
MercInfo = Info ^ hoi_mercury_to_mercury,
mercury_output_where_attributes(MercInfo, TVarSet, no, MaybeUserEqComp,
- !IO),
+ MaybeDirectArgCtors, !IO),
(
Foreign = yes(_),
write_indent(Indent, !IO),
@@ -349,7 +350,7 @@ write_type_body(Info, TypeCtor, TypeBody, Indent, TVarSet, !IO) :-
TypeBody = hlds_solver_type(SolverTypeDetails, MaybeUserEqComp),
MercInfo = Info ^ hoi_mercury_to_mercury,
mercury_output_where_attributes(MercInfo, TVarSet,
- yes(SolverTypeDetails), MaybeUserEqComp, !IO),
+ yes(SolverTypeDetails), MaybeUserEqComp, no, !IO),
io.write_string(".\n", !IO)
).
diff --git a/compiler/inst_check.m b/compiler/inst_check.m
index 1492da3..2fcbfe4 100644
--- a/compiler/inst_check.m
+++ b/compiler/inst_check.m
@@ -1,7 +1,7 @@
%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
-% Copyright (C) 2006-2009 The University of Melbourne.
+% Copyright (C) 2006-2009, 2011 The University of Melbourne.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
@@ -351,7 +351,7 @@ strip_qualifiers(qualified(_, Name)) = unqualified(Name).
get_du_functors_for_type_def(TypeDef) = Functors :-
get_type_defn_body(TypeDef, TypeDefBody),
(
- TypeDefBody = hlds_du_type(Constructors, _, _, _, _, _, _, _),
+ TypeDefBody = hlds_du_type(Constructors, _, _, _, _, _, _, _, _),
Functors = list.map(constructor_to_sym_name_and_arity, Constructors)
;
( TypeDefBody = hlds_eqv_type(_)
diff --git a/compiler/intermod.m b/compiler/intermod.m
index 5495279..567b4d2 100644
--- a/compiler/intermod.m
+++ b/compiler/intermod.m
@@ -1035,7 +1035,8 @@ gather_types_2(TypeCtor, TypeDefn0, !Info) :-
hlds_data.get_type_defn_body(TypeDefn0, TypeBody0),
(
TypeBody0 = hlds_du_type(Ctors, Tags, CheaperTagTest, Enum,
- MaybeUserEqComp0, ReservedTag, ReservedAddr, MaybeForeign0),
+ MaybeUserEqComp0, MaybeDirectArgCtors, ReservedTag, ReservedAddr,
+ MaybeForeign0),
module_info_get_globals(ModuleInfo, Globals),
globals.get_target(Globals, Target),
@@ -1066,7 +1067,8 @@ gather_types_2(TypeCtor, TypeDefn0, !Info) :-
MaybeForeign = MaybeForeign0
),
TypeBody = hlds_du_type(Ctors, Tags, CheaperTagTest, Enum,
- MaybeUserEqComp, ReservedTag, ReservedAddr, MaybeForeign),
+ MaybeUserEqComp, MaybeDirectArgCtors, ReservedTag, ReservedAddr,
+ MaybeForeign),
hlds_data.set_type_defn_body(TypeBody, TypeDefn0, TypeDefn)
;
TypeBody0 = hlds_foreign_type(ForeignTypeBody0),
@@ -1362,8 +1364,9 @@ write_type(OutInfo, TypeCtor - TypeDefn, !IO) :-
hlds_data.get_type_defn_context(TypeDefn, Context),
TypeCtor = type_ctor(Name, Arity),
(
- Body = hlds_du_type(Ctors, _, _, _, MaybeUserEqComp, _, _, _),
- TypeBody = parse_tree_du_type(Ctors, MaybeUserEqComp)
+ Body = hlds_du_type(Ctors, _, _, _, MaybeUserEqComp, MaybeDirectArgCtors,
+ _, _, _),
+ TypeBody = parse_tree_du_type(Ctors, MaybeUserEqComp, MaybeDirectArgCtors)
;
Body = hlds_eqv_type(EqvType),
TypeBody = parse_tree_eqv_type(EqvType)
@@ -1470,27 +1473,10 @@ write_type(OutInfo, TypeCtor - TypeDefn, !IO) :-
true
),
(
- Body = hlds_du_type(_, ConsTagValsA, _, _, _, _, _, _)
- ->
- map.foldl(gather_direct_arg_ctors, ConsTagValsA, [], DirectArgCtors),
- (
- DirectArgCtors = []
- ;
- DirectArgCtors = [_ | _],
- DirectArgPragma = pragma_direct_arg(Name, Arity, DirectArgCtors),
- DirectArgItemPragma = item_pragma_info(user, DirectArgPragma,
- Context, -1),
- DirectArgItem = item_pragma(DirectArgItemPragma),
- mercury_output_item(MercInfo, DirectArgItem, !IO)
- )
- ;
- true
- ),
- (
- Body = hlds_du_type(_, ConsTagValsB, _, DuTypeKind, _, _, _, _),
+ Body = hlds_du_type(_, ConsTagVals, _, DuTypeKind, _, _, _, _, _),
DuTypeKind = du_type_kind_foreign_enum(Lang)
->
- map.foldl(gather_foreign_enum_value_pair, ConsTagValsB, [],
+ map.foldl(gather_foreign_enum_value_pair, ConsTagVals, [],
ForeignEnumVals),
ForeignPragma = pragma_foreign_enum(Lang, Name, Arity, ForeignEnumVals),
ForeignItemPragma = item_pragma_info(user, ForeignPragma, Context, -1),
@@ -1500,19 +1486,6 @@ write_type(OutInfo, TypeCtor - TypeDefn, !IO) :-
true
).
-:- pred gather_direct_arg_ctors(cons_id::in, cons_tag::in,
- list(sym_name_and_arity)::in, list(sym_name_and_arity)::out) is det.
-
-gather_direct_arg_ctors(ConsId, ConsTag, !DirectArgCtors) :-
- (
- ConsId = cons(SymName, Arity, _),
- ConsTag = direct_arg_tag(_)
- ->
- !:DirectArgCtors = [SymName / Arity | !.DirectArgCtors]
- ;
- true
- ).
-
:- pred gather_foreign_enum_value_pair(cons_id::in, cons_tag::in,
assoc_list(sym_name, string)::in, assoc_list(sym_name, string)::out)
is det.
diff --git a/compiler/make_hlds_passes.m b/compiler/make_hlds_passes.m
index d4ea12c..7eaeb6d 100644
--- a/compiler/make_hlds_passes.m
+++ b/compiler/make_hlds_passes.m
@@ -1269,10 +1269,6 @@ add_pass_3_pragma(ItemPragma, !Status, !ModuleInfo, !QualInfo, !Specs) :-
add_pragma_reserve_tag(TypeName, TypeArity, !.Status, Context,
!ModuleInfo, !Specs)
;
- Pragma = pragma_direct_arg(TypeName, TypeArity, Ctors),
- add_pragma_direct_arg(TypeName, TypeArity, Ctors, !.Status, Context,
- !ModuleInfo, !Specs)
- ;
Pragma = pragma_foreign_export_enum(Lang, TypeName, TypeArity,
Attributes, Overrides),
add_pragma_foreign_export_enum(Lang, TypeName, TypeArity, Attributes,
diff --git a/compiler/make_tags.m b/compiler/make_tags.m
index 5547f7e..fc8661a 100644
--- a/compiler/make_tags.m
+++ b/compiler/make_tags.m
@@ -60,12 +60,15 @@
:- interface.
:- import_module hlds.hlds_data.
+:- import_module hlds.hlds_module.
:- import_module libs.globals.
+:- import_module parse_tree.error_util.
:- import_module parse_tree.prog_data.
:- import_module list.
:- import_module maybe.
-:- import_module set.
+
+%-----------------------------------------------------------------------------%
% assign_constructor_tags(Constructors, MaybeUserEq, TypeCtor,
% ReservedTagPragma, Globals, TagValues, IsEnum):
@@ -93,8 +96,8 @@
% Look for general du type definitions that can be converted into
% direct arg type definitions.
%
-:- pred post_process_type_defns(globals::in, set(cons_id)::in,
- type_table::in, type_table::out) is det.
+:- pred post_process_type_defns(module_info::in, module_info::out,
+ list(error_spec)::out) is det.
%-----------------------------------------------------------------------------%
%-----------------------------------------------------------------------------%
@@ -424,7 +427,8 @@ compute_cheaper_tag_test(CtorTagMap, CheaperTagTest) :-
%-----------------------------------------------------------------------------%
-post_process_type_defns(Globals, PragmaDirectArgFunctors, !TypeTable) :-
+post_process_type_defns(!HLDS, Specs) :-
+ module_info_get_globals(!.HLDS, Globals),
globals.get_target(Globals, Target),
(
Target = target_c,
@@ -436,14 +440,16 @@ post_process_type_defns(Globals, PragmaDirectArgFunctors, !TypeTable) :-
TermSizeWords = no,
TermSizeCells = no
->
- get_all_type_ctor_defns(!.TypeTable, TypeCtorsDefns),
+ module_info_get_type_table(!.HLDS, TypeTable0),
+ get_all_type_ctor_defns(TypeTable0, TypeCtorsDefns),
globals.lookup_int_option(Globals, num_tag_bits, NumTagBits),
MaxTag = max_num_tags(NumTagBits) - 1,
convert_direct_arg_functors(MaxTag, TypeCtorsDefns,
- PragmaDirectArgFunctors, !TypeTable)
+ TypeTable0, TypeTable, [], Specs),
+ module_info_set_type_table(TypeTable, !HLDS)
;
% We cannot use direct arg functors in term size grades.
- true
+ Specs = []
)
;
( Target = target_il
@@ -452,48 +458,53 @@ post_process_type_defns(Globals, PragmaDirectArgFunctors, !TypeTable) :-
; Target = target_erlang
; Target = target_asm
; Target = target_x86_64
- )
+ ),
% Direct arg functors have not (yet) been implemented on these targets.
+ Specs = []
).
:- pred convert_direct_arg_functors(int::in,
- assoc_list(type_ctor, hlds_type_defn)::in,
- set(cons_id)::in, type_table::in, type_table::out) is det.
+ assoc_list(type_ctor, hlds_type_defn)::in, type_table::in, type_table::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
-convert_direct_arg_functors(_, [], _, !TypeTable).
-convert_direct_arg_functors(MaxTag,
- [TypeCtor - TypeDefn | TypeCtorsDefns], PragmaDirectArgFunctors,
- !TypeTable) :-
+convert_direct_arg_functors(_, [], !TypeTable, !Specs).
+convert_direct_arg_functors(MaxTag, [TypeCtor - TypeDefn | TypeCtorsDefns],
+ !TypeTable, !Specs) :-
convert_direct_arg_functors_if_suitable(MaxTag, TypeCtor, TypeDefn,
- PragmaDirectArgFunctors, !TypeTable),
+ !TypeTable, !Specs),
convert_direct_arg_functors(MaxTag, TypeCtorsDefns,
- PragmaDirectArgFunctors, !TypeTable).
+ !TypeTable, !Specs).
:- pred convert_direct_arg_functors_if_suitable(int::in,
- type_ctor::in, hlds_type_defn::in,
- set(cons_id)::in, type_table::in, type_table::out) is det.
+ type_ctor::in, hlds_type_defn::in, type_table::in, type_table::out,
+ list(error_spec)::in, list(error_spec)::out) is det.
convert_direct_arg_functors_if_suitable(MaxTag, TypeCtor, TypeDefn,
- PragmaDirectArgFunctors, !TypeTable) :-
+ !TypeTable, !Specs) :-
get_type_defn_body(TypeDefn, Body),
(
Body = hlds_du_type(Ctors, _ConsTagValues, _MaybeCheaperTagTest,
- DuKind, MaybeUserEqComp, ReservedTag, ReservedAddr, MaybeForeign),
+ DuKind, MaybeUserEqComp, MaybeAssertedDirectArgCtors,
+ ReservedTag, ReservedAddr, MaybeForeign),
(
Ctors = [_, _ | _],
DuKind = du_type_kind_general,
ReservedTag = does_not_use_reserved_tag,
ReservedAddr = does_not_use_reserved_address,
MaybeForeign = no,
-
TypeCtor = type_ctor(TypeCtorSymName, _TypeCtorArity),
sym_name_get_module_name(TypeCtorSymName, TypeCtorModule)
->
get_type_defn_status(TypeDefn, TypeStatus),
+ (
+ MaybeAssertedDirectArgCtors = yes(AssertedDirectArgFunctors)
+ ;
+ MaybeAssertedDirectArgCtors = no,
+ AssertedDirectArgFunctors = []
+ ),
separate_out_constants(Ctors, Constants, Functors),
- list.filter(
- is_direct_arg_ctor(!.TypeTable, TypeCtor, TypeCtorModule,
- TypeStatus, PragmaDirectArgFunctors),
+ list.filter(is_direct_arg_ctor(!.TypeTable, TypeCtorModule,
+ TypeStatus, AssertedDirectArgFunctors),
Functors, DirectArgFunctors, NonDirectArgFunctors),
(
DirectArgFunctors = []
@@ -517,12 +528,18 @@ convert_direct_arg_functors_if_suitable(MaxTag, TypeCtor, TypeDefn,
),
compute_cheaper_tag_test(DirectArgConsTagValues,
MaybeCheaperTagTest),
+ DirectArgFunctorNames =
+ list.map(constructor_to_sym_name_and_arity,
+ DirectArgFunctors),
DirectArgBody = hlds_du_type(Ctors, DirectArgConsTagValues,
- MaybeCheaperTagTest, DuKind, MaybeUserEqComp, ReservedTag,
- ReservedAddr, MaybeForeign),
+ MaybeCheaperTagTest, DuKind, MaybeUserEqComp,
+ yes(DirectArgFunctorNames), ReservedTag, ReservedAddr,
+ MaybeForeign),
set_type_defn_body(DirectArgBody, TypeDefn, DirectArgTypeDefn),
replace_type_ctor_defn(TypeCtor, DirectArgTypeDefn, !TypeTable)
- )
+ ),
+ check_incorrect_direct_arg_assertions(AssertedDirectArgFunctors,
+ NonDirectArgFunctors, !Specs)
;
% We cannot use the direct argument representation for any
% functors.
@@ -537,46 +554,52 @@ convert_direct_arg_functors_if_suitable(MaxTag, TypeCtor, TypeDefn,
% Leave these types alone.
).
-:- pred is_direct_arg_ctor(type_table::in, type_ctor::in, module_name::in,
- import_status::in, set(cons_id)::in, constructor::in) is semidet.
-
-is_direct_arg_ctor(TypeTable, TypeCtor, TypeCtorModule, TypeStatus,
- PragmaDirectArgConsIds, Ctor) :-
- % NOTE: changes here may require corresponding changes in
- % check_pragma_direct_arg_ctors.
+:- pred is_direct_arg_ctor(type_table::in, module_name::in, import_status::in,
+ list(sym_name_and_arity)::in, constructor::in) is semidet.
+is_direct_arg_ctor(TypeTable, TypeCtorModule, TypeStatus,
+ AssertedDirectArgCtors, Ctor) :-
Ctor = ctor(ExistQTVars, ExistConstraints, ConsName, ConsArgs,
_CtorContext),
ExistQTVars = [],
ExistConstraints = [],
ConsArgs = [ConsArg],
+ Arity = 1,
ConsArg = ctor_arg(_MaybeFieldName, ArgType, _ArgContext),
type_to_ctor_and_args(ArgType, ArgTypeCtor, ArgTypeCtorArgTypes),
- ArgTypeCtorArgTypes = [],
- % XXX We could let this be a subset of the type params, but that would
- % require the runtime system to be able to handle variables in the argument
- % type, during unification and comparison (mercury_unify_compare_body.h)
- % during deconstruction (mercury_ml_expand_body.h), during deep copying
- % (mercury_deep_copy_body.h), and maybe during some other operations.
-
- ArgTypeCtor = type_ctor(ArgTypeCtorSymName, _ArgTypeCtorArity),
- sym_name_get_module_name(ArgTypeCtorSymName, ArgTypeCtorModule),
(
- Arity = 1,
- set.contains(PragmaDirectArgConsIds, cons(ConsName, Arity, TypeCtor))
+ % Trust the `direct_arg' attribute of an imported type.
+ status_is_imported(TypeStatus) = yes,
+ list.contains(AssertedDirectArgCtors, ConsName / Arity)
->
- ArgCond = direct_arg_have_pragma
+ ArgCond = direct_arg_asserted
;
- search_type_ctor_defn(TypeTable, ArgTypeCtor, ArgTypeDefn)
+ % Tuples are always acceptable argument types as they are represented
+ % by word-aligned vector pointers.
+ % Strings are *not* always word-aligned (yet) so are not acceptable.
+ type_ctor_is_tuple(ArgTypeCtor)
->
+ ArgCond = direct_arg_builtin_type
+ ;
+ ArgTypeCtorArgTypes = [],
+ % XXX We could let this be a subset of the type params, but that would
+ % require the runtime system to be able to handle variables in the
+ % argument type, during unification and comparison
+ % (mercury_unify_compare_body.h) during deconstruction
+ % (mercury_ml_expand_body.h), during deep copying
+ % (mercury_deep_copy_body.h), and maybe during some other operations.
+
+ search_type_ctor_defn(TypeTable, ArgTypeCtor, ArgTypeDefn),
get_type_defn_body(ArgTypeDefn, ArgBody),
- ArgBody = hlds_du_type(ArgCtors, ArgConsTagValues, ArgMaybeCheaperTagTest,
- ArgDuKind, _ArgMaybeUserEqComp, ArgReservedTag, ArgReservedAddr,
+ ArgBody = hlds_du_type(ArgCtors, ArgConsTagValues,
+ ArgMaybeCheaperTagTest, ArgDuKind, _ArgMaybeUserEqComp,
+ ArgDirectArgCtors, ArgReservedTag, ArgReservedAddr,
ArgMaybeForeign),
ArgCtors = [_],
ArgMaybeCheaperTagTest = no_cheaper_tag_test,
ArgDuKind = du_type_kind_general,
+ ArgDirectArgCtors = no,
ArgReservedTag = does_not_use_reserved_tag,
ArgReservedAddr = does_not_use_reserved_address,
ArgMaybeForeign = no,
@@ -585,18 +608,21 @@ is_direct_arg_ctor(TypeTable, TypeCtor, TypeCtorModule, TypeStatus,
ArgConsTagValueList = [ArgConsTagValue],
ArgConsTagValue = _ConsId - single_functor_tag,
- ( TypeCtorModule = ArgTypeCtorModule ->
- get_type_defn_status(ArgTypeDefn, ArgTypeStatus),
- ArgCond = direct_arg_same_module(ArgTypeStatus)
+ (
+ status_defined_in_this_module(TypeStatus) = yes,
+ list.contains(AssertedDirectArgCtors, ConsName / Arity)
+ ->
+ ArgCond = direct_arg_asserted
;
- ArgCond = direct_arg_different_module
+ ArgTypeCtor = type_ctor(ArgTypeCtorSymName, _ArgTypeCtorArity),
+ sym_name_get_module_name(ArgTypeCtorSymName, ArgTypeCtorModule),
+ ( TypeCtorModule = ArgTypeCtorModule ->
+ get_type_defn_status(ArgTypeDefn, ArgTypeStatus),
+ ArgCond = direct_arg_same_module(ArgTypeStatus)
+ ;
+ ArgCond = direct_arg_different_module
+ )
)
- ;
- % Tuples are always acceptable argument types as they are represented
- % by word-aligned vector pointers.
- % Strings are *not* always word-aligned (yet) so are not acceptable.
- ArgTypeCtorSymName = unqualified("{}"),
- ArgCond = direct_arg_builtin_type
),
check_direct_arg_cond(TypeStatus, ArgCond).
@@ -606,8 +632,8 @@ is_direct_arg_ctor(TypeTable, TypeCtor, TypeCtorModule, TypeStatus,
% The argument is of a builtin type that is represented with an
% untagged pointer.
- ; direct_arg_have_pragma
- % A `:- pragma direct_arg' specifies that the direct arg
+ ; direct_arg_asserted
+ % A `where direct_arg' attribute asserts that the direct arg
% representation may be used for the constructor.
; direct_arg_same_module(import_status)
@@ -634,44 +660,43 @@ check_direct_arg_cond(TypeStatus, ArgCond) :-
% If the outer type is opt-exported, another module may opt-import this
% type, but abstract-import the argument type. It could not then infer
% if the direct arg representation is required for any functors of the
- % outer type. The problem is overcome by adding `:- pragma direct_arg'
- % directives to .opt files alongside the opt-exported outer type, which
- % state which functors require the direct arg representation.
+ % outer type. The problem is overcome by adding `where direct_arg'
+ % attributes to the opt-exported type definition in .opt files,
+ % which state the functors that require the direct arg representation.
TypeStatus = status_opt_exported
;
% If the outer type is exported from this module, then the direct arg
% representation may be used, so long as any importing modules will
- % infer the same thing. That will be so if:
- % - if the argument is of an acceptable builtin type
- % - there is a `:- pragma direct_arg' for the constructor
- % - the argument type is exported from the same module as the outer
- % type. If the outer type is exported to sub-modules only, the argument
- % type only needs to be exported to sub-modules as well.
+ % infer the same thing.
( TypeStatus = status_exported
; TypeStatus = status_exported_to_submodules
),
( ArgCond = direct_arg_builtin_type
- ; ArgCond = direct_arg_have_pragma
+ ; ArgCond = direct_arg_asserted
; ArgCond = direct_arg_same_module(status_exported)
; ArgCond = direct_arg_same_module(TypeStatus)
+ % If the outer type is exported to sub-modules only, the argument
+ % type only needs to be exported to sub-modules as well.
)
;
% The direct arg representation is required if the outer type is
% imported, and:
% - if the argument type is an acceptable builtin type
- % - a `pragma direct_arg' says so
+ % - a `where direct_arg' attribute says so
% - if the argument type is imported from the same module
TypeStatus = status_imported(_),
( ArgCond = direct_arg_builtin_type
- ; ArgCond = direct_arg_have_pragma
+ ; ArgCond = direct_arg_asserted
; ArgCond = direct_arg_same_module(status_imported(_))
)
;
% If the outer type is opt-imported, there will always be a
- % `:- pragma direct_arg' in the same .opt file which states
+ % `where direct_arg' attribute on the type definition which states
% if the direct argument representation must be used.
- TypeStatus = status_opt_imported,
- ArgCond = direct_arg_have_pragma
+ ( TypeStatus = status_opt_imported
+ ; TypeStatus = status_abstract_imported
+ ),
+ ArgCond = direct_arg_asserted
).
:- pred assign_direct_arg_tags(type_ctor::in, list(constructor)::in,
@@ -701,6 +726,34 @@ assign_direct_arg_tags(TypeCtor, [Ctor | Ctors], !Val, MaxTag, LeftOverCtors,
!CtorTags)
).
+:- pred check_incorrect_direct_arg_assertions(list(sym_name_and_arity)::in,
+ list(constructor)::in, list(error_spec)::in, list(error_spec)::out) is det.
+
+check_incorrect_direct_arg_assertions(_AssertedDirectArgCtors, [], !Specs).
+check_incorrect_direct_arg_assertions(AssertedDirectArgCtors, [Ctor | Ctors],
+ !Specs) :-
+ (
+ Ctor = ctor(_, _, SymName, Args, Context),
+ list.length(Args, Arity),
+ list.contains(AssertedDirectArgCtors, SymName / Arity)
+ ->
+ Pieces = [words("Error:"), sym_name_and_arity(SymName / Arity),
+ words("cannot be represented as a direct pointer to its"),
+ words("sole argument."), nl],
+ Msg = simple_msg(Context, [always(Pieces)]),
+ Spec = error_spec(severity_error, phase_type_check, [Msg]),
+ !:Specs = [Spec | !.Specs]
+ ;
+ true
+ ),
+ check_incorrect_direct_arg_assertions(AssertedDirectArgCtors, Ctors,
+ !Specs).
+
+:- func constructor_to_sym_name_and_arity(constructor) = sym_name_and_arity.
+
+constructor_to_sym_name_and_arity(ctor(_, _, Name, Args, _)) =
+ Name / list.length(Args).
+
%-----------------------------------------------------------------------------%
%
% Auxiliary functions and predicates.
diff --git a/compiler/mercury_compile_front_end.m b/compiler/mercury_compile_front_end.m
index 0140753..c889c94 100644
--- a/compiler/mercury_compile_front_end.m
+++ b/compiler/mercury_compile_front_end.m
@@ -135,17 +135,14 @@ frontend_pass(QualInfo0, FoundUndefTypeError, FoundUndefModeError, !FoundError,
maybe_write_string(Verbose,
"% Post-processing type definitions...\n", !IO),
- module_info_get_type_table(!.HLDS, TypeTable0),
- module_info_get_pragma_direct_arg_functors(!.HLDS,
- PragmaDirectArgFunctors),
- post_process_type_defns(Globals, PragmaDirectArgFunctors,
- TypeTable0, TypeTable),
- module_info_set_type_table(TypeTable, !HLDS),
+ post_process_type_defns(!HLDS, PostTypeSpecs),
+ PostTypeErrors = contains_errors(Globals, PostTypeSpecs),
+ bool.or(PostTypeErrors, !FoundError),
maybe_dump_hlds(!.HLDS, 3, "typedefn", !DumpInfo, !IO),
maybe_write_string(Verbose, "% Checking typeclasses...\n", !IO),
check_typeclasses(!HLDS, QualInfo0, QualInfo, [], TypeClassSpecs),
- !:Specs = TypeClassSpecs ++ !.Specs,
+ !:Specs = PostTypeSpecs ++ TypeClassSpecs ++ !.Specs,
maybe_dump_hlds(!.HLDS, 5, "typeclass", !DumpInfo, !IO),
set_module_recomp_info(QualInfo, !HLDS),
diff --git a/compiler/mercury_to_mercury.m b/compiler/mercury_to_mercury.m
index 07dbb80..7b67901 100644
--- a/compiler/mercury_to_mercury.m
+++ b/compiler/mercury_to_mercury.m
@@ -359,8 +359,8 @@
bool::in, io::di, io::uo) is det.
:- pred mercury_output_where_attributes(merc_out_info::in, tvarset::in,
- maybe(solver_type_details)::in, maybe(unify_compare)::in, io::di, io::uo)
- is det.
+ maybe(solver_type_details)::in, maybe(unify_compare)::in,
+ maybe(list(sym_name_and_arity))::in, io::di, io::uo) is det.
:- func describe_error_term(varset(T), term(T)) = string.
@@ -820,16 +820,6 @@ mercury_output_item_pragma(Info, ItemPragma, !IO) :-
add_int(TypeArity, !IO),
add_string(").\n", !IO)
;
- Pragma = pragma_direct_arg(TypeName, TypeArity, Ctors),
- add_string(":- pragma direct_arg(", !IO),
- mercury_format_bracketed_sym_name(TypeName, next_to_graphic_token,
- !IO),
- add_string("/", !IO),
- add_int(TypeArity, !IO),
- add_string(", [", !IO),
- io.write_list(Ctors, ", ", mercury_format_sym_name_and_arity, !IO),
- add_string("]).\n", !IO)
- ;
Pragma = pragma_promise_pure(Pred, Arity),
mercury_output_pragma_decl(Pred, Arity, pf_predicate,
"promise_pure", no, !IO)
@@ -1938,7 +1928,7 @@ mercury_output_type_defn(Info, TVarSet, Name, TParams, TypeDefn, Context,
mercury_output_type(TVarSet, no, Body, !IO),
io.write_string(".\n", !IO)
;
- TypeDefn = parse_tree_du_type(Ctors, MaybeUserEqComp),
+ TypeDefn = parse_tree_du_type(Ctors, MaybeUserEqComp, MaybeDirectArgs),
mercury_output_begin_type_decl(non_solver_type, !IO),
Args = list.map((func(V) = term.variable(V, Context)), TParams),
construct_qualified_term(Name, Args, Context, TypeTerm),
@@ -1946,7 +1936,7 @@ mercury_output_type_defn(Info, TVarSet, Name, TParams, TypeDefn, Context,
io.write_string("\n\t--->\t", !IO),
mercury_output_ctors(Ctors, TVarSet, !IO),
mercury_output_where_attributes(Info, TVarSet, no, MaybeUserEqComp,
- !IO),
+ MaybeDirectArgs, !IO),
io.write_string(".\n", !IO)
;
TypeDefn = parse_tree_solver_type(SolverTypeDetails, MaybeUserEqComp),
@@ -1955,7 +1945,7 @@ mercury_output_type_defn(Info, TVarSet, Name, TParams, TypeDefn, Context,
construct_qualified_term(Name, Args, Context, TypeTerm),
mercury_output_term(TVarSet, no, TypeTerm, !IO),
mercury_output_where_attributes(Info, TVarSet, yes(SolverTypeDetails),
- MaybeUserEqComp, !IO),
+ MaybeUserEqComp, no, !IO),
io.write_string(".\n", !IO)
;
TypeDefn = parse_tree_foreign_type(ForeignType, MaybeUserEqComp,
@@ -2017,7 +2007,7 @@ mercury_output_type_defn(Info, TVarSet, Name, TParams, TypeDefn, Context,
),
io.write_string(")", !IO),
mercury_output_where_attributes(Info, TVarSet, no, MaybeUserEqComp,
- !IO),
+ no, !IO),
io.write_string(".\n", !IO)
).
@@ -2046,10 +2036,11 @@ mercury_output_begin_type_decl(IsSolverType, !IO) :-
).
mercury_output_where_attributes(Info, TVarSet,
- MaybeSolverTypeDetails, MaybeUserEqComp, !IO) :-
+ MaybeSolverTypeDetails, MaybeUserEqComp, MaybeDirectArgs, !IO) :-
(
MaybeSolverTypeDetails = no,
- MaybeUserEqComp = no
+ MaybeUserEqComp = no,
+ MaybeDirectArgs = no
->
true
;
@@ -2100,9 +2091,23 @@ mercury_output_where_attributes(Info, TVarSet,
(
MaybeComparePred = yes(ComparePredName),
io.write_string("comparison is ", !IO),
- mercury_output_bracketed_sym_name(ComparePredName, !IO)
+ mercury_output_bracketed_sym_name(ComparePredName, !IO),
+ (
+ MaybeDirectArgs = yes(_),
+ io.write_string(",\n\t\t", !IO)
+ ;
+ MaybeDirectArgs = no
+ )
;
MaybeComparePred = no
+ ),
+ (
+ MaybeDirectArgs = yes(DirectArgFunctors),
+ io.write_string("direct_arg is [", !IO),
+ mercury_output_direct_arg_functors(DirectArgFunctors, !IO),
+ io.write_string("]", !IO)
+ ;
+ MaybeDirectArgs = no
)
).
@@ -2233,6 +2238,12 @@ mercury_output_ctor_arg_name_prefix(yes(Name), !IO) :-
mercury_output_bracketed_sym_name(Name, !IO),
io.write_string(" :: ", !IO).
+:- pred mercury_output_direct_arg_functors(list(sym_name_and_arity)::in,
+ io::di, io::uo) is det.
+
+mercury_output_direct_arg_functors(Ctors, !IO) :-
+ io.write_list(Ctors, ", ", mercury_format_sym_name_and_arity, !IO).
+
%-----------------------------------------------------------------------------%
:- pred mercury_format_pred_or_func_decl(pred_or_func::in, tvarset::in,
diff --git a/compiler/ml_proc_gen.m b/compiler/ml_proc_gen.m
index a2587a9..3f20532 100644
--- a/compiler/ml_proc_gen.m
+++ b/compiler/ml_proc_gen.m
@@ -173,7 +173,7 @@ foreign_type_required_imports(Target, _TypeCtor - TypeDefn) = Imports :-
unexpected($module, $pred, "no IL type")
)
;
- ( TypeBody = hlds_du_type(_, _, _,_, _, _, _, _)
+ ( TypeBody = hlds_du_type(_, _, _,_, _, _, _, _, _)
; TypeBody = hlds_eqv_type(_)
; TypeBody = hlds_solver_type(_, _)
; TypeBody = hlds_abstract_type(_)
diff --git a/compiler/ml_type_gen.m b/compiler/ml_type_gen.m
index fb26465..f4510fc 100644
--- a/compiler/ml_type_gen.m
+++ b/compiler/ml_type_gen.m
@@ -181,7 +181,7 @@ ml_gen_type_defn_2(ModuleInfo, TypeCtor, TypeDefn, !Defns) :-
% The same issue arises for some of the cases below.
;
TypeBody = hlds_du_type(Ctors, TagValues, _CheaperTagTest, DuTypeKind,
- MaybeUserEqComp, _ReservedTag, _, _),
+ MaybeUserEqComp, _MaybeDirectArgCtors, _ReservedTag, _, _),
% XXX We probably shouldn't ignore _ReservedTag.
ml_gen_equality_members(MaybeUserEqComp, MaybeEqualityMembers),
(
@@ -1207,8 +1207,8 @@ ml_gen_exported_enum(_ModuleInfo, TypeTable, ExportedEnumInfo,
unexpected($module, $pred, "invalid type")
;
TypeBody = hlds_du_type(Ctors, TagValues, _CheaperTagTest,
- _IsEnumOrDummy, _MaybeUserEq, _ReservedTag, _ReservedAddr,
- _IsForeignType),
+ _IsEnumOrDummy, _MaybeUserEq, _MaybeDirectArgCtors,
+ _ReservedTag, _ReservedAddr, _IsForeignType),
ml_gen_type_name(TypeCtor, QualifiedClassName, MLDS_ClassArity),
MLDS_Type = mlds_class_type(QualifiedClassName, MLDS_ClassArity,
mlds_enum),
diff --git a/compiler/ml_unify_gen.m b/compiler/ml_unify_gen.m
index ff4ad3a..9e7d0c1 100644
--- a/compiler/ml_unify_gen.m
+++ b/compiler/ml_unify_gen.m
@@ -1848,8 +1848,10 @@ ml_gen_direct_arg_deconstruct(ModuleInfo, Mode, Ptag,
->
ml_gen_box_or_unbox_rval(ModuleInfo, VarType, ArgType,
native_if_possible, ml_lval(VarLval), VarRval),
- Statement = ml_gen_assign(ArgLval,
- ml_binop(body, VarRval, ml_const(mlconst_int(Ptag))), Context),
+ MLDS_Type = mercury_type_to_mlds_type(ModuleInfo, ArgType),
+ CastRval = ml_unop(cast(MLDS_Type),
+ ml_binop(body, VarRval, ml_const(mlconst_int(Ptag)))),
+ Statement = ml_gen_assign(ArgLval, CastRval, Context),
Statements = [Statement]
;
% Output - input: it's an assignment to the LHS.
@@ -2083,7 +2085,7 @@ ml_gen_hl_tag_field_id(ModuleInfo, Type) = FieldId :-
hlds_data.get_type_defn_body(TypeDefn, TypeDefnBody),
(
TypeDefnBody =
- hlds_du_type(Ctors, TagValues, _, _, _, _ReservedTag, _, _),
+ hlds_du_type(Ctors, TagValues, _, _, _, _, _ReservedTag, _, _),
% XXX We probably shouldn't ignore ReservedTag here.
(
some [Ctor] (
diff --git a/compiler/module_qual.m b/compiler/module_qual.m
index 1de96e3..d7cdab2 100644
--- a/compiler/module_qual.m
+++ b/compiler/module_qual.m
@@ -999,15 +999,17 @@ update_import_status(md_include_module(_), !Info, yes) :-
mq_info::in, mq_info::out,
list(error_spec)::in, list(error_spec)::out) is det.
-qualify_type_defn(parse_tree_du_type(Ctors0, MaybeUserEqComp0),
- parse_tree_du_type(Ctors, MaybeUserEqComp),
+qualify_type_defn(
+ parse_tree_du_type(Ctors0, MaybeUserEqComp0, MaybeDirectArgCtors0),
+ parse_tree_du_type(Ctors, MaybeUserEqComp, MaybeDirectArgCtors),
!Info, !Specs) :-
qualify_constructors(Ctors0, Ctors, !Info, !Specs),
% User-defined equality pred names will be converted into predicate calls
% and then module-qualified after type analysis (during mode analysis).
% That way they get full type overloading resolution, etc. Thus we don't
% module-qualify them here.
- MaybeUserEqComp = MaybeUserEqComp0.
+ MaybeUserEqComp = MaybeUserEqComp0,
+ MaybeDirectArgCtors = MaybeDirectArgCtors0.
qualify_type_defn(parse_tree_eqv_type(Type0), parse_tree_eqv_type(Type),
!Info, !Specs) :-
qualify_type(Type0, Type, !Info, !Specs).
@@ -1445,11 +1447,6 @@ qualify_pragma(Pragma0, Pragma, !Info, !Specs) :-
qualify_mode_list(ModeList0, ModeList, !Info, !Specs),
Pragma = pragma_termination2_info(PredOrFunc, SymName, ModeList,
SuccessArgs, FailureArgs, Term)
- ;
- Pragma0 = pragma_direct_arg(TypeName0, TypeArity0, Ctors),
- qualify_type_ctor(type_ctor(TypeName0, TypeArity0),
- type_ctor(TypeName, TypeArity), !Info, !Specs),
- Pragma = pragma_direct_arg(TypeName, TypeArity, Ctors)
).
:- pred qualify_pragma_vars(list(pragma_var)::in, list(pragma_var)::out,
diff --git a/compiler/modules.m b/compiler/modules.m
index 718de08..a692dde 100644
--- a/compiler/modules.m
+++ b/compiler/modules.m
@@ -937,10 +937,10 @@ insert_type_defn(New, [Head | Tail], Result) :-
make_impl_type_abstract(TypeDefnMap, !TypeDefnPairs) :-
(
- !.TypeDefnPairs =
- [parse_tree_du_type(Ctors, MaybeEqCmp) - ItemTypeDefn0],
+ !.TypeDefnPairs = [TypeDefn0 - ItemTypeDefn0],
+ TypeDefn0 = parse_tree_du_type(Ctors, MaybeEqCmp, MaybeDirectArgCtors),
not constructor_list_represents_dummy_argument_type(TypeDefnMap,
- Ctors, MaybeEqCmp)
+ Ctors, MaybeEqCmp, MaybeDirectArgCtors)
->
Defn = parse_tree_abstract_type(non_solver_type),
ItemTypeDefn = ItemTypeDefn0 ^ td_ctor_defn := Defn,
@@ -960,18 +960,19 @@ make_impl_type_abstract(TypeDefnMap, !TypeDefnPairs) :-
% NOTE: changes here may require changes to `type_util.check_dummy_type'.
%
:- pred constructor_list_represents_dummy_argument_type(type_defn_map::in,
- list(constructor)::in, maybe(unify_compare)::in) is semidet.
+ list(constructor)::in, maybe(unify_compare)::in,
+ maybe(list(sym_name_and_arity))::in) is semidet.
constructor_list_represents_dummy_argument_type(TypeDefnMap,
- Ctors, MaybeEqCmp) :-
+ Ctors, MaybeEqCmp, MaybeDirectArgCtors) :-
constructor_list_represents_dummy_argument_type_2(TypeDefnMap,
- Ctors, MaybeEqCmp, []).
+ Ctors, MaybeEqCmp, MaybeDirectArgCtors, []).
:- pred constructor_list_represents_dummy_argument_type_2(type_defn_map::in,
- list(constructor)::in, maybe(unify_compare)::in, list(mer_type)::in)
- is semidet.
+ list(constructor)::in, maybe(unify_compare)::in,
+ maybe(list(sym_name_and_arity))::in, list(mer_type)::in) is semidet.
-constructor_list_represents_dummy_argument_type_2(TypeDefnMap, [Ctor], no,
+constructor_list_represents_dummy_argument_type_2(TypeDefnMap, [Ctor], no, no,
CoveredTypes) :-
Ctor = ctor(ExistQTVars, Constraints, _Name, Args, _Context),
ExistQTVars = [],
@@ -1006,10 +1007,11 @@ ctor_arg_is_dummy_type(TypeDefnMap, Type, CoveredTypes0) = IsDummyType :-
% dummy type?
multi_map.search(TypeDefnMap, TypeCtor, TypeDefns),
list.member(TypeDefn - _, TypeDefns),
- TypeDefn = parse_tree_du_type(TypeCtors, MaybeEqCmp),
+ TypeDefn = parse_tree_du_type(TypeCtors, MaybeEqCmp,
+ MaybeDirectArgCtors),
CoveredTypes = [Type | CoveredTypes0],
constructor_list_represents_dummy_argument_type_2(TypeDefnMap,
- TypeCtors, MaybeEqCmp, CoveredTypes)
+ TypeCtors, MaybeEqCmp, MaybeDirectArgCtors, CoveredTypes)
->
IsDummyType = yes
;
@@ -1146,9 +1148,9 @@ accumulate_abs_impl_exported_type_lhs(InterfaceTypeMap, BothTypesMap,
->
set.insert(TypeCtor, !AbsEqvLhsTypeCtors)
;
- TypeDefn = parse_tree_du_type(Ctors, MaybeEqCmp),
+ TypeDefn = parse_tree_du_type(Ctors, MaybeEqCmp, MaybeDirectArgCtors),
constructor_list_represents_dummy_argument_type(BothTypesMap,
- Ctors, MaybeEqCmp)
+ Ctors, MaybeEqCmp, MaybeDirectArgCtors)
->
set.insert(TypeCtor, !DummyTypeCtors)
;
@@ -1184,7 +1186,7 @@ accumulate_abs_eqv_type_rhs_2(ImplTypeMap, TypeDefn - _,
set.union(NewRhsTypeCtors, !AbsEqvRhsTypeCtors),
set.fold3(accumulate_abs_impl_exported_type_rhs(ImplTypeMap),
NewRhsTypeCtors, !AbsEqvRhsTypeCtors, set.init, _, !Modules)
- ; TypeDefn = parse_tree_du_type(Ctors, _) ->
+ ; TypeDefn = parse_tree_du_type(Ctors, _, _) ->
% There must exist a foreign type alternative to this type. As the du
% type will be exported, we require the types of all the fields.
ctors_to_type_ctor_set(Ctors, set.init, RhsTypeCtors),
@@ -1595,7 +1597,6 @@ pragma_allowed_in_interface(Pragma) = Allowed :-
; Pragma = pragma_obsolete(_, _)
; Pragma = pragma_source_file(_)
; Pragma = pragma_reserve_tag(_, _)
- ; Pragma = pragma_direct_arg(_, _, _)
; Pragma = pragma_type_spec(_, _, _, _, _, _, _, _)
; Pragma = pragma_termination_info(_, _, _, _, _)
; Pragma = pragma_termination2_info(_,_, _, _, _, _)
@@ -3783,7 +3784,6 @@ item_needs_foreign_imports(Item) = Langs :-
; Pragma = pragma_tabled(_, _, _, _, _, _)
; Pragma = pragma_fact_table(_, _, _)
; Pragma = pragma_reserve_tag(_, _)
- ; Pragma = pragma_direct_arg(_, _, _)
; Pragma = pragma_promise_equivalent_clauses(_, _)
; Pragma = pragma_promise_pure(_, _)
; Pragma = pragma_promise_semipure(_, _)
@@ -3882,7 +3882,6 @@ include_in_int_file_implementation(Item) = Include :-
; Pragma = pragma_tabled(_, _, _, _, _, _)
; Pragma = pragma_fact_table(_, _, _)
; Pragma = pragma_reserve_tag(_, _)
- ; Pragma = pragma_direct_arg(_, _, _)
; Pragma = pragma_promise_equivalent_clauses(_, _)
; Pragma = pragma_promise_pure(_, _)
; Pragma = pragma_promise_semipure(_, _)
@@ -3928,7 +3927,7 @@ make_abstract_defn(Item, ShortInterfaceKind, AbstractItem) :-
Item = item_type_defn(ItemTypeDefn),
TypeDefn = ItemTypeDefn ^ td_ctor_defn,
(
- TypeDefn = parse_tree_du_type(_, _),
+ TypeDefn = parse_tree_du_type(_, _, _),
IsSolverType = non_solver_type,
% For the `.int2' files, we need the full definitions of
% discriminated union types. Even if the functors for a type
@@ -3986,9 +3985,11 @@ make_abstract_unify_compare(Item, int2, AbstractItem) :-
Item = item_type_defn(ItemTypeDefn),
TypeDefn = ItemTypeDefn ^ td_ctor_defn,
(
- TypeDefn = parse_tree_du_type(Constructors, yes(_UserEqComp)),
- AbstractTypeDefn = parse_tree_du_type(Constructors, yes(
- abstract_noncanonical_type(non_solver_type)))
+ TypeDefn = parse_tree_du_type(Constructors, yes(_UserEqComp),
+ MaybeDirectArgCtors),
+ MaybeUserEqComp = yes(abstract_noncanonical_type(non_solver_type)),
+ AbstractTypeDefn = parse_tree_du_type(Constructors, MaybeUserEqComp,
+ MaybeDirectArgCtors)
;
TypeDefn = parse_tree_foreign_type(ForeignType,
yes(_UserEqComp), Assertions),
@@ -4287,7 +4288,6 @@ reorderable_pragma_type(Pragma) = Reorderable :-
; Pragma = pragma_promise_semipure(_, _)
; Pragma = pragma_promise_equivalent_clauses(_, _)
; Pragma = pragma_reserve_tag(_, _)
- ; Pragma = pragma_direct_arg(_, _, _)
; Pragma = pragma_tabled(_, _, _, _, _, _)
; Pragma = pragma_terminates(_, _)
; Pragma = pragma_termination_info(_, _, _, _, _)
@@ -4400,7 +4400,6 @@ chunkable_pragma_type(Pragma) = Reorderable :-
; Pragma = pragma_promise_semipure(_, _)
; Pragma = pragma_promise_equivalent_clauses(_, _)
; Pragma = pragma_reserve_tag(_, _)
- ; Pragma = pragma_direct_arg(_, _, _)
; Pragma = pragma_tabled(_, _, _, _, _, _)
; Pragma = pragma_terminates(_, _)
; Pragma = pragma_termination_info(_, _, _, _, _)
diff --git a/compiler/post_term_analysis.m b/compiler/post_term_analysis.m
index 19f2cc8..320cf3a 100644
--- a/compiler/post_term_analysis.m
+++ b/compiler/post_term_analysis.m
@@ -212,7 +212,7 @@ special_pred_needs_term_check(ModuleInfo, SpecialPredId, TypeDefn) :-
unify_compare::out) is semidet.
get_user_unify_compare(_ModuleInfo, TypeBody, UnifyCompare) :-
- TypeBody = hlds_du_type(_, _, _, _, yes(UnifyCompare), _, _, _).
+ TypeBody = hlds_du_type(_, _, _, _, yes(UnifyCompare), _, _, _, _).
get_user_unify_compare(ModuleInfo, TypeBody, UnifyCompare) :-
TypeBody = hlds_foreign_type(ForeignTypeBody),
foreign_type_body_has_user_defined_eq_comp_pred(ModuleInfo,
diff --git a/compiler/post_typecheck.m b/compiler/post_typecheck.m
index 0c9ab6c..c03f70f 100644
--- a/compiler/post_typecheck.m
+++ b/compiler/post_typecheck.m
@@ -1503,7 +1503,7 @@ get_constructor_containing_field(ModuleInfo, TermType, FieldName,
lookup_type_ctor_defn(TypeTable, TermTypeCtor, TermTypeDefn),
hlds_data.get_type_defn_body(TermTypeDefn, TermTypeBody),
(
- TermTypeBody = hlds_du_type(Ctors, _, _, _, _, _, _, _),
+ TermTypeBody = hlds_du_type(Ctors, _, _, _, _, _, _, _, _),
get_constructor_containing_field_2(TermTypeCtor, Ctors, FieldName,
ConsId, FieldNumber)
;
diff --git a/compiler/prog_data.m b/compiler/prog_data.m
index e0bcf39..0c66b11 100644
--- a/compiler/prog_data.m
+++ b/compiler/prog_data.m
@@ -1628,7 +1628,8 @@ equivalent_cons_ids(ConsIdA, ConsIdB) :-
:- type type_defn
---> parse_tree_du_type(
du_ctors :: list(constructor),
- du_user_uc :: maybe(unify_compare)
+ du_user_uc :: maybe(unify_compare),
+ du_direct_arg :: maybe(list(sym_name_and_arity))
)
; parse_tree_eqv_type(
eqv_type :: mer_type
diff --git a/compiler/prog_io_pragma.m b/compiler/prog_io_pragma.m
index 91ee60d..27010ff 100644
--- a/compiler/prog_io_pragma.m
+++ b/compiler/prog_io_pragma.m
@@ -81,7 +81,8 @@ parse_pragma(ModuleName, VarSet, PragmaTerms, Context, SeqNum, MaybeItem) :-
% Because this is a non-solver type, if the unification with
% MaybeWherePart succeeds then _SolverTypeDetails is guaranteed
% to be `no'.
- MaybeWherePart = ok2(_SolverTypeDetails, MaybeUserEqComp),
+ MaybeWherePart = ok3(_SolverTypeDetails, MaybeUserEqComp,
+ MaybeDirectArgIs),
(
MaybeUserEqComp = yes(_),
MaybeItem0 = ok1(Item0)
@@ -95,7 +96,7 @@ parse_pragma(ModuleName, VarSet, PragmaTerms, Context, SeqNum, MaybeItem) :-
parse_tree_foreign_type(Type, MaybeUserEqComp,
Assertions),
Item = item_type_defn(ItemTypeDefn),
- MaybeItem = ok1(Item)
+ MaybeItem1 = ok1(Item)
;
Pieces = [words("Error: unexpected"),
quote("where equality/comparison is"),
@@ -103,13 +104,27 @@ parse_pragma(ModuleName, VarSet, PragmaTerms, Context, SeqNum, MaybeItem) :-
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(SinglePragmaTerm0),
[always(Pieces)])]),
- MaybeItem = error1([Spec])
+ MaybeItem1 = error1([Spec])
)
;
- MaybeItem = MaybeItem0
+ MaybeItem1 = MaybeItem0
+ ),
+ (
+ MaybeDirectArgIs = yes(_),
+ MaybeItem1 = ok1(_)
+ ->
+ PiecesB = [words("Error:"), quote("direct_arg"),
+ words("attribute is not applicable to foreign types."),
+ nl],
+ SpecB = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(SinglePragmaTerm0),
+ [always(PiecesB)])]),
+ MaybeItem = error1([SpecB])
+ ;
+ MaybeItem = MaybeItem1
)
;
- MaybeWherePart = error2(Specs),
+ MaybeWherePart = error3(Specs),
MaybeItem = error1(Specs)
)
;
@@ -215,10 +230,6 @@ parse_pragma_type(ModuleName, PragmaName, PragmaTerms, ErrorTerm, VarSet,
parse_simple_type_pragma(ModuleName, PragmaName, MakePragma,
PragmaTerms, ErrorTerm, VarSet, Context, SeqNum, MaybeItem)
;
- PragmaName = "direct_arg",
- parse_pragma_direct_arg(ModuleName, PragmaTerms, VarSet, ErrorTerm,
- Context, SeqNum, MaybeItem)
- ;
(
PragmaName = "memo",
EvalMethod = eval_memo
@@ -1282,60 +1293,6 @@ parse_pragma_require_feature_set(PragmaTerms, VarSet, ErrorTerm, Context,
MaybeItem = error1([Spec])
).
-:- pred parse_pragma_direct_arg(module_name::in, list(term)::in, varset::in,
- term::in, prog_context::in, int::in, maybe1(item)::out) is det.
-
-parse_pragma_direct_arg(ModuleName, PragmaTerms, VarSet, ErrorTerm, Context,
- SeqNum, MaybeItem) :-
- ( PragmaTerms = [TypeTerm, FunctorsTerm] ->
- ( parse_name_and_arity(TypeTerm, Name, Arity) ->
- (
- list_term_to_term_list(FunctorsTerm, FunctorsTerms),
- map_parser(parse_direct_arg_functor(ModuleName, VarSet),
- FunctorsTerms, MaybeFunctorsList),
- MaybeFunctorsList = ok1(Functors)
- ->
- Pragma = pragma_direct_arg(Name, Arity, Functors),
- ItemPragma = item_pragma_info(user, Pragma, Context, SeqNum),
- Item = item_pragma(ItemPragma),
- MaybeItem = ok1(Item)
- ;
- Pieces = [words("Error: malformed functors in"),
- quote(":- pragma direct_arg"), words("declaration."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(FunctorsTerm),
- [always(Pieces)])]),
- MaybeItem = error1([Spec])
- )
- ;
- Pieces = [words("Error: expected name/arity for type in"),
- quote(":- pragma direct_arg"), words("declaration."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(TypeTerm), [always(Pieces)])]),
- MaybeItem = error1([Spec])
- )
- ;
- Pieces = [words("Syntax error in"),
- quote(":- pragma direct_arg"), words("declaration."), nl],
- Spec = error_spec(severity_error, phase_term_to_parse_tree,
- [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
- MaybeItem = error1([Spec])
- ).
-
-:- pred parse_direct_arg_functor(module_name::in, varset::in, term::in,
- maybe1(sym_name_and_arity)::out) is det.
-
-parse_direct_arg_functor(ModuleName, VarSet, Term, MaybeFunctor) :-
- parse_simple_name_and_arity(ModuleName, "direct_arg", "functor",
- Term, Term, VarSet, MaybeNameAndArity),
- (
- MaybeNameAndArity = ok2(Name, Arity),
- MaybeFunctor = ok1(Name / Arity)
- ;
- MaybeNameAndArity = error2(Specs),
- MaybeFunctor = error1(Specs)
- ).
-
%----------------------------------------------------------------------------%
:- pred parse_foreign_decl_is_local(term::in, foreign_decl_is_local::out)
diff --git a/compiler/prog_io_type_defn.m b/compiler/prog_io_type_defn.m
index 429a4e2..8e4202c 100644
--- a/compiler/prog_io_type_defn.m
+++ b/compiler/prog_io_type_defn.m
@@ -47,7 +47,8 @@
%
:- pred parse_type_decl_where_part_if_present(is_solver_type::in,
module_name::in, varset::in, term::in, term::out,
- maybe2(maybe(solver_type_details), maybe(unify_compare))::out) is det.
+ maybe3(maybe(solver_type_details), maybe(unify_compare),
+ maybe(list(sym_name_and_arity)))::out) is det.
%-----------------------------------------------------------------------------%
@@ -138,25 +139,35 @@ parse_du_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Attributes0,
(
MaybeTypeCtorAndArgs = ok2(Name, Params),
MaybeCtors = ok1(Ctors),
- MaybeWhere = ok2(_NoSolverTypeDetails, MaybeUserEqComp)
+ MaybeWhere = ok3(_NoSolverTypeDetails, MaybeUserEqComp,
+ MaybeDirectArgIs)
->
process_du_ctors(Params, VarSet, BodyTerm, Ctors, [], CtorsSpecs),
(
- CtorsSpecs = [],
+ MaybeDirectArgIs = yes(DirectArgCtors),
+ check_direct_arg_ctors(Ctors, DirectArgCtors, BodyTerm,
+ CtorsSpecs, ErrorSpecs)
+ ;
+ MaybeDirectArgIs = no,
+ ErrorSpecs = CtorsSpecs
+ ),
+ (
+ ErrorSpecs = [],
varset.coerce(VarSet, TypeVarSet),
- TypeDefn = parse_tree_du_type(Ctors, MaybeUserEqComp),
- ItemTypeDefn = item_type_defn_info(TypeVarSet, Name, Params,
- TypeDefn, Condition, Context, SeqNum),
+ TypeDefn = parse_tree_du_type(Ctors, MaybeUserEqComp,
+ MaybeDirectArgIs),
+ ItemTypeDefn = item_type_defn_info(TypeVarSet, Name,
+ Params, TypeDefn, Condition, Context, SeqNum),
Item = item_type_defn(ItemTypeDefn),
MaybeItem0 = ok1(Item),
check_no_attributes(MaybeItem0, Attributes, MaybeItem)
;
- CtorsSpecs = [_ | _],
- MaybeItem = error1(CtorsSpecs)
+ ErrorSpecs = [_ | _],
+ MaybeItem = error1(ErrorSpecs)
)
;
Specs = get_any_errors2(MaybeTypeCtorAndArgs) ++
- get_any_errors1(MaybeCtors) ++ get_any_errors2(MaybeWhere),
+ get_any_errors1(MaybeCtors) ++ get_any_errors3(MaybeWhere),
MaybeItem = error1(Specs)
)
).
@@ -467,6 +478,58 @@ process_du_ctors(Params, VarSet, BodyTerm, [Ctor | Ctors], !Specs) :-
),
process_du_ctors(Params, VarSet, BodyTerm, Ctors, !Specs).
+:- pred check_direct_arg_ctors(list(constructor)::in,
+ list(sym_name_and_arity)::in, term::in,
+ list(error_spec)::in, list(error_spec)::out) is det.
+
+check_direct_arg_ctors(_Ctors, [], _ErrorTerm, !Specs).
+check_direct_arg_ctors(Ctors, [DirectArgCtor | DirectArgCtors], ErrorTerm,
+ !Specs) :-
+ DirectArgCtor = SymName / Arity,
+ ( find_constructor(Ctors, SymName, Arity, Ctor) ->
+ Ctor = ctor(ExistQVars, _Constraints, _SymName, _Args, _Context),
+ ( Arity \= 1 ->
+ Pieces = [words("Error: the"), quote("direct_arg"),
+ words("attribute contains a function symbol whose arity"),
+ words("is not 1."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs]
+ ; ExistQVars = [_ | _] ->
+ Pieces = [words("Error: the"), quote("direct_arg"),
+ words("attribute contains a function symbol"),
+ sym_name_and_arity(DirectArgCtor),
+ words("with existentially quantified type variables."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs]
+ ;
+ true
+ )
+ ;
+ Pieces = [words("Error: the"), quote("direct_arg"),
+ words("attribute lists the function symbol"),
+ sym_name_and_arity(DirectArgCtor),
+ words("which is not in the type definition."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(ErrorTerm), [always(Pieces)])]),
+ !:Specs = [Spec | !.Specs]
+ ),
+ check_direct_arg_ctors(Ctors, DirectArgCtors, ErrorTerm, !Specs).
+
+:- pred find_constructor(list(constructor)::in, sym_name::in, arity::in,
+ constructor::out) is semidet.
+
+find_constructor([H | T], SymName, Arity, Ctor) :-
+ (
+ H = ctor(_, _, SymName, Args, _),
+ list.length(Args, Arity)
+ ->
+ Ctor = H
+ ;
+ find_constructor(T, SymName, Arity, Ctor)
+ ).
+
%-----------------------------------------------------------------------------%
% parse_eqv_type_defn parses the definition of an equivalence type.
@@ -540,13 +603,24 @@ parse_solver_type_defn(ModuleName, VarSet, HeadTerm, BodyTerm, Attributes0,
MaybeWhere = parse_type_decl_where_term(solver_type, ModuleName,
VarSet, yes(BodyTerm)),
(
- MaybeWhere = error2(Specs),
+ MaybeWhere = error3(Specs),
MaybeItem = error1(Specs)
;
- MaybeWhere = ok2(MaybeSolverTypeDetails, MaybeUserEqComp),
- parse_solver_type_base(ModuleName, VarSet, HeadTerm,
- MaybeSolverTypeDetails, MaybeUserEqComp, Attributes,
- Condition, Context, SeqNum, MaybeItem)
+ MaybeWhere = ok3(MaybeSolverTypeDetails, MaybeUserEqComp,
+ MaybeDirectArgCtors),
+ (
+ MaybeDirectArgCtors = yes(_),
+ Pieces = [words("Error: solver type definitions cannot have a"),
+ quote("direct_arg"), words("attribute."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(HeadTerm), [always(Pieces)])]),
+ MaybeItem = error1([Spec])
+ ;
+ MaybeDirectArgCtors = no,
+ parse_solver_type_base(ModuleName, VarSet, HeadTerm,
+ MaybeSolverTypeDetails, MaybeUserEqComp, Attributes,
+ Condition, Context, SeqNum, MaybeItem)
+ )
)
).
@@ -659,7 +733,7 @@ parse_type_decl_where_part_if_present(IsSolverType, ModuleName, VarSet,
ModuleName, VarSet, yes(WhereTerm))
;
BeforeWhereTerm = Term,
- MaybeWhereDetails = ok2(no, no)
+ MaybeWhereDetails = ok3(no, no, no)
).
% The maybe2 wrapper allows us to return an error code or a pair
@@ -667,13 +741,14 @@ parse_type_decl_where_part_if_present(IsSolverType, ModuleName, VarSet,
% wrapper around each of those.
%
:- func parse_type_decl_where_term(is_solver_type, module_name, varset,
- maybe(term)) = maybe2(maybe(solver_type_details), maybe(unify_compare)).
+ maybe(term)) = maybe3(maybe(solver_type_details), maybe(unify_compare),
+ maybe(list(sym_name_and_arity))).
parse_type_decl_where_term(IsSolverType, ModuleName, VarSet, MaybeTerm0) =
MaybeWhereDetails :-
(
MaybeTerm0 = no,
- MaybeWhereDetails = ok2(no, no)
+ MaybeWhereDetails = ok3(no, no, no)
;
MaybeTerm0 = yes(Term0),
some [!MaybeTerm] (
@@ -701,6 +776,9 @@ parse_type_decl_where_term(IsSolverType, ModuleName, VarSet, MaybeTerm0) =
parse_where_attribute(parse_where_is("comparison",
parse_where_pred_is(ModuleName, VarSet)),
MaybeComparisonIs, !MaybeTerm),
+ parse_where_attribute(parse_where_is("direct_arg",
+ parse_where_direct_arg_is(ModuleName, VarSet)),
+ MaybeDirectArgIs, !MaybeTerm),
parse_where_end(!.MaybeTerm, MaybeWhereEnd)
),
MaybeWhereDetails = make_maybe_where_details(
@@ -713,6 +791,7 @@ parse_type_decl_where_term(IsSolverType, ModuleName, VarSet, MaybeTerm0) =
MaybeCStoreIs,
MaybeEqualityIs,
MaybeComparisonIs,
+ MaybeDirectArgIs,
MaybeWhereEnd,
Term0
)
@@ -900,6 +979,38 @@ parse_mutable_decl_term(ModuleName, Term, MaybeItem) :-
MaybeItem = error1([Spec])
).
+:- func parse_where_direct_arg_is(module_name, varset, term) =
+ maybe1(list(sym_name_and_arity)).
+
+parse_where_direct_arg_is(ModuleName, VarSet, Term) = MaybeDirectArgCtors :-
+ ( list_term_to_term_list(Term, FunctorsTerms) ->
+ map_parser(parse_direct_arg_functor(ModuleName, VarSet),
+ FunctorsTerms, MaybeDirectArgCtors)
+ ;
+ Pieces = [words("Error: malformed functors list in"),
+ quote("direct_arg"), words("attribute."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term),
+ [always(Pieces)])]),
+ MaybeDirectArgCtors = error1([Spec])
+ ).
+
+:- pred parse_direct_arg_functor(module_name::in, varset::in, term::in,
+ maybe1(sym_name_and_arity)::out) is det.
+
+parse_direct_arg_functor(ModuleName, VarSet, Term, MaybeFunctor) :-
+ ( parse_name_and_arity(ModuleName, Term, Name, Arity) ->
+ MaybeFunctor = ok1(Name / Arity)
+ ;
+ TermStr = describe_error_term(VarSet, Term),
+ Pieces = [words("Error: expected functor"),
+ words("name/arity for"), quote("direct_arg"),
+ words("attribute, not"), quote(TermStr), suffix("."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(Term), [always(Pieces)])]),
+ MaybeFunctor = error1([Spec])
+ ).
+
:- pred parse_where_end(maybe(term)::in, maybe1(maybe(unit))::out) is det.
parse_where_end(no, ok1(yes(unit))).
@@ -914,14 +1025,16 @@ parse_where_end(yes(Term), error1([Spec])) :-
maybe1(maybe(mer_inst)), maybe1(maybe(mer_inst)),
maybe1(maybe(list(item))),
maybe1(maybe(equality_pred)), maybe1(maybe(comparison_pred)),
+ maybe1(maybe(list(sym_name_and_arity))),
maybe1(maybe(unit)), term)
- = maybe2(maybe(solver_type_details), maybe(unify_compare)).
+ = maybe3(maybe(solver_type_details), maybe(unify_compare),
+ maybe(list(sym_name_and_arity))).
make_maybe_where_details(IsSolverType, MaybeTypeIsAbstractNoncanonical,
MaybeRepresentationIs, MaybeInitialisationIs,
MaybeGroundIs, MaybeAnyIs, MaybeCStoreIs,
- MaybeEqualityIs, MaybeComparisonIs, MaybeWhereEnd, WhereTerm)
- = MaybeSolverUC :-
+ MaybeEqualityIs, MaybeComparisonIs, MaybeDirectArgIs,
+ MaybeWhereEnd, WhereTerm) = MaybeWhereDetails :-
(
MaybeTypeIsAbstractNoncanonical = ok1(TypeIsAbstractNoncanonical),
MaybeRepresentationIs = ok1(RepresentationIs),
@@ -931,11 +1044,12 @@ make_maybe_where_details(IsSolverType, MaybeTypeIsAbstractNoncanonical,
MaybeCStoreIs = ok1(CStoreIs),
MaybeEqualityIs = ok1(EqualityIs),
MaybeComparisonIs = ok1(ComparisonIs),
+ MaybeDirectArgIs = ok1(DirectArgIs),
MaybeWhereEnd = ok1(WhereEnd)
->
- MaybeSolverUC = make_maybe_where_details_2(IsSolverType,
+ MaybeWhereDetails = make_maybe_where_details_2(IsSolverType,
TypeIsAbstractNoncanonical, RepresentationIs, InitialisationIs,
- GroundIs, AnyIs, CStoreIs, EqualityIs, ComparisonIs,
+ GroundIs, AnyIs, CStoreIs, EqualityIs, ComparisonIs, DirectArgIs,
WhereEnd, WhereTerm)
;
Specs =
@@ -947,19 +1061,22 @@ make_maybe_where_details(IsSolverType, MaybeTypeIsAbstractNoncanonical,
get_any_errors1(MaybeCStoreIs) ++
get_any_errors1(MaybeEqualityIs) ++
get_any_errors1(MaybeComparisonIs) ++
+ get_any_errors1(MaybeDirectArgIs) ++
get_any_errors1(MaybeWhereEnd),
- MaybeSolverUC = error2(Specs)
+ MaybeWhereDetails = error3(Specs)
).
:- func make_maybe_where_details_2(is_solver_type, maybe(unit),
maybe(mer_type), maybe(init_pred), maybe(mer_inst), maybe(mer_inst),
maybe(list(item)), maybe(equality_pred), maybe(comparison_pred),
- maybe(unit), term)
- = maybe2(maybe(solver_type_details), maybe(unify_compare)).
+ maybe(list(sym_name_and_arity)), maybe(unit), term)
+ = maybe3(maybe(solver_type_details), maybe(unify_compare),
+ maybe(list(sym_name_and_arity))).
make_maybe_where_details_2(IsSolverType, TypeIsAbstractNoncanonical,
RepresentationIs, InitialisationIs, GroundIs, AnyIs, CStoreIs,
- EqualityIs, ComparisonIs, _WhereEnd, WhereTerm) = MaybeSolverUC :-
+ EqualityIs, ComparisonIs, DirectArgIs, _WhereEnd, WhereTerm)
+ = MaybeWhereDetails :-
(
TypeIsAbstractNoncanonical = yes(_),
% rafe: XXX I think this is wrong. There isn't a problem with having
@@ -971,10 +1088,11 @@ make_maybe_where_details_2(IsSolverType, TypeIsAbstractNoncanonical,
AnyIs = maybe.no,
EqualityIs = maybe.no,
ComparisonIs = maybe.no,
- CStoreIs = maybe.no
+ CStoreIs = maybe.no,
+ DirectArgIs = maybe.no
->
- MaybeSolverUC =
- ok2(no, yes(abstract_noncanonical_type(IsSolverType)))
+ MaybeWhereDetails =
+ ok3(no, yes(abstract_noncanonical_type(IsSolverType)), no)
;
Pieces = [words("Error:"),
quote("where type_is_abstract_noncanonical"),
@@ -982,13 +1100,22 @@ make_maybe_where_details_2(IsSolverType, TypeIsAbstractNoncanonical,
words("attributes."), nl],
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(WhereTerm), [always(Pieces)])]),
- MaybeSolverUC = error2([Spec])
+ MaybeWhereDetails = error3([Spec])
)
;
TypeIsAbstractNoncanonical = maybe.no,
(
IsSolverType = solver_type,
(
+ DirectArgIs = yes(_)
+ ->
+ Pieces = [words("Error: solver type definitions cannot have"),
+ quote("direct_arg"), words("attributes."), nl],
+ Spec = error_spec(severity_error, phase_term_to_parse_tree,
+ [simple_msg(get_term_context(WhereTerm),
+ [always(Pieces)])]),
+ MaybeWhereDetails = error3([Spec])
+ ;
RepresentationIs = yes(RepnType),
InitialisationIs = MaybeInitialisation,
GroundIs = MaybeGroundInst,
@@ -1034,7 +1161,8 @@ make_maybe_where_details_2(IsSolverType, TypeIsAbstractNoncanonical,
MaybeUnifyCompare = yes(unify_compare(
MaybeEqPred, MaybeCmpPred))
),
- MaybeSolverUC = ok2(MaybeSolverTypeDetails, MaybeUnifyCompare)
+ MaybeWhereDetails = ok3(MaybeSolverTypeDetails,
+ MaybeUnifyCompare, no)
;
RepresentationIs = no
->
@@ -1043,7 +1171,7 @@ make_maybe_where_details_2(IsSolverType, TypeIsAbstractNoncanonical,
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(WhereTerm),
[always(Pieces)])]),
- MaybeSolverUC = error2([Spec])
+ MaybeWhereDetails = error3([Spec])
;
unexpected($module, $pred, "make_maybe_where_details_2: " ++
"shouldn't have reached this point! (1)")
@@ -1063,16 +1191,27 @@ make_maybe_where_details_2(IsSolverType, TypeIsAbstractNoncanonical,
Spec = error_spec(severity_error, phase_term_to_parse_tree,
[simple_msg(get_term_context(WhereTerm),
[always(Pieces)])]),
- MaybeSolverUC = error2([Spec])
+ MaybeWhereDetails = error3([Spec])
;
- EqualityIs = MaybeEqPred,
- ComparisonIs = MaybeCmpPred,
- MaybeSolverUC =
- ok2(no, yes(unify_compare(MaybeEqPred, MaybeCmpPred)))
+ MaybeUC = maybe_unify_compare(EqualityIs, ComparisonIs),
+ MaybeWhereDetails = ok3(no, MaybeUC, DirectArgIs)
)
)
).
+:- func maybe_unify_compare(maybe(equality_pred), maybe(comparison_pred))
+ = maybe(unify_compare).
+
+maybe_unify_compare(MaybeEqPred, MaybeCmpPred) =
+ (
+ MaybeEqPred = no,
+ MaybeCmpPred = no
+ ->
+ no
+ ;
+ yes(unify_compare(MaybeEqPred, MaybeCmpPred))
+ ).
+
%-----------------------------------------------------------------------------%
%
% Predicates useful for parsing several kinds of type definitions.
diff --git a/compiler/prog_item.m b/compiler/prog_item.m
index 212d9c5..c1a3211 100644
--- a/compiler/prog_item.m
+++ b/compiler/prog_item.m
@@ -617,20 +617,12 @@
% Predname, Arity, Fact file name.
)
- % Type representation pragmas.
-
; pragma_reserve_tag(
restag_type :: sym_name,
restag_arity :: arity
% Typename, Arity
)
- ; pragma_direct_arg(
- darg_type :: sym_name,
- darg_arity :: arity,
- darg_ctors :: list(sym_name_and_arity)
- )
-
% Purity pragmas.
; pragma_promise_equivalent_clauses(
diff --git a/compiler/recompilation.check.m b/compiler/recompilation.check.m
index 6e213ea..384dac5 100644
--- a/compiler/recompilation.check.m
+++ b/compiler/recompilation.check.m
@@ -1173,7 +1173,7 @@ check_type_defn_ambiguity_with_functor(NeedQualifier, TypeCtor, TypeDefn,
; TypeDefn = parse_tree_solver_type(_, _)
)
;
- TypeDefn = parse_tree_du_type(Ctors, _),
+ TypeDefn = parse_tree_du_type(Ctors, _, _),
list.foldl(check_functor_ambiguities(NeedQualifier, TypeCtor), Ctors,
!Info)
).
diff --git a/compiler/recompilation.usage.m b/compiler/recompilation.usage.m
index 9ed3671..944ab16 100644
--- a/compiler/recompilation.usage.m
+++ b/compiler/recompilation.usage.m
@@ -1060,7 +1060,7 @@ find_items_used_by_type_and_mode(TypeAndMode, !Info) :-
:- pred find_items_used_by_type_body(hlds_type_body::in,
recompilation_usage_info::in, recompilation_usage_info::out) is det.
-find_items_used_by_type_body(hlds_du_type(Ctors, _, _, _, _, _, _, _),
+find_items_used_by_type_body(hlds_du_type(Ctors, _, _, _, _, _, _, _, _),
!Info) :-
list.foldl(find_items_used_by_ctor, Ctors, !Info).
find_items_used_by_type_body(hlds_eqv_type(Type), !Info) :-
diff --git a/compiler/recompilation.version.m b/compiler/recompilation.version.m
index 5362304..f66abb8 100644
--- a/compiler/recompilation.version.m
+++ b/compiler/recompilation.version.m
@@ -293,7 +293,7 @@ gather_items_2(Item, !Section, !Info) :-
% procedure.
BodyItem = Item
;
- Body = parse_tree_du_type(_, _),
+ Body = parse_tree_du_type(_, _, _),
NameItemTypeDefn = item_type_defn_info(VarSet, Name, Args,
parse_tree_abstract_type(non_solver_type), Cond, Context,
SeqNum),
@@ -612,7 +612,6 @@ is_pred_pragma(PragmaType, MaybePredOrFuncId) :-
; PragmaType = pragma_foreign_enum(_, _, _, _)
; PragmaType = pragma_source_file(_)
; PragmaType = pragma_reserve_tag(_, _)
- ; PragmaType = pragma_direct_arg(_, _, _)
; PragmaType = pragma_require_feature_set(_)
),
MaybePredOrFuncId = no
diff --git a/compiler/simplify.m b/compiler/simplify.m
index 874030e..3ff04a9 100644
--- a/compiler/simplify.m
+++ b/compiler/simplify.m
@@ -1777,7 +1777,7 @@ warn_switch_for_ite_cond(ModuleInfo, VarTypes, Cond, !CondCanSwitch) :-
can_switch_on_type(TypeBody) = CanSwitchOnType :-
(
TypeBody = hlds_du_type(_Ctors, _TagValues, _CheaperTagTest,
- DuTypeKind, _UserEq, _ReservedTag, _ReservedAddr,
+ DuTypeKind, _UserEq, _DirectArgCtors, _ReservedTag, _ReservedAddr,
_MaybeForeignType),
% We don't care about _UserEq, since the unification with *any* functor
% of the type indicates that we are deconstructing the physical
diff --git a/compiler/structure_reuse.direct.choose_reuse.m b/compiler/structure_reuse.direct.choose_reuse.m
index 92b21c8..9f3f259 100644
--- a/compiler/structure_reuse.direct.choose_reuse.m
+++ b/compiler/structure_reuse.direct.choose_reuse.m
@@ -1045,7 +1045,7 @@ has_secondary_tag(ModuleInfo, VarTypes, Var, ConsId, SecondaryTag) :-
(
map.lookup(VarTypes, Var, Type),
type_to_type_defn_body(ModuleInfo, Type, TypeBody),
- TypeBody = hlds_du_type(_, ConsTagValues, _, _, _, _, _, _),
+ TypeBody = hlds_du_type(_, ConsTagValues, _, _, _, _, _, _, _),
map.search(ConsTagValues, ConsId, ConsTag),
MaybeSecondaryTag = get_secondary_tag(ConsTag),
MaybeSecondaryTag = yes(_)
diff --git a/compiler/switch_util.m b/compiler/switch_util.m
index c689c01..14a3935 100644
--- a/compiler/switch_util.m
+++ b/compiler/switch_util.m
@@ -587,7 +587,7 @@ type_range(ModuleInfo, TypeCtorCat, Type, Min, Max, NumValues) :-
lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
(
- TypeBody = hlds_du_type(_, ConsTable, _, _, _, _, _, _),
+ TypeBody = hlds_du_type(_, ConsTable, _, _, _, _, _, _, _),
map.count(ConsTable, TypeRange),
Max = TypeRange - 1
;
@@ -1061,7 +1061,7 @@ get_ptag_counts(Type, ModuleInfo, MaxPrimary, PtagCountMap) :-
lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
(
- TypeBody = hlds_du_type(_, ConsTable, _, _, _, _, _, _),
+ TypeBody = hlds_du_type(_, ConsTable, _, _, _, _, _, _, _),
map.to_assoc_list(ConsTable, ConsList),
assoc_list.values(ConsList, TagList)
;
diff --git a/compiler/term_norm.m b/compiler/term_norm.m
index ac9377f..9d5ef6d 100644
--- a/compiler/term_norm.m
+++ b/compiler/term_norm.m
@@ -146,7 +146,7 @@ find_weights(ModuleInfo, Weights) :-
find_weights_for_type(TypeCtor - TypeDefn, !Weights) :-
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
(
- TypeBody = hlds_du_type(Constructors, _, _, _, _, _, _, _),
+ TypeBody = hlds_du_type(Constructors, _, _, _, _, _, _, _, _),
hlds_data.get_type_defn_tparams(TypeDefn, TypeParams),
list.foldl(find_weights_for_cons(TypeCtor, TypeParams),
Constructors, !Weights)
diff --git a/compiler/type_ctor_info.m b/compiler/type_ctor_info.m
index f9a1abb..02100c9 100644
--- a/compiler/type_ctor_info.m
+++ b/compiler/type_ctor_info.m
@@ -371,8 +371,8 @@ construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :-
Details = tcd_eqv(MaybePseudoTypeInfo)
;
TypeBody = hlds_du_type(Ctors, ConsTagMap, _CheaperTagTest,
- DuTypeKind, MaybeUserEqComp, ReservedTag, ReservedAddr,
- _IsForeignType),
+ DuTypeKind, MaybeUserEqComp, _MaybeDirectArgCtors,
+ ReservedTag, ReservedAddr, _IsForeignType),
(
MaybeUserEqComp = yes(_),
EqualityAxioms = user_defined
@@ -407,7 +407,7 @@ construct_type_ctor_info(TypeCtorGenInfo, ModuleInfo, RttiData) :-
some [!Flags] (
!:Flags = set.init,
(
- TypeBody = hlds_du_type(_, _, _, _, _, BodyReservedTag, _, _),
+ TypeBody = hlds_du_type(_, _, _, _, _, _, BodyReservedTag, _, _),
set.insert(kind_of_du_flag, !Flags),
(
BodyReservedTag = uses_reserved_tag,
diff --git a/compiler/type_util.m b/compiler/type_util.m
index 8573608..c193b30 100644
--- a/compiler/type_util.m
+++ b/compiler/type_util.m
@@ -421,7 +421,7 @@ type_body_has_user_defined_equality_pred(ModuleInfo, TypeBody, UserEqComp) :-
module_info_get_globals(ModuleInfo, Globals),
globals.get_target(Globals, Target),
(
- TypeBody = hlds_du_type(_, _, _, _, _, _, _, _),
+ TypeBody = hlds_du_type(_, _, _, _, _, _, _, _, _),
(
TypeBody ^ du_type_is_foreign_type = yes(ForeignTypeBody),
have_foreign_type_for_backend(Target, ForeignTypeBody, yes)
@@ -489,7 +489,7 @@ type_body_definitely_has_no_user_defined_equality_pred(ModuleInfo, Type,
module_info_get_globals(ModuleInfo, Globals),
globals.get_target(Globals, Target),
(
- TypeBody = hlds_du_type(_, _, _, _, _, _, _, _),
+ TypeBody = hlds_du_type(_, _, _, _, _, _, _, _, _),
(
TypeBody ^ du_type_is_foreign_type = yes(ForeignTypeBody),
have_foreign_type_for_backend(Target, ForeignTypeBody, yes)
@@ -641,7 +641,7 @@ check_dummy_type_2(ModuleInfo, Type, CoveredTypes) = IsDummy :-
( search_type_ctor_defn(TypeTable, TypeCtor, TypeDefn)->
get_type_defn_body(TypeDefn, TypeBody),
(
- TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _),
+ TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _, _),
(
DuTypeKind = du_type_kind_direct_dummy,
IsDummy = is_dummy_type
@@ -685,7 +685,7 @@ type_ctor_has_hand_defined_rtti(Type, Body) :-
; Name = "typeclass_info"
; Name = "base_typeclass_info"
),
- \+ ( Body = hlds_du_type(_, _, _, _, _, _, _, yes(_))
+ \+ ( Body = hlds_du_type(_, _, _, _, _, _, _, _, yes(_))
; Body = hlds_foreign_type(_)
; Body = hlds_solver_type(_, _)
).
@@ -780,7 +780,7 @@ classify_type_ctor(ModuleInfo, TypeCtor) = TypeCategory :-
lookup_type_ctor_defn(TypeTable, TypeCtor, TypeDefn),
hlds_data.get_type_defn_body(TypeDefn, TypeBody),
(
- TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _),
+ TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _, _),
(
DuTypeKind = du_type_kind_mercury_enum,
TypeCategory = ctor_cat_enum(cat_enum_mercury)
@@ -818,7 +818,7 @@ classify_type_defn_body(TypeBody) = TypeCategory :-
% already done that.
(
- TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _),
+ TypeBody = hlds_du_type(_, _, _, DuTypeKind, _, _, _, _, _),
(
DuTypeKind = du_type_kind_mercury_enum,
TypeCategory = ctor_cat_enum(cat_enum_mercury)
diff --git a/compiler/unify_proc.m b/compiler/unify_proc.m
index 81d2a0a..a317f69 100644
--- a/compiler/unify_proc.m
+++ b/compiler/unify_proc.m
@@ -401,12 +401,14 @@ add_lazily_generated_unify_pred(TypeCtor, PredId, !ModuleInfo) :-
ConsId = tuple_cons(TupleArity),
map.from_assoc_list([ConsId - single_functor_tag], ConsTagValues),
UnifyPred = no,
+ DirectArgCtors = no,
DuTypeKind = du_type_kind_general,
ReservedTag = does_not_use_reserved_tag,
ReservedAddr = does_not_use_reserved_address,
IsForeign = no,
TypeBody = hlds_du_type([Ctor], ConsTagValues, no_cheaper_tag_test,
- DuTypeKind, UnifyPred, ReservedTag, ReservedAddr, IsForeign),
+ DuTypeKind, UnifyPred, DirectArgCtors, ReservedTag, ReservedAddr,
+ IsForeign),
construct_type(TypeCtor, TupleArgTypes, Type),
term.context_init(Context)
@@ -613,7 +615,7 @@ generate_initialise_proc_body(_Type, TypeBody, X, Context, Clause, !Info) :-
Goal = hlds_goal(Call, GoalInfo),
quantify_clause_body([X], Goal, Context, Clause, !Info)
;
- ( TypeBody = hlds_du_type(_, _, _, _, _, _, _, _)
+ ( TypeBody = hlds_du_type(_, _, _, _, _, _, _, _, _)
; TypeBody = hlds_foreign_type(_)
; TypeBody = hlds_abstract_type(_)
),
@@ -641,7 +643,7 @@ generate_unify_proc_body(Type, TypeBody, X, Y, Context, Clause, !Info) :-
Clause, !Info)
;
(
- TypeBody = hlds_du_type(Ctors, _, _, DuTypeKind, _, _, _, _),
+ TypeBody = hlds_du_type(Ctors, _, _, DuTypeKind, _, _, _, _, _),
(
( DuTypeKind = du_type_kind_mercury_enum
; DuTypeKind = du_type_kind_foreign_enum(_)
@@ -842,7 +844,7 @@ generate_index_proc_body(Type, TypeBody, X, Index, Context, Clause, !Info) :-
"trying to create index proc for non-canonical type")
;
(
- TypeBody = hlds_du_type(Ctors, _, _, DuTypeKind, _, _, _, _),
+ TypeBody = hlds_du_type(Ctors, _, _, DuTypeKind, _, _, _, _, _),
(
% For enum types, the generated comparison predicate performs
% an integer comparison, and does not call the type's index
@@ -914,7 +916,7 @@ generate_compare_proc_body(Type, TypeBody, Res, X, Y, Context, Clause,
Res, X, Y, Context, Clause, !Info)
;
(
- TypeBody = hlds_du_type(Ctors, _, _, DuTypeKind, _, _, _, _),
+ TypeBody = hlds_du_type(Ctors, _, _, DuTypeKind, _, _, _, _, _),
(
( DuTypeKind = du_type_kind_mercury_enum
; DuTypeKind = du_type_kind_foreign_enum(_)
diff --git a/compiler/unused_imports.m b/compiler/unused_imports.m
index 7d75bca..7950f6f 100644
--- a/compiler/unused_imports.m
+++ b/compiler/unused_imports.m
@@ -198,7 +198,7 @@ type_used_modules(_TypeCtor, TypeDefn, !UsedModules) :-
DefinedInThisModule = yes,
Visibility = item_visibility(ImportStatus),
(
- TypeBody = hlds_du_type(Ctors, _, _, _, _, _, _, _),
+ TypeBody = hlds_du_type(Ctors, _, _, _, _, _, _, _, _),
list.foldl(ctor_used_modules(Visibility), Ctors, !UsedModules)
;
TypeBody = hlds_eqv_type(EqvType),
diff --git a/compiler/xml_documentation.m b/compiler/xml_documentation.m
index 79e581d..6d71d58 100644
--- a/compiler/xml_documentation.m
+++ b/compiler/xml_documentation.m
@@ -372,7 +372,7 @@ type_documentation(C, type_ctor(TypeName, TypeArity), TypeDefn, !Xmls) :-
:- func type_xml_tag(hlds_type_body) = string.
-type_xml_tag(hlds_du_type(_, _, _, _, _, _, _, _)) = "du_type".
+type_xml_tag(hlds_du_type(_, _, _, _, _, _, _, _, _)) = "du_type".
type_xml_tag(hlds_eqv_type(_)) = "eqv_type".
type_xml_tag(hlds_foreign_type(_)) = "foreign_type".
type_xml_tag(hlds_solver_type(_, _)) = "solver_type".
@@ -386,7 +386,7 @@ type_param(TVarset, TVar) = Xml :-
:- func type_body(comments, tvarset, hlds_type_body) = list(xml).
-type_body(C, TVarset, hlds_du_type(Ctors, _, _, _, _, _, _, _)) =
+type_body(C, TVarset, hlds_du_type(Ctors, _, _, _, _, _, _, _, _)) =
[xml_list("constructors", constructor(C, TVarset), Ctors)].
type_body(_, TVarset, hlds_eqv_type(Type)) =
[elem("equivalent_type", [], [mer_type(TVarset, Type)])].
diff --git a/doc/reference_manual.texi b/doc/reference_manual.texi
index 0fa8398..a5bc2ea 100644
--- a/doc/reference_manual.texi
+++ b/doc/reference_manual.texi
@@ -2005,6 +2005,39 @@ Note that excessive overloading of constructors can slow down type checking
and can make the program confusing for human readers,
so overloading should not be over-used.
+ at c XXX The `where direct_arg' attribute is not documented because it requires
+ at c the user has a detailed understanding of the type representation, and
+ at c is very implementation specific. The following is for implementors.
+
+ at c Discriminated union type definitions may be followed by a
+ at c @samp{direct_arg} attribute of the following form:
+ at c
+ at c @example
+ at c where direct_arg is @var{ctors}
+ at c @end example
+ at c
+ at c @noindent
+ at c where @var{ctors} is a list of @var{functor-name} / @var{functor-arity}.
+ at c The functor arities must always be one.
+ at c
+ at c The attribute notifies importing modules that each of the functors
+ at c listed is to be represented as a tagged pointer to its argument. The
+ at c argument type must be known, when compiling the module that the type is
+ at c defined in, to not require the use of the tag bits. The compiler will
+ at c emit an error message otherwise. The compiler will silently ignore
+ at c functors which require a secondary tag.
+ at c
+ at c The optimised type representation is usually only applied if the
+ at c argument type is defined in the interface section of the same module.
+ at c This attribute allows the programmer to also apply it when the argument
+ at c type is known to the defining module, but not necessarily modules which
+ at c import the top-level type.
+ at c
+ at c Ideally, the @samp{direct_arg} attribute would be automatically
+ at c generated when making an interface file, so the user would never need to
+ at c write it manually. At this time, the compiler does not have enough
+ at c information when making interface files.
+
@node Equivalence types
@subsection Equivalence types
@@ -9508,11 +9541,6 @@ extensions to the Mercury language:
@c implementation-specific...
@c * Reserved tag:: Support for Herbrand constraint solvers.
- at c XXX The `direct arg' pragma is not documented because it requires the user
- at c has a detailed understanding of the type representation, and is very
- at c implementation specific.
- at c * Direct argument:: A type representation optimisation.
-
@node Fact tables
@section Fact tables
@@ -10056,39 +10084,6 @@ function then the compiler will quit with an error message.
@c compiler option will have any useful effect if the @samp{--high-level-data}
@c option is used (e.g. for the .NET or Java back-ends).
- at c XXX The `direct arg' pragma is not documented because it requires the user
- at c has a detailed understanding of the type representation, and is very
- at c implementation specific.
- at c @node Direct argument
- at c @section Direct argument
- at c
- at c The @samp{direct_arg} pragma declaration has the following form:
- at c
- at c @example
- at c :- pragma direct_arg(@var{type-name} / @var{type-arity}, @var{ctors}).
- at c @end example
- at c
- at c @noindent
- at c where @var{ctors} is a list of @var{functor-name} / @var{functor-arity}.
- at c The type must be defined in the module containing the pragma, and the
- at c functor arities must always be one.
- at c
- at c The pragma will become part of the module's interface, notifying importing
- at c modules that each of the functors listed is to be represented as a tagged
- at c pointer to its argument. The argument type must be known, when compiling the
- at c module containing the @samp{:- pragma direct_arg}, to not require the use of
- at c the tag bits. The compiler will emit an error message otherwise.
- at c The compiler will silently ignore functors which require a secondary tag.
- at c
- at c The optimised type representation is usually only applied if the argument type
- at c is defined in the interface section of the same module. This pragma allows the
- at c programmer to also apply it when the argument type is known to the defining
- at c module, but not necessarily modules which import the top-level type.
- at c
- at c Ideally, @samp{:- pragma direct_arg} would be automatically generated.
- at c It is required because the compiler does not have enough information when
- at c making the interface file for a module.
-
@c XXX TO DO!
@c @node Compile-time garbage collection
@c @section Compile-time garbage collection
diff --git a/library/private_builtin.m b/library/private_builtin.m
index a4024a7..f624ffc 100644
--- a/library/private_builtin.m
+++ b/library/private_builtin.m
@@ -1,7 +1,7 @@
%---------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et wm=0 tw=0
%---------------------------------------------------------------------------%
-% Copyright (C) 1994-2007, 2010 The University of Melbourne.
+% Copyright (C) 1994-2007, 2011 The University of Melbourne.
% This file may only be copied under the terms of the GNU Library General
% Public License - see the file COPYING.LIB in the Mercury distribution.
%---------------------------------------------------------------------------%
diff --git a/runtime/mercury_deconstruct.c b/runtime/mercury_deconstruct.c
index 46c386f..d66ec7c 100644
--- a/runtime/mercury_deconstruct.c
+++ b/runtime/mercury_deconstruct.c
@@ -2,7 +2,7 @@
** vim:ts=4 sw=4 expandtab
*/
/*
-** Copyright (C) 2002-2007 The University of Melbourne.
+** Copyright (C) 2002-2007, 2011 The University of Melbourne.
** This file may only be copied under the terms of the GNU Library General
** Public License - see the file COPYING.LIB in the Mercury distribution.
*/
diff --git a/runtime/mercury_deep_copy_body.h b/runtime/mercury_deep_copy_body.h
index aedc9db..5adb1ac 100644
--- a/runtime/mercury_deep_copy_body.h
+++ b/runtime/mercury_deep_copy_body.h
@@ -2,7 +2,7 @@
** vim: ts=4 sw=4 expandtab
*/
/*
-** Copyright (C) 1997-2005, 2007 The University of Melbourne.
+** Copyright (C) 1997-2005, 2007, 2011 The University of Melbourne.
** This file may only be copied under the terms of the GNU Library General
** Public License - see the file COPYING.LIB in the Mercury distribution.
*/
diff --git a/runtime/mercury_table_type_body.h b/runtime/mercury_table_type_body.h
index 5ec130b..8b94e69 100644
--- a/runtime/mercury_table_type_body.h
+++ b/runtime/mercury_table_type_body.h
@@ -2,7 +2,7 @@
** vim: ts=4 sw=4 expandtab
*/
/*
-** Copyright (C) 2006-2007 The University of Melbourne.
+** Copyright (C) 2006-2007, 2011 The University of Melbourne.
** This file may only be copied under the terms of the GNU Library General
** Public License - see the file COPYING.LIB in the Mercury distribution.
*/
diff --git a/runtime/mercury_term_size.c b/runtime/mercury_term_size.c
index df2ecbf..78d558f 100644
--- a/runtime/mercury_term_size.c
+++ b/runtime/mercury_term_size.c
@@ -2,7 +2,7 @@
** vim:ts=4 sw=4 expandtab
*/
/*
-** Copyright (C) 2003-2005, 2007, 2009 The University of Melbourne.
+** Copyright (C) 2003-2005, 2007, 2009, 2011 The University of Melbourne.
** This file may only be copied under the terms of the GNU Library General
** Public License - see the file COPYING.LIB in the Mercury distribution.
*/
diff --git a/runtime/mercury_unify_compare_body.h b/runtime/mercury_unify_compare_body.h
index fa5eccc..08c3941 100644
--- a/runtime/mercury_unify_compare_body.h
+++ b/runtime/mercury_unify_compare_body.h
@@ -2,7 +2,7 @@
** vim:ts=4 sw=4 expandtab
*/
/*
-** Copyright (C) 2000-2005, 2007 The University of Melbourne.
+** Copyright (C) 2000-2005, 2007, 2011 The University of Melbourne.
** This file may only be copied under the terms of the GNU Library General
** Public License - see the file COPYING.LIB in the Mercury distribution.
*/
diff --git a/tests/debugger/Mmakefile b/tests/debugger/Mmakefile
index 0aa945c..50d3544 100644
--- a/tests/debugger/Mmakefile
+++ b/tests/debugger/Mmakefile
@@ -7,6 +7,7 @@ THIS_DIR = debugger
RETRY_PROGS = \
all_solutions \
browser_test \
+ chooser_tag_test \
io_tab_goto \
lambda_expr \
mdb_command_test \
@@ -25,7 +26,6 @@ NONRETRY_PROGS = \
class_decl \
cmd_quote \
cond \
- chooser_tag_test \
debugger_regs \
dice \
double_print \
diff --git a/tests/debugger/chooser_tag_test.exp b/tests/debugger/chooser_tag_test.exp
index 8824a76..361cc33 100644
--- a/tests/debugger/chooser_tag_test.exp
+++ b/tests/debugger/chooser_tag_test.exp
@@ -1,10 +1,8 @@
- E1: C1 CALL pred chooser_tag_test.main/2-0 (det) chooser_tag_test.m:53
+ E1: C1 CALL pred chooser_tag_test.main/2-0 (det) chooser_tag_test.m:54
mdb> mdb> echo on
Command echo enabled.
mdb> context none
Contexts will not be printed.
-mdb> table_io start
-I/O tabling started.
mdb> break test_wraps
0: + stop interface pred chooser_tag_test.test_wraps/2-0 (det)
mdb> continue
@@ -39,6 +37,9 @@ mdb> condition HeadVar__1 = xb(b(12, _))
0: + stop interface pred chooser_tag_test.unwrap_b/2-0 (semidet)
HeadVar__1 = xb(b(12, _))
mdb> continue
+test_wrap_a: A0 = a(10, 11), X = xa(a(10, 11)), A1 = a(10, 11)
+test_wrap_a: A0 = a(12, 20), X = xa(a(12, 20)), A1 = a(12, 20)
+test_wrap_b: B0 = b(10, "eleven"), X = xb(b(10, "eleven")), B1 = b(10, "eleven")
E6: C4 CALL pred chooser_tag_test.unwrap_b/2-0 (semidet)
mdb> print
unwrap_b(xb(b(12, "twenty")), _)
@@ -46,5 +47,8 @@ mdb> delete *
0: E stop interface pred chooser_tag_test.unwrap_b/2-0 (semidet)
HeadVar__1 = xb(b(12, _))
mdb> continue
+test_wrap_b: B0 = b(12, "twenty"), X = xb(b(12, "twenty")), B1 = b(12, "twenty")
+test_wrap_c: C0 = c("ten", 11), X = xc(c("ten", 11)), C1 = c("ten", 11)
+test_wrap_c: C0 = c("twelve", 20), X = xc(c("twelve", 20)), C1 = c("twelve", 20)
solns for 30 = [xa(a(30, 30)), xa(a(31, 31)), xb(b(30, "b2")), xb(b(31, "b2")), xc(c("c1", 30)), xc(c("c1", 31))]
solns for 130 = []
diff --git a/tests/debugger/chooser_tag_test.inp b/tests/debugger/chooser_tag_test.inp
index 8b9786d..1788179 100644
--- a/tests/debugger/chooser_tag_test.inp
+++ b/tests/debugger/chooser_tag_test.inp
@@ -1,7 +1,6 @@
register --quiet
echo on
context none
-table_io start
break test_wraps
continue
finish
diff --git a/tests/debugger/chooser_tag_test.m b/tests/debugger/chooser_tag_test.m
index e7334f1..2ca0649 100644
--- a/tests/debugger/chooser_tag_test.m
+++ b/tests/debugger/chooser_tag_test.m
@@ -39,6 +39,7 @@
:- import_module int.
:- import_module list.
+:- import_module maybe.
:- import_module solutions.
:- import_module string.
@@ -65,15 +66,22 @@ test_wraps(!IO) :-
:- pred test_wrap_a(a::in, io::di, io::uo) is det.
test_wrap_a(A0, !IO) :-
+ wrap_a(A0, X),
+ ( unwrap_a(X, A1_Prime) ->
+ MaybeA1 = yes(A1_Prime)
+ ;
+ MaybeA1 = no
+ ),
io.write_string("test_wrap_a: A0 = ", !IO),
io.write(A0, !IO),
io.write_string(", X = ", !IO),
- wrap_a(A0, X),
io.write(X, !IO),
io.write_string(", A1 = ", !IO),
- ( unwrap_a(X, A1) ->
+ (
+ MaybeA1 = yes(A1),
io.write(A1, !IO)
;
+ MaybeA1 = no,
io.write_string("unwrap failed", !IO)
),
io.nl(!IO).
@@ -81,15 +89,22 @@ test_wrap_a(A0, !IO) :-
:- pred test_wrap_b(b::in, io::di, io::uo) is det.
test_wrap_b(B0, !IO) :-
+ wrap_b(B0, X),
+ ( unwrap_b(X, B1_Prime) ->
+ MaybeB1 = yes(B1_Prime)
+ ;
+ MaybeB1 = no
+ ),
io.write_string("test_wrap_b: B0 = ", !IO),
io.write(B0, !IO),
io.write_string(", X = ", !IO),
- wrap_b(B0, X),
io.write(X, !IO),
io.write_string(", B1 = ", !IO),
- ( unwrap_b(X, B1) ->
+ (
+ MaybeB1 = yes(B1),
io.write(B1, !IO)
;
+ MaybeB1 = no,
io.write_string("unwrap failed", !IO)
),
io.nl(!IO).
@@ -97,15 +112,22 @@ test_wrap_b(B0, !IO) :-
:- pred test_wrap_c(c::in, io::di, io::uo) is det.
test_wrap_c(C0, !IO) :-
+ wrap_c(C0, X),
+ ( unwrap_c(X, C1_Prime) ->
+ MaybeC1 = yes(C1_Prime)
+ ;
+ MaybeC1 = no
+ ),
io.write_string("test_wrap_c: C0 = ", !IO),
io.write(C0, !IO),
io.write_string(", X = ", !IO),
- wrap_c(C0, X),
io.write(X, !IO),
io.write_string(", C1 = ", !IO),
- ( unwrap_c(X, C1) ->
+ (
+ MaybeC1 = yes(C1),
io.write(C1, !IO)
;
+ MaybeC1 = no,
io.write_string("unwrap failed", !IO)
),
io.nl(!IO).
diff --git a/tests/hard_coded/direct_arg_cyclic3.m b/tests/hard_coded/direct_arg_cyclic3.m
index a137cd8..2020433 100644
--- a/tests/hard_coded/direct_arg_cyclic3.m
+++ b/tests/hard_coded/direct_arg_cyclic3.m
@@ -6,6 +6,5 @@
:- type maybe_grapheme
---> no_grapheme
- ; yes_grapheme(grapheme).
-
-:- pragma direct_arg(maybe_grapheme/0, [yes_grapheme/1]).
+ ; yes_grapheme(grapheme)
+ where direct_arg is [yes_grapheme/1].
diff --git a/tests/hard_coded/direct_arg_parent.m b/tests/hard_coded/direct_arg_parent.m
index 41cf84e..87f8d66 100644
--- a/tests/hard_coded/direct_arg_parent.m
+++ b/tests/hard_coded/direct_arg_parent.m
@@ -19,9 +19,8 @@
:- type maybe_foo
---> no
; not_possible(foo)
- ; forced(foo).
-
- :- pragma direct_arg(maybe_foo/0, [forced/1]).
+ ; forced(foo)
+ where direct_arg is [forced/1].
%-----------------------------------------------------------------------------%
diff --git a/tests/invalid/Mmakefile b/tests/invalid/Mmakefile
index 3346004..3c21529 100644
--- a/tests/invalid/Mmakefile
+++ b/tests/invalid/Mmakefile
@@ -168,7 +168,6 @@ SINGLEMODULE= \
polymorphic_unification \
pragma_c_code_dup_var \
pragma_c_code_no_det \
- pragma_direct_arg_bad \
pragma_source_file \
predmode \
prog_io_erroneous \
@@ -252,6 +251,8 @@ SINGLEMODULE= \
user_eq_dummy \
uu_type \
vars_in_wrong_places \
+ where_direct_arg \
+ where_direct_arg2 \
with_type \
zinc2mer_lib
diff --git a/tests/invalid/pragma_direct_arg_bad.err_exp b/tests/invalid/pragma_direct_arg_bad.err_exp
deleted file mode 100644
index 158a877..0000000
--- a/tests/invalid/pragma_direct_arg_bad.err_exp
+++ /dev/null
@@ -1,29 +0,0 @@
-pragma_direct_arg_bad.m:024: In `pragma direct_arg' declaration for
-pragma_direct_arg_bad.m:024: `pragma_direct_arg_bad.example'/0:
-pragma_direct_arg_bad.m:024: `pragma_direct_arg_bad.zero'/0 cannot be
-pragma_direct_arg_bad.m:024: represented as a direct pointer to its sole
-pragma_direct_arg_bad.m:024: argument.
-pragma_direct_arg_bad.m:024: `pragma_direct_arg_bad.two'/2 cannot be
-pragma_direct_arg_bad.m:024: represented as a direct pointer to its sole
-pragma_direct_arg_bad.m:024: argument.
-pragma_direct_arg_bad.m:024: `pragma_direct_arg_bad.string'/1 cannot be
-pragma_direct_arg_bad.m:024: represented as a direct pointer to its sole
-pragma_direct_arg_bad.m:024: argument.
-pragma_direct_arg_bad.m:024: `pragma_direct_arg_bad.int'/1 cannot be
-pragma_direct_arg_bad.m:024: represented as a direct pointer to its sole
-pragma_direct_arg_bad.m:024: argument.
-pragma_direct_arg_bad.m:024: `pragma_direct_arg_bad.nonexistent'/1 does not
-pragma_direct_arg_bad.m:024: match any constructor.
-pragma_direct_arg_bad.m:036: In `pragma direct_arg' declaration for
-pragma_direct_arg_bad.m:036: `nonexistent'/0:
-pragma_direct_arg_bad.m:036: error: undefined type `nonexistent'/0.
-pragma_direct_arg_bad.m:036: In pragma:
-pragma_direct_arg_bad.m:036: error: undefined type `nonexistent'/0.
-pragma_direct_arg_bad.m:038: In `pragma direct_arg' declaration for
-pragma_direct_arg_bad.m:038: `maybe.maybe'/1:
-pragma_direct_arg_bad.m:038: error: `pragma direct_arg' declaration must have
-pragma_direct_arg_bad.m:038: the same visibility as the type definition.
-pragma_direct_arg_bad.m:045: In `pragma direct_arg' declaration for
-pragma_direct_arg_bad.m:045: `pragma_direct_arg_bad.example2'/0:
-pragma_direct_arg_bad.m:045: error: `pragma direct_arg' declaration must have
-pragma_direct_arg_bad.m:045: the same visibility as the type definition.
diff --git a/tests/invalid/pragma_direct_arg_bad.m b/tests/invalid/pragma_direct_arg_bad.m
deleted file mode 100644
index 4a6e722..0000000
--- a/tests/invalid/pragma_direct_arg_bad.m
+++ /dev/null
@@ -1,54 +0,0 @@
-%-----------------------------------------------------------------------------%
-
-:- module pragma_direct_arg_bad.
-:- interface.
-
-:- import_module maybe.
-
-:- type example
- ---> zero
- ; two(int, int)
- ; string(string)
- ; int(int)
- ; struct(struct)
- ; eqv(eqv_struct)
- ; tuple({int, int}).
-
-:- type example2
- ---> nil
- ; struct(struct).
-
-:- type struct ---> struct(int, int).
-:- type eqv_struct == struct.
-
-:- pragma direct_arg(example/0,
- [
- zero/0,
- two/2,
- string/1,
- int/1,
- struct/1,
- eqv/1,
- tuple/1,
- nonexistent/1
- ]).
-
-:- pragma direct_arg(nonexistent/0, [nonexistent/1]).
-
-:- pragma direct_arg(maybe/1, [yes/1]).
-
-%-----------------------------------------------------------------------------%
-%-----------------------------------------------------------------------------%
-
-:- implementation.
-
-:- pragma direct_arg(example2/0, [struct/1]).
-
-:- type example3
- ---> nil
- ; struct(struct).
-
-:- pragma direct_arg(example3/0, [struct/1]).
-
-%-----------------------------------------------------------------------------%
-% vim: ft=mercury ts=4 sts=4 sw=4 et
diff --git a/tests/invalid/where_direct_arg.err_exp b/tests/invalid/where_direct_arg.err_exp
new file mode 100644
index 0000000..91e8017
--- /dev/null
+++ b/tests/invalid/where_direct_arg.err_exp
@@ -0,0 +1,9 @@
+where_direct_arg.m:012: Error: the `direct_arg' attribute contains a function
+where_direct_arg.m:012: symbol whose arity is not 1.
+where_direct_arg.m:012: Error: the `direct_arg' attribute lists the function
+where_direct_arg.m:012: symbol `where_direct_arg.nonexistent'/1 which is not
+where_direct_arg.m:012: in the type definition.
+where_direct_arg.m:016: Error: only solver types can be defined by a `where'
+where_direct_arg.m:016: block alone.
+where_direct_arg.m:018: Error: solver type definitions cannot have `direct_arg'
+where_direct_arg.m:018: attributes.
diff --git a/tests/invalid/where_direct_arg.m b/tests/invalid/where_direct_arg.m
new file mode 100644
index 0000000..c07ed95
--- /dev/null
+++ b/tests/invalid/where_direct_arg.m
@@ -0,0 +1,23 @@
+%-----------------------------------------------------------------------------%
+
+:- module where_direct_arg.
+:- interface.
+
+:- type bad_example
+ ---> zero
+ ; two(int, int)
+ ; string(string)
+ ; int(int)
+ ; tuple({int, int})
+ where direct_arg is [
+ zero/0, two/2, string/1, int/1, tuple/1, nonexistent/1
+ ].
+
+:- type bad_example2 where direct_arg is [struct/1].
+
+:- solver type bad_example3 where direct_arg is [].
+
+:- type dummy ---> dummy.
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
diff --git a/tests/invalid/where_direct_arg2.err_exp b/tests/invalid/where_direct_arg2.err_exp
new file mode 100644
index 0000000..abc790c
--- /dev/null
+++ b/tests/invalid/where_direct_arg2.err_exp
@@ -0,0 +1,10 @@
+where_direct_arg2.m:009: Error: `where_direct_arg2.string'/1 cannot be
+where_direct_arg2.m:009: represented as a direct pointer to its sole
+where_direct_arg2.m:009: argument.
+where_direct_arg2.m:010: Error: `where_direct_arg2.int'/1 cannot be represented
+where_direct_arg2.m:010: as a direct pointer to its sole argument.
+where_direct_arg2.m:014: Error: `where_direct_arg2.enum'/1 cannot be
+where_direct_arg2.m:014: represented as a direct pointer to its sole
+where_direct_arg2.m:014: argument.
+where_direct_arg2.m:036: Error: `direct_arg' attribute is not applicable to
+where_direct_arg2.m:036: foreign types.
diff --git a/tests/invalid/where_direct_arg2.m b/tests/invalid/where_direct_arg2.m
new file mode 100644
index 0000000..715d2fa
--- /dev/null
+++ b/tests/invalid/where_direct_arg2.m
@@ -0,0 +1,39 @@
+%-----------------------------------------------------------------------------%
+
+:- module where_direct_arg2.
+:- interface.
+
+:- type bad_example
+ ---> zero
+ ; two(int, int)
+ ; string(string)
+ ; int(int)
+ ; struct(struct)
+ ; eqv(eqv_struct)
+ ; tuple({int, int})
+ ; enum(enum)
+ where direct_arg is [string/1, int/1, struct/1, eqv/1, tuple/1, enum/1].
+
+:- type struct ---> struct(int, int).
+:- type eqv_struct == struct.
+
+:- type enum
+ ---> enum1
+ ; enum2
+ ; enum3.
+
+%-----------------------------------------------------------------------------%
+%-----------------------------------------------------------------------------%
+
+:- implementation.
+
+:- type good_example
+ ---> nil
+ ; struct(struct)
+ where direct_arg is [struct/1].
+
+:- type foreign ---> foreign.
+:- pragma foreign_type("C", foreign, "int") where direct_arg is [].
+
+%-----------------------------------------------------------------------------%
+% vim: ft=mercury ts=4 sts=4 sw=4 et
--------------------------------------------------------------------------
mercury-reviews mailing list
Post messages to: mercury-reviews at csse.unimelb.edu.au
Administrative Queries: owner-mercury-reviews at csse.unimelb.edu.au
Subscriptions: mercury-reviews-request at csse.unimelb.edu.au
--------------------------------------------------------------------------
More information about the reviews
mailing list