OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2011-12-02  Robert Dewar  <dewar@adacore.com>

	* sem_ch6.adb: Minor change in error message.

2011-12-02  Robert Dewar  <dewar@adacore.com>

	* sem_ch9.adb, prj-part.adb, vms_data.ads, sem_ch8.adb: Minor
	reformatting.

2011-12-02  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Constrain_Access): Enable on Ada 2005 mode the
	static check of the rule of general access types whose designated
	type has discriminants.
	* sem_util.ads, sem_util.adb
	(Effectively_Has_Constrained_Partial_View): New subprogram.
	(In_Generic_Body): New subprogram.
	* einfo.ads (Has_Constrained_Partial_View): Adding documentation.
	* sem_prag.adb (Inside_Generic_Body): Removed. Replaced by new
	subprogram In_Generic_Body.
	* exp_attr.adb, checks.adb, sem_attr.adb, exp_ch4.adb,
	sem_ch4.adb: In addition, this patch replaces the occurrences of
	Has_Constrained_Partial_View by
	Effectively_Has_Constrained_Partial_View.

2011-12-02  Matthew Heaney  <heaney@adacore.com>

	* a-comutr.adb, a-cimutr.adb, a-cbmutr.adb (Iterator): Rename
	Position component.
	(Finalize): Remove unnecessary access check.
	(First): Forward to First_Child.
	(Last): Forward to Last_Child.
	(Iterate): Check preconditions for parent node parameter.
	(Next): Forward to Next_Sibling.
	(Previous): Forward to Previous_Sibling.

From-SVN: r181914
This commit is contained in:
Arnaud Charlet 2011-12-02 15:45:58 +01:00
parent 35fae080e6
commit cc96a1b85c
19 changed files with 249 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
gcc/ada/ChangeLog
View File

@ -1,3 +1,39 @@
2011-12-02 Robert Dewar <dewar@adacore.com>
* sem_ch6.adb: Minor change in error message.
2011-12-02 Robert Dewar <dewar@adacore.com>
* sem_ch9.adb, prj-part.adb, vms_data.ads, sem_ch8.adb: Minor
reformatting.
2011-12-02 Javier Miranda <miranda@adacore.com>
* sem_ch3.adb (Constrain_Access): Enable on Ada 2005 mode the
static check of the rule of general access types whose designated
type has discriminants.
* sem_util.ads, sem_util.adb
(Effectively_Has_Constrained_Partial_View): New subprogram.
(In_Generic_Body): New subprogram.
* einfo.ads (Has_Constrained_Partial_View): Adding documentation.
* sem_prag.adb (Inside_Generic_Body): Removed. Replaced by new
subprogram In_Generic_Body.
* exp_attr.adb, checks.adb, sem_attr.adb, exp_ch4.adb,
sem_ch4.adb: In addition, this patch replaces the occurrences of
Has_Constrained_Partial_View by
Effectively_Has_Constrained_Partial_View.
2011-12-02 Matthew Heaney <heaney@adacore.com>
* a-comutr.adb, a-cimutr.adb, a-cbmutr.adb (Iterator): Rename
Position component.
(Finalize): Remove unnecessary access check.
(First): Forward to First_Child.
(Last): Forward to Last_Child.
(Iterate): Check preconditions for parent node parameter.
(Next): Forward to Next_Sibling.
(Previous): Forward to Previous_Sibling.
2011-12-02 Robert Dewar <dewar@adacore.com>
* a-coinve.adb, a-coorma.adb, freeze.adb, a-coorse.adb, a-comutr.adb,

61
gcc/ada/a-cbmutr.adb
View File

