[m-rev.] diff: fix bug#436: unknown constructors in foreign_enum
Julien Fischer
jfischer at opturion.com
Wed May 3 09:42:43 AEST 2017
Fix bug #436.
Fix a bug in foreign_enum pragmas where the compiler was not checking if
symbols appearing in the third argument were actually constructors of the type
that is the subject of the pragma. Such symbols would be silently ignored.
compiler/add_foreign_enum.m:
Generate an error message if we encounter symbols in the third argument
of a foreign_enum pragma that are not constructors of the type.
tests/invalid/Mmakefile:
tests/invalid/bug436.{m,err_exp}:
Add a regression test for bug #436.
tests/invalid/fe_unmapped_nonverbose.{m,err_exp}:
tests/invalid/fe_unmapped_verbose.{m,err_exp}:
Fix a misspelled constructor name in these tests.
Julien.
diff --git a/compiler/add_foreign_enum.m b/compiler/add_foreign_enum.m
index 68ef56327..3ad4c31a6 100644
--- a/compiler/add_foreign_enum.m
+++ b/compiler/add_foreign_enum.m
@@ -1,7 +1,7 @@
%-----------------------------------------------------------------------------%
% vim: ft=mercury ts=4 sw=4 et
%-----------------------------------------------------------------------------%
-% Copyright (C) 2015 The Mercury team.
+% Copyright (C) 2015-2017 The Mercury team.
% This file may only be copied under the terms of the GNU General
% Public License - see the file COPYING in the Mercury distribution.
%-----------------------------------------------------------------------------%
@@ -37,6 +37,7 @@
:- import_module map.
:- import_module pair.
:- import_module require.
+:- import_module set_tree234.
:- import_module string.
%-----------------------------------------------------------------------------%
@@ -428,9 +429,10 @@ add_pragma_foreign_enum(FEInfo, PragmaStatus, Context, !ModuleInfo, !Specs) :-
% XXX We should also check that this type is not
% the subject of a reserved tag pragma.
DuTypeKind = du_type_kind_foreign_enum(Lang),
+ list.foldl(gather_ctor_name, Ctors, set_tree234.init, CtorNameSet),
build_foreign_enum_tag_map(Context, ContextPieces,
- TypeName, ForeignTagValues, MaybeForeignTagMap,
- !Specs),
+ CtorNameSet, TypeName, ForeignTagValues,
+ MaybeForeignTagMap, !Specs),
( if
LangForForeignEnums = Lang,
MaybeForeignTagMap = yes(ForeignTagMap)
@@ -516,13 +518,21 @@ add_pragma_foreign_enum(FEInfo, PragmaStatus, Context, !ModuleInfo, !Specs) :-
!:Specs = [Spec | !.Specs]
).
+:- pred gather_ctor_name(constructor::in,
+ set_tree234(string)::in, set_tree234(string)::out) is det.
+
+gather_ctor_name(Constructor, !CtorNameSet) :-
+ CtorSymName = Constructor ^ cons_name,
+ Name = unqualify_name(CtorSymName),
+ set_tree234.insert(Name, !CtorNameSet).
+
:- pred build_foreign_enum_tag_map(prog_context::in, format_components::in,
- sym_name::in, assoc_list(sym_name, string)::in,
+ set_tree234(string)::in, sym_name::in, assoc_list(sym_name, string)::in,
maybe(map(sym_name, string))::out,
list(error_spec)::in, list(error_spec)::out) is det.
-build_foreign_enum_tag_map(Context, ContextPieces, TypeName, ForeignTagValues0,
- MaybeForeignTagMap, !Specs) :-
+build_foreign_enum_tag_map(Context, ContextPieces, CtorNameSet, TypeName,
+ ForeignTagValues0, MaybeForeignTagMap, !Specs) :-
(
TypeName = qualified(TypeModuleName, _)
;
@@ -530,10 +540,18 @@ build_foreign_enum_tag_map(Context, ContextPieces, TypeName, ForeignTagValues0,
unexpected($module, $pred,
"unqualified type name while processing foreign tags.")
),
- list.map_foldl(fixup_foreign_tag_val_qualification(TypeModuleName),
- ForeignTagValues0, ForeignTagValues1, [], BadCtors),
+ list.map_foldl2(fixup_foreign_tag_val_qualification(CtorNameSet, TypeModuleName),
+ ForeignTagValues0, ForeignTagValues1, [], BadCtors, [], UnknownCtors),
(
+ UnknownCtors = []
+ ;
+ UnknownCtors = [_ | _],
+ add_unknown_ctors_error(Context, ContextPieces, UnknownCtors, !Specs)
+ ),
+ ( if
BadCtors = [],
+ UnknownCtors = []
+ then
( if bimap.from_assoc_list(ForeignTagValues1, ForeignTagValues) then
ForeignTagMap = ForeignTagValues ^ forward_map,
MaybeForeignTagMap = yes(ForeignTagMap)
@@ -541,8 +559,7 @@ build_foreign_enum_tag_map(Context, ContextPieces, TypeName, ForeignTagValues0,
add_foreign_enum_bijection_error(Context, ContextPieces, !Specs),
MaybeForeignTagMap = no
)
- ;
- BadCtors = [_ | _],
+ else
MaybeForeignTagMap = no
).
@@ -551,12 +568,14 @@ build_foreign_enum_tag_map(Context, ContextPieces, TypeName, ForeignTagValues0,
%
% XXX module_qual.m should really be doing this rather than add_pragma.m.
%
-:- pred fixup_foreign_tag_val_qualification(module_name::in,
+:- pred fixup_foreign_tag_val_qualification(set_tree234(string)::in,
+ module_name::in,
pair(sym_name, string)::in, pair(sym_name, string)::out,
+ list(sym_name)::in, list(sym_name)::out,
list(sym_name)::in, list(sym_name)::out) is det.
-fixup_foreign_tag_val_qualification(TypeModuleName, !NamesAndTags,
- !BadCtors) :-
+fixup_foreign_tag_val_qualification(CtorNameSet, TypeModuleName, !NamesAndTags,
+ !BadCtors, !UnknownCtors) :-
!.NamesAndTags = CtorSymName0 - ForeignTag,
(
CtorSymName0 = unqualified(Name),
@@ -570,6 +589,11 @@ fixup_foreign_tag_val_qualification(TypeModuleName, !NamesAndTags,
CtorSymName = CtorSymName0
)
),
+ ( if CtorNameSet `set_tree234.contains` Name then
+ true
+ else
+ !:UnknownCtors = [CtorSymName0 | !.UnknownCtors]
+ ),
!:NamesAndTags = CtorSymName - ForeignTag.
% For a given target language work out which language's foreign_enum
@@ -659,6 +683,21 @@ unqual_ctor_to_format_component(SymName) = [unqual_sym_name(SymName)].
%-----------------------------------------------------------------------------%
+:- pred add_unknown_ctors_error(prog_context::in, format_components::in,
+ list(sym_name)::in, list(error_spec)::in, list(error_spec)::out) is det.
+
+add_unknown_ctors_error(Context, ContextPieces, Ctors, !Specs) :-
+ IsOrAre = choose_number(Ctors, "symbol is not a constructor",
+ "symbols are not constructors"),
+ ErrorPieces = [words("error: the following"), words(IsOrAre),
+ words("of the type:"), nl_indent_delta(2)] ++
+ unqual_ctors_to_line_pieces(Ctors, [suffix(".")]),
+ Msg = simple_msg(Context, [always(ContextPieces ++ ErrorPieces)]),
+ Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
+ !:Specs = [Spec | !.Specs].
+
+%-----------------------------------------------------------------------------%
+
:- pred add_foreign_enum_bijection_error(prog_context::in,
format_components::in, list(error_spec)::in, list(error_spec)::out) is det.
@@ -681,7 +720,7 @@ add_foreign_enum_pragma_in_interface_error(Context, TypeName, TypeArity,
ErrorPieces = [words("Error: "),
pragma_decl("foreign_enum"), words("declaration for"),
qual_sym_name_and_arity(sym_name_arity(TypeName, TypeArity)),
- words("in module interface."), nl ],
+ words("in module interface."), nl],
Msg = simple_msg(Context, [always(ErrorPieces)]),
Spec = error_spec(severity_error, phase_parse_tree_to_hlds, [Msg]),
list.cons(Spec, !Specs).
diff --git a/tests/invalid/Mmakefile b/tests/invalid/Mmakefile
index 509cc5263..95a2b39b4 100644
--- a/tests/invalid/Mmakefile
+++ b/tests/invalid/Mmakefile
@@ -86,6 +86,7 @@ SINGLEMODULE= \
bug278 \
bug363 \
bug415 \
+ bug436 \
bug83 \
builtin_int \
builtin_proc \
diff --git a/tests/invalid/bug436.err_exp b/tests/invalid/bug436.err_exp
index e69de29bb..71f29774f 100644
--- a/tests/invalid/bug436.err_exp
+++ b/tests/invalid/bug436.err_exp
@@ -0,0 +1,7 @@
+bug436.m:017: In `:- pragma foreign_enum' declaration for type `bug436.foo'/0:
+bug436.m:017: error: the following symbol is not a constructor of the type:
+bug436.m:017: `bar'.
+bug436.m:023: In `:- pragma foreign_enum' declaration for type `bug436.bar'/0:
+bug436.m:023: error: the following symbols are not constructors of the type:
+bug436.m:023: `baaz2',
+bug436.m:023: `baaz1'.
diff --git a/tests/invalid/bug436.m b/tests/invalid/bug436.m
index e69de29bb..0f6533849 100644
--- a/tests/invalid/bug436.m
+++ b/tests/invalid/bug436.m
@@ -0,0 +1,28 @@
+% Check that all of the symbols in the third argument of a foreign_enum pragma
+% are data constructors of the type referred to by the foreign_enum pragma.
+
+:- module bug436.
+:- interface.
+
+:- type foo
+ ---> foo1
+ ; foo2.
+
+:- type bar
+ ---> bar1
+ ; bar2.
+
+:- implementation.
+
+:- pragma foreign_enum("C", foo/0, [
+ foo1 - "1",
+ foo2 - "2",
+ bar - "3"
+]).
+
+:- pragma foreign_enum("C", bar/0, [
+ bar1 - "1",
+ bar2 - "2",
+ baaz1 - "3",
+ baaz2 - "4"
+]).
diff --git a/tests/invalid/fe_unmapped_nonverbose.err_exp b/tests/invalid/fe_unmapped_nonverbose.err_exp
index 768349138..aae9fe974 100644
--- a/tests/invalid/fe_unmapped_nonverbose.err_exp
+++ b/tests/invalid/fe_unmapped_nonverbose.err_exp
@@ -21,7 +21,6 @@ fe_unmapped_nonverbose.m:085: In `:- pragma foreign_enum' declaration for type
fe_unmapped_nonverbose.m:085: `fe_unmapped_nonverbose.shade_of_white'/0:
fe_unmapped_nonverbose.m:085: error: the following constructors do not have a
fe_unmapped_nonverbose.m:085: foreign value:
-fe_unmapped_nonverbose.m:085: `anitque_white',
fe_unmapped_nonverbose.m:085: `blond',
fe_unmapped_nonverbose.m:085: `cornsilk',
fe_unmapped_nonverbose.m:085: `cosmic_latte',
@@ -30,6 +29,7 @@ fe_unmapped_nonverbose.m:085: `eggshell',
fe_unmapped_nonverbose.m:085: `floral_white',
fe_unmapped_nonverbose.m:085: `ghost_white',
fe_unmapped_nonverbose.m:085: `honeydew',
-fe_unmapped_nonverbose.m:085: `isabelline', ...
-fe_unmapped_nonverbose.m:085: and 17 more.
+fe_unmapped_nonverbose.m:085: `isabelline',
+fe_unmapped_nonverbose.m:085: `ivory', ...
+fe_unmapped_nonverbose.m:085: and 16 more.
For more information, recompile with `-E'.
diff --git a/tests/invalid/fe_unmapped_nonverbose.m b/tests/invalid/fe_unmapped_nonverbose.m
index 5d4c89a98..62eb8eaf7 100644
--- a/tests/invalid/fe_unmapped_nonverbose.m
+++ b/tests/invalid/fe_unmapped_nonverbose.m
@@ -36,7 +36,7 @@
% Test for > 10 constructors missing foreign values.
:- type shade_of_white
---> anti_flash_white
- ; anitque_white
+ ; antique_white
; beige
; blond
; cornsilk
diff --git a/tests/invalid/fe_unmapped_verbose.err_exp b/tests/invalid/fe_unmapped_verbose.err_exp
index f42991dc4..fd5e78f85 100644
--- a/tests/invalid/fe_unmapped_verbose.err_exp
+++ b/tests/invalid/fe_unmapped_verbose.err_exp
@@ -2,7 +2,6 @@ fe_unmapped_verbose.m:050: In `:- pragma foreign_enum' declaration for type
fe_unmapped_verbose.m:050: `fe_unmapped_verbose.shade_of_white'/0:
fe_unmapped_verbose.m:050: error: the following constructors do not have a
fe_unmapped_verbose.m:050: foreign value:
-fe_unmapped_verbose.m:050: `anitque_white',
fe_unmapped_verbose.m:050: `blond',
fe_unmapped_verbose.m:050: `cornsilk',
fe_unmapped_verbose.m:050: `cosmic_latte',
diff --git a/tests/invalid/fe_unmapped_verbose.m b/tests/invalid/fe_unmapped_verbose.m
index 30a48a9df..7d957f6df 100644
--- a/tests/invalid/fe_unmapped_verbose.m
+++ b/tests/invalid/fe_unmapped_verbose.m
@@ -13,7 +13,7 @@
%
:- type shade_of_white
---> anti_flash_white
- ; anitque_white
+ ; antique_white
; beige
; blond
; cornsilk
More information about the reviews
mailing list