This patch fixes a spurious error on an instantiation of an unbounded
container, when the element type is a private type with unknown discriminants,
derived from an array subtype with a predicate aspect.
The following must ocmpile quietly:
gcc -c gpr2-attribute.adb
---
package GPR2 is
subtype Name_Type is String
with Dynamic_Predicate => Name_Type'Length > 0;
end GPR2;
---
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
package GPR2.Attribute is
type Qualified_Name (<>) is private;
function Create (Name : Name_Type) return Qualified_Name;
private
type Qualified_Name is new Name_Type;
end GPR2.Attribute;
---
with Ada.Containers.Indefinite_Ordered_Maps;
package body GPR2.Attribute is
type Def is null record;
package Attribute_Definitions is new Ada.Containers.Indefinite_Ordered_Maps
(Qualified_Name, Def);
function Create (Name : Name_Type) return Qualified_Name is
begin
return Qualified_Name (Name);
end Create;
end GPR2.Attribute;
Tested on x86_64-pc-linux-gnu, committed on trunk
2016-06-22 Ed Schonberg <schonb...@adacore.com>
* einfo.ads, einfo.adb (Is_Actual_Subtype): New flag, defined
on subtypes that are created within subprogram bodies to handle
unconstrained composite formals.
* checks.adb (Apply_Predicate_Check): Do not generate a check on
an object whose type is an actual subtype.
* sem_ch6.adb (Set_Actual_Subtypes): Do not generate an
actual subtype for a formal whose base type is private.
Set Is_Actual_Subtype on corresponding entity after analyzing
its declaration.
Index: einfo.adb
===================================================================
--- einfo.adb (revision 237680)
+++ einfo.adb (working copy)
@@ -607,8 +607,8 @@
-- Has_Inherited_Invariants Flag291
-- Is_Partial_Invariant_Procedure Flag292
+ -- Is_Actual_Subtype Flag293
- -- (unused) Flag293
-- (unused) Flag294
-- (unused) Flag295
-- (unused) Flag296
@@ -2014,6 +2014,12 @@
return Flag69 (Id);
end Is_Access_Constant;
+ function Is_Actual_Subtype (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag293 (Id);
+ end Is_Actual_Subtype;
+
function Is_Ada_2005_Only (Id : E) return B is
begin
return Flag185 (Id);
@@ -5036,6 +5042,12 @@
Set_Flag69 (Id, V);
end Set_Is_Access_Constant;
+ procedure Set_Is_Actual_Subtype (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag293 (Id, V);
+ end Set_Is_Actual_Subtype;
+
procedure Set_Is_Ada_2005_Only (Id : E; V : B := True) is
begin
Set_Flag185 (Id, V);
@@ -9186,6 +9198,7 @@
W ("Is_Abstract_Subprogram", Flag19 (Id));
W ("Is_Abstract_Type", Flag146 (Id));
W ("Is_Access_Constant", Flag69 (Id));
+ W ("Is_Actual_Subtype", Flag293 (Id));
W ("Is_Ada_2005_Only", Flag185 (Id));
W ("Is_Ada_2012_Only", Flag199 (Id));
W ("Is_Aliased", Flag15 (Id));
Index: einfo.ads
===================================================================
--- einfo.ads (revision 237680)
+++ einfo.ads (working copy)
@@ -2232,6 +2232,10 @@
-- Is_Access_Type (synthesized)
-- Applies to all entities, true for access types and subtypes
+-- Is_Actual_Subtype (Flag293)
+-- Defined on all types, true for the generated constrained subtypes
+-- that are built for unconstrained composite actuals.
+
-- Is_Ada_2005_Only (Flag185)
-- Defined in all entities, true if a valid pragma Ada_05 or Ada_2005
-- applies to the entity which specifically names the entity, indicating
@@ -7017,6 +7021,7 @@
function Is_Abstract_Subprogram (Id : E) return B;
function Is_Abstract_Type (Id : E) return B;
function Is_Access_Constant (Id : E) return B;
+ function Is_Actual_Subtype (Id : E) return B;
function Is_Ada_2005_Only (Id : E) return B;
function Is_Ada_2012_Only (Id : E) return B;
function Is_Aliased (Id : E) return B;
@@ -7689,6 +7694,7 @@
procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True);
procedure Set_Is_Abstract_Type (Id : E; V : B := True);
procedure Set_Is_Access_Constant (Id : E; V : B := True);
+ procedure Set_Is_Actual_Subtype (Id : E; V : B := True);
procedure Set_Is_Ada_2005_Only (Id : E; V : B := True);
procedure Set_Is_Ada_2012_Only (Id : E; V : B := True);
procedure Set_Is_Aliased (Id : E; V : B := True);
@@ -8477,6 +8483,7 @@
pragma Inline (Is_Abstract_Subprogram);
pragma Inline (Is_Abstract_Type);
pragma Inline (Is_Access_Constant);
+ pragma Inline (Is_Actual_Subtype);
pragma Inline (Is_Access_Protected_Subprogram_Type);
pragma Inline (Is_Access_Subprogram_Type);
pragma Inline (Is_Access_Type);
@@ -8989,6 +8996,7 @@
pragma Inline (Set_Is_Abstract_Subprogram);
pragma Inline (Set_Is_Abstract_Type);
pragma Inline (Set_Is_Access_Constant);
+ pragma Inline (Set_Is_Actual_Subtype);
pragma Inline (Set_Is_Ada_2005_Only);
pragma Inline (Set_Is_Ada_2012_Only);
pragma Inline (Set_Is_Aliased);
Index: checks.adb
===================================================================
--- checks.adb (revision 237691)
+++ checks.adb (working copy)
@@ -2650,7 +2650,17 @@
Check_Expression_Against_Static_Predicate (N, Typ);
- if Is_Entity_Name (N) then
+ if not Expander_Active then
+ return;
+ end if;
+
+ -- For an entity of the type, generate a call to the predicate
+ -- function, unless its type is an actual subtype, which is not
+ -- visible outside of the enclosing subprogram.
+
+ if Is_Entity_Name (N)
+ and then not Is_Actual_Subtype (Typ)
+ then
Insert_Action (N,
Make_Predicate_Check
(Typ, New_Occurrence_Of (Entity (N), Sloc (N))));
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb (revision 237688)
+++ sem_ch6.adb (working copy)
@@ -11226,9 +11226,12 @@
-- At this stage we have an unconstrained type that may need an
-- actual subtype. For sure the actual subtype is needed if we have
- -- an unconstrained array type.
+ -- an unconstrained array type. However, in an instance, the type
+ -- may appear as a subtype of the full view, while the actual is
+ -- in fact private (in which case no actual subtype is needed) so
+ -- check the kind of the base type.
- elsif Is_Array_Type (T) then
+ elsif Is_Array_Type (Base_Type (T)) then
AS_Needed := True;
-- The only other case needing an actual subtype is an unconstrained
@@ -11299,6 +11302,7 @@
-- therefore needs no constraint checks.
Analyze (Decl, Suppress => All_Checks);
+ Set_Is_Actual_Subtype (Defining_Identifier (Decl));
-- We need to freeze manually the generated type when it is
-- inserted anywhere else than in a declarative part.