@ -55,7 +55,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is
Tree_Iterator_Interfaces.Reversible_Iterator with
record
Container : Tree_Access;
Position : Cursor;
Parent : Count_Type;
end record;
overriding procedure Finalize (Object : in out Child_Iterator);
@ -1243,25 +1243,15 @@ package body Ada.Containers.Bounded_Multiway_Trees is
--------------
procedure Finalize (Object : in out Iterator) is
B : Natural renames Object.Container.Busy;
begin
if Object.Container /= null then
declare
B : Natural renames Object.Container.all.Busy;
begin
B := B - 1;
end;
end if;
B := B - 1;
end Finalize;
procedure Finalize (Object : in out Child_Iterator) is
B : Natural renames Object.Container.Busy;
begin
if Object.Container /= null then
declare
B : Natural renames Object.Container.all.Busy;
begin
B := B - 1;
end;
end if;
B := B - 1;
end Finalize;
----------
@ -1294,10 +1284,8 @@ package body Ada.Containers.Bounded_Multiway_Trees is
end First;
function First (Object : Child_Iterator) return Cursor is
Node : Count_Type'Base;
begin
Node := Object.Container.Nodes (Object.Position.Node).Children.First;
return (Object.Container, Node);
return First_Child (Cursor'(Object.Container, Object.Parent));
end First;
-----------------
@ -1876,13 +1864,22 @@ package body Ada.Containers.Bounded_Multiway_Trees is
Parent : Cursor)
return Tree_Iterator_Interfaces.Reversible_Iterator'Class
is
B : Natural renames Container'Unrestricted_Access.all.Busy;
C : constant Tree_Access := Container'Unrestricted_Access;
B : Natural renames C.Busy;
begin
if Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
if Parent.Container /= C then
raise Program_Error with "Parent cursor not in container";
end if;
return It : constant Child_Iterator :=
Child_Iterator'(Limited_Controlled with
Container => Parent.Container,
Position => Parent)
Container => C,
Parent => Parent.Node)
do
B := B + 1;
end return;
@ -1965,7 +1962,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is
overriding function Last (Object : Child_Iterator) return Cursor is
begin
return Last_Child (Object.Position);
return Last_Child (Cursor'(Object.Container, Object.Parent));
end Last;
----------------
@ -2089,13 +2086,18 @@ package body Ada.Containers.Bounded_Multiway_Trees is
end if;
end Next;
function Next
overriding function Next
(Object : Child_Iterator;
Position : Cursor) return Cursor
is
begin
if Object.Container /= Position.Container then
raise Program_Error;
if Position.Container = null then
return No_Element;
end if;
if Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong tree";
end if;
return Next_Sibling (Position);
@ -2255,8 +2257,13 @@ package body Ada.Containers.Bounded_Multiway_Trees is
Position : Cursor) return Cursor
is
begin
if Object.Container /= Position.Container then
raise Program_Error;
if Position.Container = null then
return No_Element;
end if;
if Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong tree";
end if;
return Previous_Sibling (Position);

71
gcc/ada/a-cimutr.adb
View File

