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,
a-coormu.adb, a-convec.adb: Minor reformatting.
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);
--------------
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;
----------
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;
-----------------
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;
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;
----------------
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);
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);
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);
--------------
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;
----------
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;
-----------------
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;
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;
----------------
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;
+ end if;
- else
- return (Object.Container, C);
+ 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;
------------------
--------------
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;
+ end if;
- else
- return (Object.Container, C);
+ 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;
----------------------
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);
--------------
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;
----------
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;
-----------------
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;
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;
----------------
(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;
------------------
(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;
----------------------
-- 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;
-- 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
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;
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))
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));
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 :=
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;
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;
-- 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);
-- 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);
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.
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;
-- 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
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;
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)
-- (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));
-- 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;
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
else
Error_Msg_N
("return nested in extended return statement cannot return " &
- "value; use `RETURN;`", N);
+ "value (use `RETURN;`)", N);
end if;
end if;
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);
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)
Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef);
end if;
- <<Skip_UB>>
+ <<Skip_UB>>
null;
end;
end if;
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_
-- 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)
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 --
--------------------------
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 --
-----------------
-- 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;
-- 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.
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
"-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";
OSDN Git Service
