diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 36 | ||||
| -rw-r--r-- | gcc/ada/a-cbmutr.adb | 61 | ||||
| -rw-r--r-- | gcc/ada/a-cimutr.adb | 67 | ||||
| -rw-r--r-- | gcc/ada/a-comutr.adb | 64 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/prj-part.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_ch9.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 30 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 52 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 11 | ||||
| -rw-r--r-- | gcc/ada/vms_data.ads | 16 |
19 files changed, 247 insertions, 149 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 116759d8892..cff6725faad 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,41 @@ 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. diff --git a/gcc/ada/a-cbmutr.adb b/gcc/ada/a-cbmutr.adb index 46a68c8bc45..aee67f02a2f 100644 --- a/gcc/ada/a-cbmutr.adb +++ b/gcc/ada/a-cbmutr.adb @@ -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); diff --git a/gcc/ada/a-cimutr.adb b/gcc/ada/a-cimutr.adb index 08bfbaebaa4..01929bbf373 100644 --- a/gcc/ada/a-cimutr.adb +++ b/gcc/ada/a-cimutr.adb @@ -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; + 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; ------------------ @@ -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; + 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; ---------------------- diff --git a/gcc/ada/a-comutr.adb b/gcc/ada/a-comutr.adb index d68f2a8f51a..b18b15f7534 100644 --- a/gcc/ada/a-comutr.adb +++ b/gcc/ada/a-comutr.adb @@ -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; ---------------------- diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 01f240fc034..ceaae4a96a8 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -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; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 019f2f37133..46ea04e81d6 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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 diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index ac6fdf9f26e..bb44a303fe8 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -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)) diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index d2f0668873e..55214a1afbc 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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)); diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb index 23ad841a3c5..f3650f0b04c 100644 --- a/gcc/ada/prj-part.adb +++ b/gcc/ada/prj-part.adb @@ -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 diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index c2277851bc4..45dd822c7a5 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 5cc06e7d899..2a0f032df10 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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)); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 0f918c06b4c..acd03a9545a 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -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; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 780a916bc2d..a47a2dc02b6 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 98913dbccce..296e3edfd3a 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -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); diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 35c4eeebda0..f9aab6a235d 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -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; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index a21358bd791..c8daa8c5312 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index edf1fecbfe6..c1a79275e4e 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 693ddf2def9..b2b6cbfa7ee 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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 diff --git a/gcc/ada/vms_data.ads b/gcc/ada/vms_data.ads index 9fc3d97d2e2..12eca51a7b0 100644 --- a/gcc/ada/vms_data.ads +++ b/gcc/ada/vms_data.ads @@ -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"; |