@ -45,7 +45,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Tree_Iterator_Interfaces.Reversible_Iterator with
record
Container : Tree_Access;
Position : Cursor;
Parent : Tree_Node_Access;
end record;
overriding procedure Finalize (Object : in out Iterator);
@ -937,25 +937,15 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
--------------
procedure Finalize (Object : in out Iterator) is
B : Natural renames Object.Container.Busy;
begin
if Object.Container /= null then
declare
B : Natural renames Object.Container.all.Busy;
begin
B := B - 1;
end;
end if;
B := B - 1;
end Finalize;
procedure Finalize (Object : in out Child_Iterator) is
B : Natural renames Object.Container.Busy;
begin
if Object.Container /= null then
declare
B : Natural renames Object.Container.all.Busy;
begin
B := B - 1;
end;
end if;
B := B - 1;
end Finalize;
----------
@ -988,7 +978,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
function First (Object : Child_Iterator) return Cursor is
begin
return (Object.Container, Object.Position.Node.Children.First);
return First_Child (Cursor'(Object.Container, Object.Parent));
end First;
-----------------
@ -1433,13 +1423,22 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
Parent : Cursor)
return Tree_Iterator_Interfaces.Reversible_Iterator'Class
is
B : Natural renames Container'Unrestricted_Access.all.Busy;
C : constant Tree_Access := Container'Unrestricted_Access;
B : Natural renames C.Busy;
begin
if Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
if Parent.Container /= C then
raise Program_Error with "Parent cursor not in container";
end if;
return It : constant Child_Iterator :=
Child_Iterator'(Limited_Controlled with
Container => Parent.Container,
Position => Parent)
Container => C,
Parent => Parent.Node)
do
B := B + 1;
end return;
@ -1516,7 +1515,7 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
overriding function Last (Object : Child_Iterator) return Cursor is
begin
return (Object.Container, Object.Position.Node.Children.Last);
return Last_Child (Cursor'(Object.Container, Object.Parent));
end Last;
----------------
@ -1646,18 +1645,20 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
end Next;
function Next
(Object : Child_Iterator;
(Object : Child_Iterator;
Position : Cursor) return Cursor
is
C : constant Tree_Node_Access := Position.Node.Next;
begin
if C = null then
if Position.Container = null then
return No_Element;
else
return (Object.Container, C);
end if;
if Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong tree";
end if;
return Next_Sibling (Position);
end Next;
------------------
@ -1787,18 +1788,20 @@ package body Ada.Containers.Indefinite_Multiway_Trees is
--------------
overriding function Previous
(Object : Child_Iterator;
(Object : Child_Iterator;
Position : Cursor) return Cursor
is
C : constant Tree_Node_Access := Position.Node.Prev;
begin
if C = null then
if Position.Container = null then
return No_Element;
else
return (Object.Container, C);
end if;
if Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong tree";
end if;
return Previous_Sibling (Position);
end Previous;
----------------------

64
gcc/ada/a-comutr.adb
View File

@ -46,7 +46,7 @@ package body Ada.Containers.Multiway_Trees is
Tree_Iterator_Interfaces.Reversible_Iterator with
record
Container : Tree_Access;
Position : Cursor;
Parent : Tree_Node_Access;
end record;
overriding procedure Finalize (Object : in out Iterator);
@ -910,25 +910,15 @@ package body Ada.Containers.Multiway_Trees is
--------------
procedure Finalize (Object : in out Iterator) is
B : Natural renames Object.Container.Busy;
begin
if Object.Container /= null then
declare
B : Natural renames Object.Container.all.Busy;
begin
B := B - 1;
end;
end if;
B := B - 1;
end Finalize;
procedure Finalize (Object : in out Child_Iterator) is
B : Natural renames Object.Container.Busy;
begin
if Object.Container /= null then
declare
B : Natural renames Object.Container.all.Busy;
begin
B := B - 1;
end;
end if;
B := B - 1;
end Finalize;
----------
@ -960,7 +950,7 @@ package body Ada.Containers.Multiway_Trees is
function First (Object : Child_Iterator) return Cursor is
begin
return (Object.Container, Object.Position.Node.Children.First);
return First_Child (Cursor'(Object.Container, Object.Parent));
end First;
-----------------
@ -1461,12 +1451,22 @@ package body Ada.Containers.Multiway_Trees is
Parent : Cursor)
return Tree_Iterator_Interfaces.Reversible_Iterator'Class
is
B : Natural renames Container'Unrestricted_Access.all.Busy;
C : constant Tree_Access := Container'Unrestricted_Access;
B : Natural renames C.Busy;
begin
if Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
end if;
if Parent.Container /= C then
raise Program_Error with "Parent cursor not in container";
end if;
return It : constant Child_Iterator :=
Child_Iterator'(Limited_Controlled with
Container => Parent.Container,
Position => Parent)
Container => C,
Parent => Parent.Node)
do
B := B + 1;
end return;
@ -1542,7 +1542,7 @@ package body Ada.Containers.Multiway_Trees is
overriding function Last (Object : Child_Iterator) return Cursor is
begin
return (Object.Container, Object.Position.Node.Children.Last);
return Last_Child (Cursor'(Object.Container, Object.Parent));
end Last;
----------------
@ -1675,9 +1675,17 @@ package body Ada.Containers.Multiway_Trees is
(Object : Child_Iterator;
Position : Cursor) return Cursor
is
C : constant Tree_Node_Access := Position.Node.Next;
begin
return (if C = null then No_Element else (Object.Container, C));
if Position.Container = null then
return No_Element;
end if;
if Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Next designates wrong tree";
end if;
return Next_Sibling (Position);
end Next;
------------------
@ -1807,9 +1815,17 @@ package body Ada.Containers.Multiway_Trees is
(Object : Child_Iterator;
Position : Cursor) return Cursor
is
C : constant Tree_Node_Access := Position.Node.Prev;
begin
return (if C = null then No_Element else (Object.Container, C));
if Position.Container = null then
return No_Element;
end if;
if Position.Container /= Object.Container then
raise Program_Error with
"Position cursor of Previous designates wrong tree";
end if;
return Previous_Sibling (Position);
end Previous;
----------------------

2
gcc/ada/checks.adb
View File

@ -1240,7 +1240,7 @@ package body Checks is
-- partial view that is constrained.
elsif Ada_Version >= Ada_2005
and then Has_Constrained_Partial_View (Base_Type (T_Typ))
and then Effectively_Has_Constrained_Partial_View (Base_Type (T_Typ))
then
return;
end if;

2
gcc/ada/einfo.ads
View File

@ -1420,6 +1420,8 @@ package Einfo is
-- type has no discriminants and the full view has discriminants with
-- defaults. In Ada 2005 heap-allocated objects of such types are not
-- constrained, and can change their discriminants with full assignment.
-- Sem_Util.Effectively_Has_Constrained_Partial_View should be always
-- used by callers, rather than reading this attribute directly.
-- Has_Contiguous_Rep (Flag181)
-- Present in enumeration types. True if the type as a representation

12
gcc/ada/exp_attr.adb
View File

@ -1559,10 +1559,11 @@ package body Exp_Attr is
return Is_Aliased_View (Obj)
and then
(Is_Constrained (Etype (Obj))
or else (Nkind (Obj) = N_Explicit_Dereference
and then
not Has_Constrained_Partial_View
(Base_Type (Etype (Obj)))));
or else
(Nkind (Obj) = N_Explicit_Dereference
and then
not Effectively_Has_Constrained_Partial_View
(Base_Type (Etype (Obj)))));
end if;
end Is_Constrained_Aliased_View;
@ -1684,7 +1685,8 @@ package body Exp_Attr is
or else
(Nkind (Pref) = N_Explicit_Dereference
and then
not Has_Constrained_Partial_View (Base_Type (Ptyp)))
not Effectively_Has_Constrained_Partial_View
(Base_Type (Ptyp)))
or else Is_Constrained (Underlying_Type (Ptyp))
or else (Ada_Version >= Ada_2012
and then Is_Tagged_Type (Underlying_Type (Ptyp))

5
gcc/ada/exp_ch4.adb
View File

@ -3903,8 +3903,9 @@ package body Exp_Ch4 is
and then Present (Discriminant_Default_Value
(First_Discriminant (Typ)))
and then (Ada_Version < Ada_2005
or else
not Has_Constrained_Partial_View (Typ))
or else not
Effectively_Has_Constrained_Partial_View
(Typ))
then
Typ := Build_Default_Subtype (Typ, N);
Set_Expression (N, New_Reference_To (Typ, Loc));

