===================================================================
@@ -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;
===================================================================
@@ -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
===================================================================
@@ -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;
===================================================================
@@ -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;
===================================================================
@@ -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));
===================================================================
@@ -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;
===================================================================
@@ -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
===================================================================
@@ -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
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.