[Ada] Handling of predicate type errors in generics
Arnaud Charlet
charlet@adacore.com
Fri Oct 22 15:00:00 GMT 2010
All errors in generics where improper use of generic actuals that
have predicates should generate program error exceptions and
warnings rather than errors. The following is updated output
from a test that includes these cases (compiled with -gnata12
-gnatj60 -gnatld7).
1. procedure Bad_Predicates is
2. -- This test should get compile-time errors
3.
4. type Color is
5. (Red, Orange, Yellow, Green,
6. Blue, Indigo, Violet);
7. subtype RGB is Color with
8. Predicate =>
9. RGB = Red or RGB in Green .. Blue;
10. subtype Other_Color is Color with
11. Predicate => Other_Color not in RGB;
12.
13. subtype Another_Color is Other_Color;
|
>>> info: "Another_Color" inherits predicate from
"Other_Color" at line 10
14.
15. type Bad_Array is array
16. (Another_Color range <>) of Character;
|
>>> subtype "Another_Color" has predicate, not
allowed as index subtype
17. -- ERROR: Subtype with predicate not
18. -- allowed as index subtype
19.
20. type OK_Array is array
21. (Color range <>) of Character;
22.
23. subtype Bad_Array_Subtype is
24. OK_Array (Another_Color);
|
>>> subtype "Another_Color" has predicate, not
allowed in index constraint
25. -- ERROR: Subtype with predicate not
26. -- allowed in index_constraint
27.
28. OK : constant OK_Array := (Color => 'x');
29.
30. Bad_Slice : constant OK_Array :=
31. OK (Another_Color);
|
>>> subtype "Another_Color" has predicate, not
allowed in slice
32. -- ERROR: Subtype with predicate not
33. -- allowed in slice
34.
35. protected type Prot is
36. entry Bad_Family
37. (Another_Color) (X : Integer);
|
>>> subtype "Another_Color" has predicate, not
allowed in entry family
38. -- ERROR: Subtype with predicate not
39. -- allowed in entry family
40. end Prot;
41.
42. protected body Prot is
43. entry Bad_Family (for J in Another_Color)
44. (X : Integer)
45. when True
46. is
47. begin null; end;
48. end Prot;
49.
50. -- Same set of checks in a generic
51.
52. generic
53. type Another_Color is (<>);
54. package T is
55. type Bad_Array is array
56. (Another_Color range <>) of Character;
57. -- ERROR: Subtype with predicate not
58. -- allowed as index subtype
59.
60. subtype Bad_Array_Subtype is
61. Bad_Array (Another_Color);
62. -- ERROR: Subtype with predicate not
63. -- allowed in index_constraint
64.
65. protected type Prot is
66. entry Bad_Family
67. (Another_Color) (X : Integer);
68. -- ERROR: Subtype with predicate not
69. -- allowed in entry family
70. end Prot;
71. end T;
72.
73. package body T is
74. protected body Prot is
75. entry Bad_Family (for J in Another_Color)
76. (X : Integer)
77. when True
78. is
79. begin null; end;
80. end Prot;
81. end;
82.
83. package TT is new T (Another_Color);
|
>>> warning: in instantiation at line 56, subtype
"Another_Color" has predicate, not allowed as
index subtype, Program_Error will be raised at
run time
>>> warning: in instantiation at line 61, subtype
"Another_Color" has predicate, not allowed in
index constraint, Program_Error will be raised
at run time
>>> warning: in instantiation at line 67, subtype
"Another_Color" has predicate, not allowed in
entry family, Program_Error will be raised at
run time
84.
85. begin
86. null;
87. end Bad_Predicates;
Tested on x86_64-pc-linux-gnu, committed on trunk
2010-10-22 Robert Dewar <dewar@adacore.com>
* sem_case.adb, sem_attr.adb (Bad_Predicated_Subtype_Use): Change order
of parameters.
* sem_ch13.adb (Build_Predicate_Function): Don't give inheritance
messages for generic actual subtypes.
* sem_ch9.adb, sem_res.adb, sem_util.adb, sem_util.ads, sem_ch3.adb
(Bad_Predicated_Subtype_Use): Use this procedure.
-------------- next part --------------
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 165828)
+++ sem_ch3.adb (working copy)
@@ -4429,11 +4429,9 @@ package body Sem_Ch3 is
-- Check error of subtype with predicate for index type
- if Has_Predicates (Etype (Index)) then
- Error_Msg_NE
- ("subtype& has predicate, not allowed as index subtype",
- Index, Etype (Index));
- end if;
+ Bad_Predicated_Subtype_Use
+ ("subtype& has predicate, not allowed as index subtype",
+ Index, Etype (Index));
-- Move to next index
@@ -11402,9 +11400,9 @@ package body Sem_Ch3 is
-- Check error of subtype with predicate in index constraint
- elsif Has_Predicates (Entity (S)) then
- Error_Msg_NE
- ("subtype& has predicate, not allowed in index consraint",
+ else
+ Bad_Predicated_Subtype_Use
+ ("subtype& has predicate, not allowed in index constraint",
S, Entity (S));
end if;
Index: sem_ch9.adb
===================================================================
--- sem_ch9.adb (revision 165805)
+++ sem_ch9.adb (working copy)
@@ -894,11 +894,9 @@ package body Sem_Ch9 is
-- Check subtype with predicate in entry family
- if Has_Predicates (Etype (D_Sdef)) then
- Error_Msg_NE
- ("subtype& has predicate, not allowed in entry family",
- D_Sdef, Etype (D_Sdef));
- end if;
+ Bad_Predicated_Subtype_Use
+ ("subtype& has predicate, not allowed in entry family",
+ D_Sdef, Etype (D_Sdef));
end if;
-- Decorate Def_Id
Index: sem_util.adb
===================================================================
--- sem_util.adb (revision 165828)
+++ sem_util.adb (working copy)
@@ -334,21 +334,21 @@ package body Sem_Util is
--------------------------------
procedure Bad_Predicated_Subtype_Use
- (Typ : Entity_Id;
+ (Msg : String;
N : Node_Id;
- Msg : String)
+ Typ : Entity_Id)
is
begin
if Has_Predicates (Typ) then
if Is_Generic_Actual_Type (Typ) then
- Error_Msg_F (Msg & '?', Typ);
- Error_Msg_F ("\Program_Error will be raised at run time?", Typ);
+ Error_Msg_FE (Msg & '?', N, Typ);
+ Error_Msg_F ("\Program_Error will be raised at run time?", N);
Insert_Action (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Bad_Predicated_Generic_Type));
else
- Error_Msg_F (Msg, Typ);
+ Error_Msg_FE (Msg, N, Typ);
end if;
end if;
end Bad_Predicated_Subtype_Use;
Index: sem_util.ads
===================================================================
--- sem_util.ads (revision 165828)
+++ sem_util.ads (working copy)
@@ -94,18 +94,19 @@ package Sem_Util is
-- whether an error or warning is given.
procedure Bad_Predicated_Subtype_Use
- (Typ : Entity_Id;
+ (Msg : String;
N : Node_Id;
- Msg : String);
+ Typ : Entity_Id);
-- This is called when Typ, a predicated subtype, is used in a context
- -- which does not allow the use of a predicated subtype. Msg will be
- -- passed to Error_Msg_F to output an appropriate message. The caller
- -- should set up any insertions other than the & for the type itself.
- -- Note that if Typ is a generic actual type, then the message will be
- -- output as a warning, and a raise Program_Error is inserted using
- -- Insert_Action with node N as the insertion point. Node N also supplies
- -- the source location for construction of the raise node. If Typ is NOT a
- -- type with predicates this call has no effect.
+ -- which does not allow the use of a predicated subtype. Msg is passed
+ -- to Error_Msg_FE to output an appropriate message using N as the
+ -- location, and Typ as the entity. The caller must set up any insertions
+ -- other than the & for the type itself. Note that if Typ is a generic
+ -- actual type, then the message will be output as a warning, and a
+ -- raise Program_Error is inserted using Insert_Action with node N as
+ -- the insertion point. Node N also supplies the source location for
+ -- construction of the raise node. If Typ is NOT a type with predicates
+ -- this call has no effect.
function Build_Actual_Subtype
(T : Entity_Id;
Index: sem_res.adb
===================================================================
--- sem_res.adb (revision 165805)
+++ sem_res.adb (working copy)
@@ -8481,7 +8481,7 @@ package body Sem_Res is
-- Check bad use of type with predicates
if Has_Predicates (Etype (Drange)) then
- Error_Msg_NE
+ Bad_Predicated_Subtype_Use
("subtype& has predicate, not allowed in slice",
Drange, Etype (Drange));
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 165828)
+++ sem_attr.adb (working copy)
@@ -842,7 +842,7 @@ package body Sem_Attr is
if Comes_From_Source (N) then
Error_Msg_Name_1 := Aname;
Bad_Predicated_Subtype_Use
- (P_Type, N, "type& has predicates, attribute % not allowed");
+ ("type& has predicates, attribute % not allowed", N, P_Type);
end if;
end Bad_Attribute_For_Predicate;
Index: sem_case.adb
===================================================================
--- sem_case.adb (revision 165828)
+++ sem_case.adb (working copy)
@@ -866,9 +866,8 @@ package body Sem_Case is
or else No (Static_Predicate (E))
then
Bad_Predicated_Subtype_Use
- (E, N,
- "cannot use subtype& with non-static "
- & "predicate as case alternative");
+ ("cannot use subtype& with non-static "
+ & "predicate as case alternative", N, E);
-- Static predicate case
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 165828)
+++ sem_ch13.adb (working copy)
@@ -3888,9 +3888,13 @@ package body Sem_Ch13 is
Right_Opnd => Exp);
end if;
- -- Output info message on inheritance if required
+ -- Output info message on inheritance if required. Note we do not
+ -- give this information for generic actual types, since it is
+ -- unwelcome noise in that case in instantiations.
- if Opt.List_Inherited_Aspects then
+ if Opt.List_Inherited_Aspects
+ and then not Is_Generic_Actual_Type (Typ)
+ then
Error_Msg_Sloc := Sloc (Predicate_Function (T));
Error_Msg_Node_2 := T;
Error_Msg_N ("?info: & inherits predicate from & #", Typ);
@@ -4087,9 +4091,10 @@ package body Sem_Ch13 is
function Hi_Val (N : Node_Id) return Uint is
begin
- if Nkind (N) = N_Identifier then
+ if Is_Static_Expression (N) then
return Expr_Value (N);
else
+ pragma Assert (Nkind (N) = N_Range);
return Expr_Value (High_Bound (N));
end if;
end Hi_Val;
@@ -4100,9 +4105,10 @@ package body Sem_Ch13 is
function Lo_Val (N : Node_Id) return Uint is
begin
- if Nkind (N) = N_Identifier then
+ if Is_Static_Expression (N) then
return Expr_Value (N);
else
+ pragma Assert (Nkind (N) = N_Range);
return Expr_Value (Low_Bound (N));
end if;
end Lo_Val;
@@ -4124,19 +4130,19 @@ package body Sem_Ch13 is
SHi := Hi_Val (N);
end if;
- -- Identifier case
+ -- Static expression case
- else pragma Assert (Nkind (N) = N_Identifier);
+ elsif Is_Static_Expression (N) then
+ SLo := Lo_Val (N);
+ SHi := Hi_Val (N);
- -- Static expression case
+ -- Identifier (other than static expression) case
- if Is_Static_Expression (N) then
- SLo := Lo_Val (N);
- SHi := Hi_Val (N);
+ else pragma Assert (Nkind (N) = N_Identifier);
-- Type case
- elsif Is_Type (Entity (N)) then
+ if Is_Type (Entity (N)) then
-- If type has static predicates, process them recursively
More information about the Gcc-patches
mailing list