13
gcc/ada/prj-part.adb
View File

@ -374,6 +374,7 @@ package body Prj.Part is
declare
Org_With_Clause : Project_Node_Id := Extension_Withs;
New_With_Clause : Project_Node_Id := Empty_Node;
begin
while Present (Org_With_Clause) loop
New_With_Clause :=
@ -381,6 +382,7 @@ package body Prj.Part is
Org_With_Clause := Next_With_Clause_Of (Org_With_Clause, In_Tree);
end loop;
Set_First_With_Clause_Of (Virtual_Project, In_Tree, New_With_Clause);
end;
@ -442,10 +444,10 @@ package body Prj.Part is
With_Clause : Project_Node_Id := Empty_Node;
-- Node for a with clause of Proj
Imported : Project_Node_Id := Empty_Node;
Imported : Project_Node_Id := Empty_Node;
-- Node for a project imported by Proj
Extended : Project_Node_Id := Empty_Node;
Extended : Project_Node_Id := Empty_Node;
-- Node for the eventual project extended by Proj
Extends_All : Boolean := False;
@ -457,6 +459,7 @@ package body Prj.Part is
-- Nothing to do if Proj is undefined or has already been processed
if Present (Proj) and then not Processed_Hash.Get (Proj) then
-- Make sure the project will not be processed again
Processed_Hash.Set (Proj, True);
@ -478,7 +481,6 @@ package body Prj.Part is
-- Now check the projects it imports
With_Clause := First_With_Clause_Of (Proj, In_Tree);
while Present (With_Clause) loop
Imported := Project_Node_Of (With_Clause, In_Tree);
@ -488,6 +490,7 @@ package body Prj.Part is
end if;
if Extends_All then
-- This is an EXTENDS ALL project: prepend each of its WITH
-- clauses to the currently active list of extension deps.
@ -757,7 +760,7 @@ package body Prj.Part is
end if;
if Limited_With then
Scan (In_Tree); -- scan past LIMITED
Scan (In_Tree); -- past LIMITED
Expect (Tok_With, "WITH");
exit With_Loop when Token /= Tok_With;
end if;
@ -801,7 +804,7 @@ package body Prj.Part is
-- End of (possibly multiple) with clause;
Scan (In_Tree); -- past the semicolon
Scan (In_Tree); -- past semicolon
exit Comma_Loop;
elsif Token = Tok_Comma then

2
gcc/ada/sem_attr.adb
View File

