From 10f3c435c53ae82d105bfb3dd66cce8e3248be3c Mon Sep 17 00:00:00 2001 From: charlet Date: Mon, 20 Jan 2014 15:41:35 +0000 Subject: [PATCH] 2014-01-20 Fedor Rybin * gnat_ugn.texi: Documenting --passed-tests option for gnattest. 2014-01-20 Hristian Kirtchev * sem_util.adb (Default_Initialization): New routine. * sem_util.ads: Add new type Default_Initialization_Kind. (Default_Initialization): New routine. 2014-01-20 Hristian Kirtchev * sem_prag.adb (Check_Mode): Correct all error message logic dealing with in/in out parameters that may appear as inputs or have a self reference. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@206830 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 16 ++++++ gcc/ada/gnat_ugn.texi | 6 +++ gcc/ada/sem_prag.adb | 27 +++++++++-- gcc/ada/sem_util.adb | 132 ++++++++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_util.ads | 34 +++++++++++++ 5 files changed, 211 insertions(+), 4 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 97defc9..82a8ddc 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2014-01-20 Fedor Rybin + + * gnat_ugn.texi: Documenting --passed-tests option for gnattest. + +2014-01-20 Hristian Kirtchev + + * sem_util.adb (Default_Initialization): New routine. + * sem_util.ads: Add new type Default_Initialization_Kind. + (Default_Initialization): New routine. + +2014-01-20 Hristian Kirtchev + + * sem_prag.adb (Check_Mode): Correct all error + message logic dealing with in/in out parameters that may appear + as inputs or have a self reference. + 2014-01-20 Robert Dewar * exp_ch9.adb, checks.adb, exp_intr.adb: Minor reformatting. diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index 6485e9d..c17ca38 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -19496,6 +19496,12 @@ to check substitutability. Specifies the default behavior of generated skeletons. @var{val} can be either "fail" or "pass", "fail" being the default. +@item --passed-tests=@var{val} +@cindex @option{--skeleton-default} (@command{gnattest}) +Specifies whether or not passed tests should be shown. @var{val} can be either +"show" or "hide", "show" being the default. + + @item --tests-root=@var{dirname} @cindex @option{--tests-root} (@command{gnattest}) The directory hierarchy of tested sources is recreated in the @var{dirname} diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 54ed0b1..ad5e004 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -964,9 +964,12 @@ package body Sem_Prag is -- or tags can be read. In general, states and variables are -- considered to have mode IN OUT unless they are classified by -- pragma [Refined_]Global. In that case, the item must appear in - -- an input global list. + -- an input global list. OUT parameters of enclosing subprograms + -- behave as read-write variables in which case do not emit an + -- error. if (Ekind (Item_Id) = E_Out_Parameter + and then Scope (Item_Id) = Spec_Id and then not Is_Unconstrained_Or_Tagged_Item (Item_Id)) or else (Global_Seen and then not Appears_In (Subp_Inputs, Item_Id)) @@ -999,18 +1002,34 @@ package body Sem_Prag is -- type acts as an input because the discriminants, array bounds -- or the tag may be read. Note that the presence of [Refined_] -- Global is not significant here because the item is a parameter. + -- This rule applies only to the formals of the related subprogram + -- as OUT parameters of enclosing subprograms behave as read-write + -- variables and their types do not matter. elsif Ekind (Item_Id) = E_Out_Parameter + and then Scope (Item_Id) = Spec_Id and then Is_Unconstrained_Or_Tagged_Item (Item_Id) then null; -- The remaining cases are IN, IN OUT, and OUT parameters. To -- qualify as self-referential item, the parameter must be of - -- mode IN OUT. + -- mode IN OUT or be an IN OUT or OUT parameter of an enclosing + -- subprogram. - elsif Ekind (Item_Id) /= E_In_Out_Parameter then - Error_Msg_NE ("item & must have mode `IN OUT`", Item, Item_Id); + elsif Scope (Item_Id) = Spec_Id then + if Ekind (Item_Id) /= E_In_Out_Parameter then + Error_Msg_NE + ("item & must have mode `IN OUT`", Item, Item_Id); + end if; + + -- Enclosing subprogram parameter + + elsif not Ekind_In (Item_Id, E_In_Out_Parameter, + E_Out_Parameter) + then + Error_Msg_NE + ("item & must have mode `IN OUT` or `OUT`", Item, Item_Id); end if; -- Output diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 905eabb..e646854 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3863,6 +3863,138 @@ package body Sem_Util is end if; end Deepest_Type_Access_Level; + ---------------------------- + -- Default_Initialization -- + ---------------------------- + + function Default_Initialization + (Typ : Entity_Id) return Default_Initialization_Kind + is + Comp : Entity_Id; + Init : Default_Initialization_Kind; + + FDI : Boolean := False; + NDI : Boolean := False; + -- Two flags used to designate whether a record type has at least one + -- fully default initialized component and/or one not fully default + -- initialized component. + + begin + -- Access types are always fully default initialized + + if Is_Access_Type (Typ) then + return Full_Default_Initialization; + + -- An array type subject to aspect/pragma Default_Component_Value is + -- fully default initialized. Otherwise its initialization status is + -- that of its component type. + + elsif Is_Array_Type (Typ) then + if Present (Default_Aspect_Component_Value (Base_Type (Typ))) then + return Full_Default_Initialization; + else + return Default_Initialization (Component_Type (Typ)); + end if; + + -- The initialization status of a private type depends on its full view + + elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) then + return Default_Initialization (Full_View (Typ)); + + -- Record and protected types offer several initialization options + -- depending on their components (if any). + + elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then + Comp := First_Component (Typ); + + -- Inspect all components + + if Present (Comp) then + while Present (Comp) loop + + -- Do not process internally generated components except for + -- _parent which represents the ancestor portion of a derived + -- type. + + if Comes_From_Source (Comp) + or else Chars (Comp) = Name_uParent + then + Init := Default_Initialization (Base_Type (Etype (Comp))); + + -- A component with mixed initialization renders the whole + -- record/protected type mixed. + + if Init = Mixed_Initialization then + return Mixed_Initialization; + + -- The component is fully default initialized when its type + -- is fully default initialized or when the component has an + -- initialization expression. Note that this has precedence + -- given that the component type may lack initialization. + + elsif Init = Full_Default_Initialization + or else Present (Expression (Parent (Comp))) + then + FDI := True; + + -- Components with no possible initialization are ignored + + elsif Init = No_Possible_Initialization then + null; + + -- The component has no full default initialization + + else + NDI := True; + end if; + end if; + + Next_Component (Comp); + end loop; + + -- Detect a mixed case of initialization + + if FDI and NDI then + return Mixed_Initialization; + + elsif FDI then + return Full_Default_Initialization; + + elsif NDI then + return No_Default_Initialization; + + -- The type either has no components or they are all internally + -- generated. + + else + return No_Possible_Initialization; + end if; + + -- The record type is null, there is nothing to initialize + + else + return No_Possible_Initialization; + end if; + + -- A scalar type subject to aspect/pragma Default_Value is fully default + -- initialized. + + elsif Is_Scalar_Type (Typ) + and then Present (Default_Aspect_Value (Base_Type (Typ))) + then + return Full_Default_Initialization; + + -- Task types are always fully default initialized + + elsif Is_Task_Type (Typ) then + return Full_Default_Initialization; + end if; + + -- The type has no full default initialization + + return No_Default_Initialization; + end Default_Initialization; + --------------------- -- Defining_Entity -- --------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 4bd32b4..8b95413 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -384,6 +384,40 @@ package Sem_Util is -- Current_Scope is returned. The returned value is Empty if this is called -- from a library package which is not within any subprogram. + -- The following type lists all possible forms of default initialization + -- that may apply to a type. + + type Default_Initialization_Kind is + (No_Possible_Initialization, + -- This value signifies that a type cannot possibly be initialized + -- because it has no content, for example - a null record. + + Full_Default_Initialization, + -- This value covers the following combinations of types and content: + -- * Access type + -- * Array-of-scalars with specified Default_Component_Value + -- * Array type with fully default initialized component type + -- * Record or protected type with components that either have a + -- default expression or their related types are fully default + -- initialized. + -- * Scalar type with specified Default_Value + -- * Task type + -- * Type extension of a type with full default initialization where + -- the extension components are also fully default initialized + + Mixed_Initialization, + -- This value applies to a type where some of its internals are fully + -- default initialized and some are not. + + No_Default_Initialization); + -- This value reflects a type where none of its content is fully + -- default initialized. + + function Default_Initialization + (Typ : Entity_Id) return Default_Initialization_Kind; + -- Determine the default initialization kind that applies to a particular + -- type. + function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint; -- Same as Type_Access_Level, except that if the type is the type of an Ada -- 2012 stand-alone object of an anonymous access type, then return the -- 2.7.4