diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 16 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/exp_ch13.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/gnat_ugn.texi | 3 | ||||
| -rw-r--r-- | gcc/ada/live.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/rtsfind.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 3 | ||||
| -rwxr-xr-x | gcc/ada/sem_aux.adb | 105 | ||||
| -rwxr-xr-x | gcc/ada/sem_aux.ads | 18 | ||||
| -rw-r--r-- | gcc/ada/sem_ch10.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_elab.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 108 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 18 |
18 files changed, 170 insertions, 133 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6a23bae..d0eba38 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2011-12-02 Bob Duff <duff@adacore.com> + + * gnat_ugn.texi: Clarify usage of -p binder switch. + +2011-12-02 Javier Miranda <miranda@adacore.com> + + * sem_util.ads, sem_util.adb, sem_aux.ads, sem_aux.adb + (Effectively_Has_Constrained_Partial_View): Moved to sem_aux + (In_Generic_Body): Moved to sem_aux. + (Unit_Declaration_Node): Moved to sem_aux. + * einfo.ads (Effectively_Has_Constrained_Partial_View): Complete + documentation. + * exp_attr.adb, live.adb, sem_ch10.adb, checks.adb, sem.adb, + rtsfind.adb, sem_attr.adb, sem_elab.adb, exp_ch4.adb, sem_ch4.adb, + exp_ch13.adb: Add with-clause on Sem_Aux. + 2011-12-02 Yannick Moy <moy@adacore.com> * sem_util.adb (Unique_Name): Reach through Unique_Entity to diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index ceaae4a..5383bd8 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -1240,7 +1240,9 @@ package body Checks is -- partial view that is constrained. elsif Ada_Version >= Ada_2005 - and then Effectively_Has_Constrained_Partial_View (Base_Type (T_Typ)) + and then Effectively_Has_Constrained_Partial_View + (Typ => Base_Type (T_Typ), + Scop => Current_Scope) then return; end if; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 46ea04e..be60765 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1420,8 +1420,11 @@ 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. +-- Sem_Aux.Effectively_Has_Constrained_Partial_View should be always +-- used by callers, rather than reading this attribute directly because, +-- according to RM 3.10.2 (27/2), untagged generic formal private types +-- and subtypes are also considered to have a constrained partial view +-- [when in a generic body]. -- 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 bb44a30..a4d9149 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1563,7 +1563,8 @@ package body Exp_Attr is (Nkind (Obj) = N_Explicit_Dereference and then not Effectively_Has_Constrained_Partial_View - (Base_Type (Etype (Obj))))); + (Typ => Base_Type (Etype (Obj)), + Scop => Current_Scope))); end if; end Is_Constrained_Aliased_View; @@ -1686,7 +1687,8 @@ package body Exp_Attr is (Nkind (Pref) = N_Explicit_Dereference and then not Effectively_Has_Constrained_Partial_View - (Base_Type (Ptyp))) + (Typ => Base_Type (Ptyp), + Scop => Current_Scope)) 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_ch13.adb b/gcc/ada/exp_ch13.adb index a6890d7..038a844 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -39,6 +39,7 @@ with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 55214a1..12980a7 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -3905,7 +3905,8 @@ package body Exp_Ch4 is and then (Ada_Version < Ada_2005 or else not Effectively_Has_Constrained_Partial_View - (Typ)) + (Typ => Typ, + Scop => Current_Scope)) then Typ := Build_Default_Subtype (Typ, N); Set_Expression (N, New_Reference_To (Typ, Loc)); diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index a741c33..52198c6 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -8660,6 +8660,9 @@ This is because in the default static elaboration mode, all necessary These implicit pragmas are still respected by the binder in @option{^-p^/PESSIMISTIC_ELABORATION^} mode, so a safe elaboration order is assured. + +Note that @option{^-p^/PESSIMISTIC_ELABORATION^} is not intended for +production use; it is more for debugging/experimental use. @end table @node Output Control diff --git a/gcc/ada/live.adb b/gcc/ada/live.adb index eaa5202..b0c616f 100644 --- a/gcc/ada/live.adb +++ b/gcc/ada/live.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -27,6 +27,7 @@ with Atree; use Atree; with Einfo; use Einfo; with Lib; use Lib; with Nlists; use Nlists; +with Sem_Aux; use Sem_Aux; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Types; use Types; diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 459f886..b8a6b1f 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -42,6 +42,7 @@ with Output; use Output; with Opt; use Opt; with Restrict; use Restrict; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; with Sem_Ch7; use Sem_Ch7; with Sem_Dist; use Sem_Dist; with Sem_Util; use Sem_Util; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 2a27360..ce6d88b 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -37,6 +37,7 @@ with Nlists; use Nlists; with Output; use Output; with Restrict; use Restrict; with Sem_Attr; use Sem_Attr; +with Sem_Aux; use Sem_Aux; with Sem_Ch2; use Sem_Ch2; with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 45dd822..bfad3f8 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -8633,7 +8633,8 @@ package body Sem_Attr is (Ada_Version < Ada_2005 or else not Effectively_Has_Constrained_Partial_View - (Designated_Type (Base_Type (Typ)))) + (Typ => Designated_Type (Base_Type (Typ)), + Scop => Current_Scope)) then null; diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 3b3453f..4f93f22 100755 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -152,6 +152,25 @@ package body Sem_Aux is end if; end Constant_Value; + ---------------------------------------------- + -- Effectively_Has_Constrained_Partial_View -- + ---------------------------------------------- + + function Effectively_Has_Constrained_Partial_View + (Typ : Entity_Id; + Scop : Entity_Id) 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_Dynamic_Scope -- ----------------------------- @@ -419,6 +438,43 @@ package body Sem_Aux is end Initialize; --------------------- + -- In_Generic_Body -- + --------------------- + + function In_Generic_Body (Id : Entity_Id) return Boolean is + S : Entity_Id; + + begin + -- Climb scopes looking for generic body + + S := Id; + 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; + + -- False if top of scope stack without finding a generic body + + return False; + end In_Generic_Body; + + --------------------- -- Is_By_Copy_Type -- --------------------- @@ -904,4 +960,53 @@ package body Sem_Aux is return E; end Ultimate_Alias; + -------------------------- + -- Unit_Declaration_Node -- + -------------------------- + + function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is + N : Node_Id := Parent (Unit_Id); + + begin + -- Predefined operators do not have a full function declaration + + if Ekind (Unit_Id) = E_Operator then + return N; + end if; + + -- Isn't there some better way to express the following ??? + + while Nkind (N) /= N_Abstract_Subprogram_Declaration + and then Nkind (N) /= N_Formal_Package_Declaration + and then Nkind (N) /= N_Function_Instantiation + and then Nkind (N) /= N_Generic_Package_Declaration + and then Nkind (N) /= N_Generic_Subprogram_Declaration + and then Nkind (N) /= N_Package_Declaration + and then Nkind (N) /= N_Package_Body + and then Nkind (N) /= N_Package_Instantiation + and then Nkind (N) /= N_Package_Renaming_Declaration + and then Nkind (N) /= N_Procedure_Instantiation + and then Nkind (N) /= N_Protected_Body + and then Nkind (N) /= N_Subprogram_Declaration + and then Nkind (N) /= N_Subprogram_Body + and then Nkind (N) /= N_Subprogram_Body_Stub + and then Nkind (N) /= N_Subprogram_Renaming_Declaration + and then Nkind (N) /= N_Task_Body + and then Nkind (N) /= N_Task_Type_Declaration + and then Nkind (N) not in N_Formal_Subprogram_Declaration + and then Nkind (N) not in N_Generic_Renaming_Declaration + loop + N := Parent (N); + + -- We don't use Assert here, because that causes an infinite loop + -- when assertions are turned off. Better to crash. + + if No (N) then + raise Program_Error; + end if; + end loop; + + return N; + end Unit_Declaration_Node; + end Sem_Aux; diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 03ff2fe..d4875a4 100755 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -104,6 +104,14 @@ package Sem_Aux is -- constants from the point of view of constant folding. Empty is also -- returned for variables with no initialization expression. + function Effectively_Has_Constrained_Partial_View + (Typ : Entity_Id; + Scop : Entity_Id) 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_Dynamic_Scope (Ent : Entity_Id) return Entity_Id; -- For any entity, Ent, returns the closest dynamic scope in which the -- entity is declared or Standard_Standard for library-level entities. @@ -147,6 +155,9 @@ package Sem_Aux is -- Typ must be a tagged record type. This function returns the Entity for -- the first _Tag field in the record type. + function In_Generic_Body (Id : Entity_Id) return Boolean; + -- Determine whether entity Id appears inside a generic body + function Is_By_Copy_Type (Ent : Entity_Id) return Boolean; -- Ent is any entity. Returns True if Ent is a type entity where the type -- is required to be passed by copy, as defined in (RM 6.2(3)). @@ -228,4 +239,11 @@ package Sem_Aux is -- Return the last entity in the chain of aliased entities of Prim. If Prim -- has no alias return Prim. + function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id; + -- Unit_Id is the simple name of a program unit, this function returns the + -- corresponding xxx_Declaration node for the entity. Also applies to the + -- body entities for subprograms, tasks and protected units, in which case + -- it returns the subprogram, task or protected body node for it. The unit + -- may be a child unit with any number of ancestors. + end Sem_Aux; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index e5afc1b..4913b13 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -47,6 +47,7 @@ with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; with Sem_Ch3; use Sem_Ch3; with Sem_Ch6; use Sem_Ch6; with Sem_Ch7; use Sem_Ch7; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index acd03a9..8f1e43a 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -576,7 +576,9 @@ package body Sem_Ch4 is -- and the allocated object is unconstrained. elsif Ada_Version >= Ada_2005 - and then Effectively_Has_Constrained_Partial_View (Base_Typ) + and then Effectively_Has_Constrained_Partial_View + (Typ => Base_Typ, + Scop => Current_Scope) then Error_Msg_N ("constraint not allowed when type " & diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index ce4cff3..6df8c32 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -43,6 +43,7 @@ with Output; use Output; with Restrict; use Restrict; with Rident; use Rident; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 4fc88f2..203eec1 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3039,25 +3039,6 @@ 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 -- -------------------------- @@ -6107,43 +6088,6 @@ 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; - - begin - -- Climb scopes looking for generic body - - S := Id; - 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; - - -- False if top of scope stack without finding a generic body - - return False; - end In_Generic_Body; - ----------------- -- In_Instance -- ----------------- @@ -7002,7 +6946,8 @@ package body Sem_Util is if Ekind (Prefix_Type) = E_Access_Type and then not Effectively_Has_Constrained_Partial_View - (Designated_Type (Prefix_Type)) + (Typ => Designated_Type (Prefix_Type), + Scop => Current_Scope) then return False; @@ -12985,55 +12930,6 @@ package body Sem_Util is end if; end Unique_Name; - -------------------------- - -- Unit_Declaration_Node -- - -------------------------- - - function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is - N : Node_Id := Parent (Unit_Id); - - begin - -- Predefined operators do not have a full function declaration - - if Ekind (Unit_Id) = E_Operator then - return N; - end if; - - -- Isn't there some better way to express the following ??? - - while Nkind (N) /= N_Abstract_Subprogram_Declaration - and then Nkind (N) /= N_Formal_Package_Declaration - and then Nkind (N) /= N_Function_Instantiation - and then Nkind (N) /= N_Generic_Package_Declaration - and then Nkind (N) /= N_Generic_Subprogram_Declaration - and then Nkind (N) /= N_Package_Declaration - and then Nkind (N) /= N_Package_Body - and then Nkind (N) /= N_Package_Instantiation - and then Nkind (N) /= N_Package_Renaming_Declaration - and then Nkind (N) /= N_Procedure_Instantiation - and then Nkind (N) /= N_Protected_Body - and then Nkind (N) /= N_Subprogram_Declaration - and then Nkind (N) /= N_Subprogram_Body - and then Nkind (N) /= N_Subprogram_Body_Stub - and then Nkind (N) /= N_Subprogram_Renaming_Declaration - and then Nkind (N) /= N_Task_Body - and then Nkind (N) /= N_Task_Type_Declaration - and then Nkind (N) not in N_Formal_Subprogram_Declaration - and then Nkind (N) not in N_Generic_Renaming_Declaration - loop - N := Parent (N); - - -- We don't use Assert here, because that causes an infinite loop - -- when assertions are turned off. Better to crash. - - if No (N) then - raise Program_Error; - end if; - end loop; - - return N; - end Unit_Declaration_Node; - --------------------- -- Unit_Is_Visible -- --------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b2b6cbf..d7154a2 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -368,14 +368,6 @@ 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. @@ -725,9 +717,6 @@ 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 @@ -1503,13 +1492,6 @@ package Sem_Util is -- Return a unique name for entity E, which could be used to identify E -- across compilation units. - function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id; - -- Unit_Id is the simple name of a program unit, this function returns the - -- corresponding xxx_Declaration node for the entity. Also applies to the - -- body entities for subprograms, tasks and protected units, in which case - -- it returns the subprogram, task or protected body node for it. The unit - -- may be a child unit with any number of ancestors. - function Unit_Is_Visible (U : Entity_Id) return Boolean; -- Determine whether a compilation unit is visible in the current context, -- because there is a with_clause that makes the unit available. Used to |