@ -8632,7 +8632,7 @@ package body Sem_Attr is
and then
(Ada_Version < Ada_2005
or else
not Has_Constrained_Partial_View
not Effectively_Has_Constrained_Partial_View
(Designated_Type (Base_Type (Typ))))
then
null;

8
gcc/ada/sem_ch3.adb
View File

@ -10674,8 +10674,7 @@ package body Sem_Ch3 is
return;
end if;
if (Ekind (T) = E_General_Access_Type
or else Ada_Version >= Ada_2005)
if Ekind (T) = E_General_Access_Type
and then Has_Private_Declaration (Desig_Type)
and then In_Open_Scopes (Scope (Desig_Type))
and then Has_Discriminants (Desig_Type)
@ -10687,11 +10686,6 @@ package body Sem_Ch3 is
-- (Defect Report 8652/0008, Technical Corrigendum 1, checked
-- by ACATS B371001).
-- Rule updated for Ada 2005: the private type is said to have
-- a constrained partial view, given that objects of the type
-- can be declared. Furthermore, the rule applies to all access
-- types, unlike the rule concerning default discriminants.
declare
Pack : constant Node_Id :=
Unit_Declaration_Node (Scope (Desig_Type));

4
gcc/ada/sem_ch4.adb
View File

@ -576,10 +576,10 @@ package body Sem_Ch4 is
-- and the allocated object is unconstrained.
elsif Ada_Version >= Ada_2005
and then Has_Constrained_Partial_View (Base_Typ)
and then Effectively_Has_Constrained_Partial_View (Base_Typ)
then
Error_Msg_N
("constraint no allowed when type " &
("constraint not allowed when type " &
"has a constrained partial view", Constraint (E));
end if;

4
gcc/ada/sem_ch6.adb
View File

@ -1487,7 +1487,7 @@ package body Sem_Ch6 is
if Returns_Object then
if Nkind (N) = N_Extended_Return_Statement then
Error_Msg_N
("extended return statements cannot be nested; use `RETURN;`",
("extended return statement cannot be nested (use `RETURN;`)",
N);
-- Case of a simple return statement with a value inside extended
@ -1496,7 +1496,7 @@ package body Sem_Ch6 is
else
Error_Msg_N
("return nested in extended return statement cannot return " &
"value; use `RETURN;`", N);
"value (use `RETURN;`)", N);
end if;
end if;

3
gcc/ada/sem_ch8.adb
View File

@ -2850,7 +2850,8 @@ package body Sem_Ch8 is
end if;
-- Implementation-defined aspect specifications can appear in a renaming
-- declaration, but not language-defined ones.
-- declaration, but not language-defined ones. The call to procedure
-- Analyze_Aspect_Specifications will take care of this error check.
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, New_S);

4
gcc/ada/sem_ch9.adb
View File

@ -953,7 +953,7 @@ package body Sem_Ch9 is
Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef);
end if;
<<Skip_LB>>
<<Skip_LB>>
if Is_Generic_Type (Etype (D_Sdef))
or else In_Instance
or else Error_Posted (D_Sdef)
@ -979,7 +979,7 @@ package body Sem_Ch9 is
Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef);
end if;
<<Skip_UB>>
<<Skip_UB>>
null;
end;
end if;

30
gcc/ada/sem_prag.adb
View File

@ -1314,34 +1314,6 @@ package body Sem_Prag is
Subtype_Indication (Component_Definition (Comp));
Typ : constant Entity_Id := Etype (Comp_Id);
function Inside_Generic_Body (Id : Entity_Id) return Boolean;
-- Determine whether entity Id appears inside a generic body.
-- Shouldn't this be in a more general place ???
-------------------------
-- Inside_Generic_Body --
-------------------------
function Inside_Generic_Body (Id : Entity_Id) return Boolean is
S : Entity_Id;
begin
S := Id;
while Present (S) and then S /= Standard_Standard loop
if Ekind (S) = E_Generic_Package
and then In_Package_Body (S)
then
return True;
end if;
S := Scope (S);
end loop;
return False;
end Inside_Generic_Body;
-- Start of processing for Check_Component
begin
-- Ada 2005 (AI-216): If a component subtype is subject to a per-
-- object constraint, then the component type shall be an Unchecked_
@ -1363,7 +1335,7 @@ package body Sem_Prag is
-- the formal part of the generic unit.
elsif Ada_Version >= Ada_2012
and then Inside_Generic_Body (UU_Typ)
and then In_Generic_Body (UU_Typ)
and then In_Variant_Part
and then Is_Private_Type (Typ)
and then Is_Generic_Type (Typ)

52
gcc/ada/sem_util.adb
View File

@ -3039,6 +3039,24 @@ package body Sem_Util is
return Extra_Accessibility (Id);
end Effective_Extra_Accessibility;
----------------------------------------------
-- Effectively_Has_Constrained_Partial_View --
----------------------------------------------
function Effectively_Has_Constrained_Partial_View
(Typ : Entity_Id;
Scop : Entity_Id := Current_Scope) return Boolean is
begin
return Has_Constrained_Partial_View (Typ)
or else (In_Generic_Body (Scop)
and then Is_Generic_Type (Base_Type (Typ))
and then Is_Private_Type (Base_Type (Typ))
and then not Is_Tagged_Type (Typ)
and then not (Is_Array_Type (Typ)
and then not Is_Constrained (Typ))
and then Has_Discriminants (Typ));
end Effectively_Has_Constrained_Partial_View;
--------------------------
-- Enclosing_CPP_Parent --
--------------------------
@ -6088,6 +6106,38 @@ package body Sem_Util is
return False;
end Implements_Interface;
---------------------
-- In_Generic_Body --
---------------------
function In_Generic_Body (Id : Entity_Id) return Boolean is
S : Entity_Id := Id;
begin
while Present (S) and then S /= Standard_Standard loop
-- Generic package body
if Ekind (S) = E_Generic_Package
and then In_Package_Body (S)
then
return True;
-- Generic subprogram body
elsif Is_Subprogram (S)
and then Nkind (Unit_Declaration_Node (S))
= N_Generic_Subprogram_Declaration
then
return True;
end if;
S := Scope (S);
end loop;
return False;
end In_Generic_Body;
-----------------
-- In_Instance --
-----------------
@ -6945,7 +6995,7 @@ package body Sem_Util is
-- designated object is known to be constrained.
if Ekind (Prefix_Type) = E_Access_Type
and then not Has_Constrained_Partial_View
and then not Effectively_Has_Constrained_Partial_View
(Designated_Type (Prefix_Type))
then
return False;

11
gcc/ada/sem_util.ads
View File

@ -368,6 +368,14 @@ package Sem_Util is
-- Same as Einfo.Extra_Accessibility except thtat object renames
-- are looked through.
function Effectively_Has_Constrained_Partial_View
(Typ : Entity_Id;
Scop : Entity_Id := Current_Scope) return Boolean;
-- Return True if Typ has attribute Has_Constrained_Partial_View set to
-- True; in addition, within a generic body, return True if a subtype is
-- a descendant of an untagged generic formal private or derived type, and
-- the subtype is not an unconstrained array subtype (RM 3.3(23.10/3)).
function Enclosing_CPP_Parent (Typ : Entity_Id) return Entity_Id;
-- Returns the closest ancestor of Typ that is a CPP type.
@ -717,6 +725,9 @@ package Sem_Util is
Exclude_Parents : Boolean := False) return Boolean;
-- Returns true if the Typ_Ent implements interface Iface_Ent
function In_Generic_Body (Id : Entity_Id) return Boolean;
-- Determine whether entity Id appears inside a generic body
function In_Instance return Boolean;
-- Returns True if the current scope is within a generic instance

16
gcc/ada/vms_data.ads
View File

@ -6388,18 +6388,18 @@ package VMS_Data is
"-ntM";
-- /TYPE_CASING=name-option
--
-- Specify the casing of type and subtype. If not specified, the
-- casing of these names is defined by the NAME_CASING option.
-- 'name-option' may be one of:
-- Specify the casing of subtype names (including first subtypes from
-- type declarations). If not specified, the casing of these names is
-- defined by the NAME_CASING option. 'name-option' is one of:
--
-- AS_DECLARED Name casing for defining occurrences are
-- as they appear in the source file.
-- AS_DECLARED Names are cased as they appear in the declaration
-- in the source file.
--
-- LOWER_CASE Namess are in lower case.
-- LOWER_CASE Names are in lower case.
--
-- UPPER_CASE Namess are in upper case.
-- UPPER_CASE Names are in upper case.
--
-- MIXED_CASE Namess are in mixed case.
-- MIXED_CASE Names are in mixed case.
S_Pretty_Verbose : aliased constant S := "/VERBOSE " &
"-v";