From: Arnaud Charlet Date: Thu, 7 Sep 2017 09:40:16 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=1155ae01593b0b84cddf5031b7a85d684fe0dd0d;p=gcc.git [multiple changes] 2017-09-07 Arnaud Charlet * sem_prag.adb (Find_Role): The Global_Seen flag is now consulted not only for abstract states and variables, but for all kinds of items. (Collect_Subprogram_Inputs_Outputs): Do not process formal generic parameters, because unlike ordinary formal parameters, generic formals only act as input/ outputs if they are explicitly mentioned in a Global contract. 2017-09-07 Yannick Moy * ghost.adb (Check_Ghost_Context): Do not err on ghost code inside predicate procedure. Check predicate pragma/aspect with Ghost entity. * exp_ch6.adb, par-ch6.adb, sem_ch13.adb, sem_prag.adb; Minor reformatting. 2017-09-07 Ed Schonberg * sem_aggr.adb: Move New_Copy_Tree_And_Dimensions to sem_dim (code cleanup); * sem_ch3.adb (Build_Derived_Record_Type):i Call Copy_Dimensions_Of_Components after creating the copy of the record declaration. * sem_dim.ads, sem_dim.adb (Copy_Dimensions_Of_Components): For a derived recor type, copy the dikensions if any of each component of the parent record to the corresponding component declarations of the derived record. These expressions are used among other things as default values in aggregates with box associations. * a-dirval-mingw.adb, g-cgi.adb, gnatcmd.adb, lib-xref.adb, repinfo.adb, sem_attr.adb, sem_ch10.adb, sem_ch6.adb, sem_prag.adb: Minor reformatting. 2017-09-07 Arnaud Charlet * sem_util.adb: Remove extra space after THEN. 2017-09-07 Eric Botcazou * sem_ch7.adb (Has_Referencer): For a subprogram renaming, also mark the renamed subprogram as referenced. From-SVN: r251836 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7ab4ed4cd4a..157743b204b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,45 @@ +2017-09-07 Arnaud Charlet + + * sem_prag.adb (Find_Role): The Global_Seen flag + is now consulted not only for abstract states and variables, + but for all kinds of items. + (Collect_Subprogram_Inputs_Outputs): Do not process formal + generic parameters, because unlike ordinary formal parameters, + generic formals only act as input/ outputs if they are explicitly + mentioned in a Global contract. + +2017-09-07 Yannick Moy + + * ghost.adb (Check_Ghost_Context): Do not err on ghost code inside + predicate procedure. Check predicate pragma/aspect with Ghost entity. + * exp_ch6.adb, par-ch6.adb, sem_ch13.adb, sem_prag.adb; Minor + reformatting. + +2017-09-07 Ed Schonberg + + * sem_aggr.adb: Move New_Copy_Tree_And_Dimensions to sem_dim + (code cleanup); + * sem_ch3.adb (Build_Derived_Record_Type):i Call + Copy_Dimensions_Of_Components after creating the copy of the + record declaration. + * sem_dim.ads, sem_dim.adb (Copy_Dimensions_Of_Components): For a + derived recor type, copy the dikensions if any of each component + of the parent record to the corresponding component declarations + of the derived record. These expressions are used among other + things as default values in aggregates with box associations. + * a-dirval-mingw.adb, g-cgi.adb, gnatcmd.adb, lib-xref.adb, + repinfo.adb, sem_attr.adb, sem_ch10.adb, sem_ch6.adb, sem_prag.adb: + Minor reformatting. + +2017-09-07 Arnaud Charlet + + * sem_util.adb: Remove extra space after THEN. + +2017-09-07 Eric Botcazou + + * sem_ch7.adb (Has_Referencer): For a subprogram renaming, + also mark the renamed subprogram as referenced. + 2017-09-07 Ed Schonberg * par-ch6.adb (P_Subprogram): Improve error message on null diff --git a/gcc/ada/a-dirval-mingw.adb b/gcc/ada/a-dirval-mingw.adb index dad5c4ae8a4..b0a9cc35c1d 100644 --- a/gcc/ada/a-dirval-mingw.adb +++ b/gcc/ada/a-dirval-mingw.adb @@ -7,7 +7,7 @@ -- B o d y -- -- (Windows Version) -- -- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2017, 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- -- @@ -75,7 +75,7 @@ package body Ada.Directories.Validity is -- A drive letter may be specified at the beginning if Name'Length >= 2 - and then Name (Start + 1) = ':' + and then Name (Start + 1) = ':' and then (Name (Start) in 'A' .. 'Z' or else Name (Start) in 'a' .. 'z') then diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 39b11f812aa..908338fd28e 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -137,7 +137,8 @@ package body Exp_Ch6 is -- there are no tasks. function Caller_Known_Size - (Func_Call : Node_Id; Result_Subt : Entity_Id) return Boolean; + (Func_Call : Node_Id; + Result_Subt : Entity_Id) return Boolean; -- True if result subtype is definite, or has a size that does not require -- secondary stack usage (i.e. no variant part or components whose type -- depends on discriminants). In particular, untagged types with only @@ -837,11 +838,14 @@ package body Exp_Ch6 is ----------------------- function Caller_Known_Size - (Func_Call : Node_Id; Result_Subt : Entity_Id) return Boolean is + (Func_Call : Node_Id; + Result_Subt : Entity_Id) return Boolean + is begin - return (Is_Definite_Subtype (Underlying_Type (Result_Subt)) - and then No (Controlling_Argument (Func_Call))) - or else not Requires_Transient_Scope (Underlying_Type (Result_Subt)); + return + (Is_Definite_Subtype (Underlying_Type (Result_Subt)) + and then No (Controlling_Argument (Func_Call))) + or else not Requires_Transient_Scope (Underlying_Type (Result_Subt)); end Caller_Known_Size; -------------------------------- @@ -8081,7 +8085,8 @@ package body Exp_Ch6 is declare Definite : constant Boolean := - Caller_Known_Size (Func_Call, Result_Subt); + Caller_Known_Size (Func_Call, Result_Subt); + begin -- Create an access type designating the function's result subtype. -- We use the type of the original call because it may be a call to diff --git a/gcc/ada/g-cgi.adb b/gcc/ada/g-cgi.adb index 34058e0a96c..9d658e69db2 100644 --- a/gcc/ada/g-cgi.adb +++ b/gcc/ada/g-cgi.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2010, AdaCore -- +-- Copyright (C) 2001-2017, AdaCore -- -- -- -- 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- -- @@ -110,7 +110,7 @@ package body GNAT.CGI is begin while K <= S'Last loop if K + 2 <= S'Last - and then S (K) = '%' + and then S (K) = '%' and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 1)) and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 2)) then diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb index beb05f4ecdd..78ba5f3e133 100644 --- a/gcc/ada/ghost.adb +++ b/gcc/ada/ghost.adb @@ -281,6 +281,13 @@ package body Ghost is if Chars (Subp_Id) = Name_uPostconditions then return True; + -- The context is the internally built predicate function, + -- which is OK because the real check was done before the + -- predicate function was generated. + + elsif Is_Predicate_Function (Subp_Id) then + return True; + else Subp_Decl := Original_Node (Unit_Declaration_Node (Subp_Id)); @@ -362,10 +369,12 @@ package body Ghost is return True; -- An assertion expression pragma is Ghost when it contains a - -- reference to a Ghost entity (SPARK RM 6.9(10)). - - elsif Assertion_Expression_Pragma (Prag_Id) then + -- reference to a Ghost entity (SPARK RM 6.9(10)), except for + -- predicate pragmas (SPARK RM 6.9(11)). + elsif Assertion_Expression_Pragma (Prag_Id) + and then Prag_Id /= Pragma_Predicate + then -- Ensure that the assertion policy and the Ghost policy are -- compatible (SPARK RM 6.9(18)). @@ -464,9 +473,16 @@ package body Ghost is return True; -- A reference to a Ghost entity can appear within an aspect - -- specification (SPARK RM 6.9(10)). - - elsif Nkind (Par) = N_Aspect_Specification then + -- specification (SPARK RM 6.9(10)). The precise checking will + -- occur when analyzing the corresponding pragma. We make an + -- exception for predicate aspects that only allow referencing + -- a Ghost entity when the corresponding type declaration is + -- Ghost (SPARK RM 6.9(11)). + + elsif Nkind (Par) = N_Aspect_Specification + and then not Same_Aspect + (Get_Aspect_Id (Par), Aspect_Predicate) + then return True; elsif Is_OK_Declaration (Par) then diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index e5df7bbead0..55f79c355df 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -573,9 +573,9 @@ begin -- report an error indicating that the command is no longer supporting -- project files. - if The_Command = Find or else The_Command = Xref then + if The_Command = Find or else The_Command = Xref then declare - Argv : String_Access; + Argv : String_Access; begin for Arg_Num in 1 .. Last_Switches.Last loop Argv := Last_Switches.Table (Arg_Num); diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index c2958ead326..edc955b15b4 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -1079,7 +1079,7 @@ package body Lib.Xref is -- original discriminant, which gets the reference. elsif Ekind (E) = E_In_Parameter - and then Present (Discriminal_Link (E)) + and then Present (Discriminal_Link (E)) then Ent := Discriminal_Link (E); Set_Referenced (Ent); @@ -2702,7 +2702,7 @@ package body Lib.Xref is if XE.Key.Loc /= No_Location and then (XE.Key.Loc /= Crloc - or else (Prevt = 'm' and then XE.Key.Typ = 'r')) + or else (Prevt = 'm' and then XE.Key.Typ = 'r')) then Crloc := XE.Key.Loc; Prevt := XE.Key.Typ; diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index 58c46a95a28..83bb25118a4 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -855,13 +855,14 @@ package body Ch6 is if Is_Non_Empty_List (Aspects) then if Func then - Error_Msg ("aspect specifications must come after " - & "parenthesized expression", - Sloc (First (Aspects))); + Error_Msg + ("aspect specifications must come after " + & "parenthesized expression", + Sloc (First (Aspects))); else - Error_Msg ("aspect specifications must come after " - & "subprogram specification", - Sloc (First (Aspects))); + Error_Msg + ("aspect specifications must come after subprogram " + & "specification", Sloc (First (Aspects))); end if; end if; diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index dbc5920566d..57528d60697 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -341,7 +341,7 @@ package body Repinfo is begin Decl := Parent (E); while Present (Decl) - and then Nkind (Decl) /= N_Package_Body + and then Nkind (Decl) /= N_Package_Body and then Nkind (Decl) /= N_Subprogram_Declaration and then Nkind (Decl) /= N_Subprogram_Body loop diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 1249fa03fed..a7269048246 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -3279,14 +3279,6 @@ package body Sem_Aggr is -- An error message is emitted if the components taking their value from -- the others choice do not have same type. - function New_Copy_Tree_And_Copy_Dimensions - (Source : Node_Id; - Map : Elist_Id := No_Elist; - New_Sloc : Source_Ptr := No_Location; - New_Scope : Entity_Id := Empty) return Node_Id; - -- Same as New_Copy_Tree (defined in Sem_Util), except that this routine - -- also copies the dimensions of Source to the returned node. - procedure Propagate_Discriminants (Aggr : Node_Id; Assoc_List : List_Id); @@ -3733,26 +3725,6 @@ package body Sem_Aggr is return Expr; end Get_Value; - --------------------------------------- - -- New_Copy_Tree_And_Copy_Dimensions -- - --------------------------------------- - - function New_Copy_Tree_And_Copy_Dimensions - (Source : Node_Id; - Map : Elist_Id := No_Elist; - New_Sloc : Source_Ptr := No_Location; - New_Scope : Entity_Id := Empty) return Node_Id - is - New_Copy : constant Node_Id := - New_Copy_Tree (Source, Map, New_Sloc, New_Scope); - - begin - -- Move the dimensions of Source to New_Copy - - Copy_Dimensions (Source, New_Copy); - return New_Copy; - end New_Copy_Tree_And_Copy_Dimensions; - ----------------------------- -- Propagate_Discriminants -- ----------------------------- diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index feef95a3283..09ca1fd0f7f 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -3556,7 +3556,7 @@ package body Sem_Attr is elsif Nkind (P) = N_Indexed_Component then if not Is_Entity_Name (Prefix (P)) - or else No (Entity (Prefix (P))) + or else No (Entity (Prefix (P))) or else Ekind (Entity (Prefix (P))) /= E_Entry_Family then if Nkind (Prefix (P)) = N_Selected_Component diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 358b20a83bf..332863966aa 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -1748,7 +1748,7 @@ package body Sem_Ch10 is -- body may not be available, in which case do not try analysis. if Serious_Errors_Detected > 0 - and then No (Library_Unit (Library_Unit (N))) + and then No (Library_Unit (Library_Unit (N))) then return; end if; @@ -2129,7 +2129,7 @@ package body Sem_Ch10 is -- attempt processing. if Serious_Errors_Detected > 0 - and then No (Entity (Name (Item))) + and then No (Entity (Name (Item))) then Set_Entity (Name (Item), Standard_Standard); end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index a99d2ee065c..124a4af08ea 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -12649,7 +12649,6 @@ package body Sem_Ch13 is -------------------------------- procedure Resolve_Aspect_Expressions (E : Entity_Id) is - function Resolve_Name (N : Node_Id) return Traverse_Result; -- Verify that all identifiers in the expression, with the exception -- of references to the current entity, denote visible entities. This @@ -12668,6 +12667,7 @@ package body Sem_Ch13 is function Resolve_Name (N : Node_Id) return Traverse_Result is Dummy : Traverse_Result; + begin if Nkind (N) = N_Selected_Component then if Nkind (Prefix (N)) = N_Identifier @@ -12700,6 +12700,8 @@ package body Sem_Ch13 is procedure Resolve_Aspect_Expression is new Traverse_Proc (Resolve_Name); + -- Local variables + ASN : Node_Id := First_Rep_Item (E); -- Start of processing for Resolve_Aspect_Expressions diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 75348c7b267..41bf2a8671c 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -9352,6 +9352,7 @@ package body Sem_Ch3 is New_Decl := New_Copy_Tree (Parent (Parent_Base), Map => Assoc_List, New_Sloc => Loc); + Copy_Dimensions_Of_Components (Derived_Type); -- Restore the fields saved prior to the New_Copy_Tree call -- and compute the stored constraint. @@ -11883,7 +11884,7 @@ package body Sem_Ch3 is -- or protected interfaces. elsif Nkind (N) = N_Full_Type_Declaration - and then Protected_Present (Type_Def) + and then Protected_Present (Type_Def) then if Limited_Present (Iface_Def) or else Synchronized_Present (Iface_Def) @@ -16795,7 +16796,7 @@ package body Sem_Ch3 is procedure Diagnose_Interface (N : Node_Id; E : Entity_Id) is begin - if not Is_Interface (E) and then E /= Any_Type then + if not Is_Interface (E) and then E /= Any_Type then Error_Msg_NE ("(Ada 2005) & must be an interface", N, E); end if; end Diagnose_Interface; @@ -21450,7 +21451,7 @@ package body Sem_Ch3 is Constrain_Access (Def_Id, S, Related_Nod); if Expander_Active - and then Is_Itype (Designated_Type (Def_Id)) + and then Is_Itype (Designated_Type (Def_Id)) and then Nkind (Related_Nod) = N_Subtype_Declaration and then not Is_Incomplete_Type (Designated_Type (Def_Id)) then diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index f96c073f3af..16f4f340b68 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -439,6 +439,23 @@ package body Sem_Ch7 is then Set_Is_Public (Decl_Id, False); end if; + + -- For a subprogram renaming, if the entity is referenced, + -- then so is the renamed subprogram. But there is an issue + -- with generic bodies because instantiations are not done + -- yet and, therefore, cannot be scanned for referencers. + -- That's why we use an approximation and test that we have + -- at least one subprogram referenced by an inlined body + -- instead of precisely the entity of this renaming. + + if Nkind (Decl) = N_Subprogram_Renaming_Declaration + and then Subprogram_Table.Get_First + and then Is_Entity_Name (Name (Decl)) + and then Present (Entity (Name (Decl))) + and then Is_Subprogram (Entity (Name (Decl))) + then + Subprogram_Table.Set (Entity (Name (Decl)), True); + end if; end if; Prev (Decl); diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index 2b4b84319f8..6aae74b8ec8 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -2405,6 +2405,25 @@ package body Sem_Dim is end if; end Copy_Dimensions; + ----------------------------------- + -- Copy_Dimensions_Of_Components -- + ----------------------------------- + + procedure Copy_Dimensions_Of_Components (Rec : Entity_Id) is + C : Entity_Id; + + begin + C := First_Component (Rec); + while Present (C) loop + if Nkind (Parent (C)) = N_Component_Declaration then + Copy_Dimensions + (Expression (Parent (Corresponding_Record_Component (C))), + Expression (Parent (C))); + end if; + Next_Component (C); + end loop; + end Copy_Dimensions_Of_Components; + -------------------------- -- Create_Rational_From -- -------------------------- @@ -3483,6 +3502,26 @@ package body Sem_Dim is Remove_Dimensions (From); end Move_Dimensions; + --------------------------------------- + -- New_Copy_Tree_And_Copy_Dimensions -- + --------------------------------------- + + function New_Copy_Tree_And_Copy_Dimensions + (Source : Node_Id; + Map : Elist_Id := No_Elist; + New_Sloc : Source_Ptr := No_Location; + New_Scope : Entity_Id := Empty) return Node_Id + is + New_Copy : constant Node_Id := + New_Copy_Tree (Source, Map, New_Sloc, New_Scope); + + begin + -- Move the dimensions of Source to New_Copy + + Copy_Dimensions (Source, New_Copy); + return New_Copy; + end New_Copy_Tree_And_Copy_Dimensions; + ------------ -- Reduce -- ------------ diff --git a/gcc/ada/sem_dim.ads b/gcc/ada/sem_dim.ads index bad3bf22b85..9452d7a84fb 100644 --- a/gcc/ada/sem_dim.ads +++ b/gcc/ada/sem_dim.ads @@ -189,6 +189,20 @@ package Sem_Dim is -- node that is allowed to contain a dimension (see OK_For_Dimension in -- body of Sem_Dim). + procedure Copy_Dimensions_Of_Components (Rec : Entity_Id); + -- Propagate the dimensions of the components of a record type T to the + -- components of a record type derived from T. The derivation creates + -- a full copy of the type declaration of the parent, and the dimension + -- information of individual components must be transferred explicitly. + + function New_Copy_Tree_And_Copy_Dimensions + (Source : Node_Id; + Map : Elist_Id := No_Elist; + New_Sloc : Source_Ptr := No_Location; + New_Scope : Entity_Id := Empty) return Node_Id; + -- Same as New_Copy_Tree (defined in Sem_Util), except that this routine + -- also copies the dimensions of Source to the returned node. + function Dimensions_Match (T1 : Entity_Id; T2 : Entity_Id) return Boolean; -- If the common base type has a dimension system, verify that two -- subtypes have the same dimensions. Used for conformance checking. diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index bb3658478b2..6d838b3697c 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -1205,126 +1205,173 @@ package body Sem_Prag is Item_Is_Output : out Boolean) is begin - Item_Is_Input := False; - Item_Is_Output := False; + case Ekind (Item_Id) is - -- Abstract states + -- Abstract states - if Ekind (Item_Id) = E_Abstract_State then + when E_Abstract_State => - -- When pragma Global is present, the mode of the state may be - -- further constrained by setting a more restrictive mode. + -- When pragma Global is present it determines the mode of + -- the abstract state. - if Global_Seen then - if Appears_In (Subp_Inputs, Item_Id) then - Item_Is_Input := True; - end if; + if Global_Seen then + Item_Is_Input := Appears_In (Subp_Inputs, Item_Id); + Item_Is_Output := Appears_In (Subp_Outputs, Item_Id); + + -- Otherwise the state has a default IN OUT mode, because it + -- behaves as a variable. - if Appears_In (Subp_Outputs, Item_Id) then + else + Item_Is_Input := True; Item_Is_Output := True; end if; - -- Otherwise the state has a default IN OUT mode + -- Constants and IN parameters - else - Item_Is_Input := True; - Item_Is_Output := True; - end if; + when E_Constant + | E_Generic_In_Parameter + | E_In_Parameter + | E_Loop_Parameter + => + -- When pragma Global is present it determines the mode + -- of constant objects as inputs (and such objects cannot + -- appear as outputs in the Global contract). - -- Constants + if Global_Seen then + Item_Is_Input := Appears_In (Subp_Inputs, Item_Id); + else + Item_Is_Input := True; + end if; - elsif Ekind_In (Item_Id, E_Constant, - E_Loop_Parameter) - then - Item_Is_Input := True; + Item_Is_Output := False; - -- Parameters + -- Variables and IN OUT parameters - elsif Ekind_In (Item_Id, E_Generic_In_Parameter, - E_In_Parameter) - then - Item_Is_Input := True; + when E_Generic_In_Out_Parameter + | E_In_Out_Parameter + | E_Variable + => + -- When pragma Global is present it determines the mode of + -- the object. - elsif Ekind_In (Item_Id, E_Generic_In_Out_Parameter, - E_In_Out_Parameter) - then - Item_Is_Input := True; - Item_Is_Output := True; + if Global_Seen then - elsif Ekind (Item_Id) = E_Out_Parameter then - if Scope (Item_Id) = Spec_Id then + -- A variable has mode IN when its type is unconstrained + -- or tagged because array bounds, discriminants or tags + -- can be read. - -- An OUT parameter of the related subprogram has mode IN - -- if its type is unconstrained or tagged because array - -- bounds, discriminants or tags can be read. + Item_Is_Input := + Appears_In (Subp_Inputs, Item_Id) + or else Is_Unconstrained_Or_Tagged_Item (Item_Id); - if Is_Unconstrained_Or_Tagged_Item (Item_Id) then - Item_Is_Input := True; + Item_Is_Output := Appears_In (Subp_Outputs, Item_Id); + + -- Otherwise the variable has a default IN OUT mode + + else + Item_Is_Input := True; + Item_Is_Output := True; end if; - Item_Is_Output := True; + when E_Out_Parameter => - -- An OUT parameter of an enclosing subprogram behaves as a - -- read-write variable in which case the mode is IN OUT. + -- An OUT parameter of the related subprogram; it cannot + -- appear in Global. - else - Item_Is_Input := True; - Item_Is_Output := True; - end if; + if Scope (Item_Id) = Spec_Id then - -- Protected types + -- The parameter has mode IN if its type is unconstrained + -- or tagged because array bounds, discriminants or tags + -- can be read. - elsif Ekind (Item_Id) = E_Protected_Type then + Item_Is_Input := + Is_Unconstrained_Or_Tagged_Item (Item_Id); - -- A protected type acts as a formal parameter of mode IN when - -- it applies to a protected function. + Item_Is_Output := True; - if Ekind (Spec_Id) = E_Function then - Item_Is_Input := True; + -- An OUT parameter of an enclosing subprogram; it can + -- appear in Global and behaves as a read-write variable. - -- Otherwise the protected type acts as a formal of mode IN OUT + else + -- When pragma Global is present it determines the mode + -- of the object. - else - Item_Is_Input := True; - Item_Is_Output := True; - end if; + if Global_Seen then - -- Task types + -- A variable has mode IN when its type is + -- unconstrained or tagged because array + -- bounds, discriminants or tags can be read. - elsif Ekind (Item_Id) = E_Task_Type then - Item_Is_Input := True; - Item_Is_Output := True; + Item_Is_Input := + Appears_In (Subp_Inputs, Item_Id) + or else Is_Unconstrained_Or_Tagged_Item (Item_Id); - -- Variable case + Item_Is_Output := Appears_In (Subp_Outputs, Item_Id); - else pragma Assert (Ekind (Item_Id) = E_Variable); + -- Otherwise the variable has a default IN OUT mode - -- When pragma Global is present, the mode of the variable may - -- be further constrained by setting a more restrictive mode. + else + Item_Is_Input := True; + Item_Is_Output := True; + end if; + end if; - if Global_Seen then + -- Protected types - -- A variable has mode IN when its type is unconstrained or - -- tagged because array bounds, discriminants or tags can be - -- read. + when E_Protected_Type => + if Global_Seen then - if Appears_In (Subp_Inputs, Item_Id) - or else Is_Unconstrained_Or_Tagged_Item (Item_Id) - then - Item_Is_Input := True; + -- A variable has mode IN when its type is unconstrained + -- or tagged because array bounds, discriminants or tags + -- can be read. + + Item_Is_Input := + Appears_In (Subp_Inputs, Item_Id) + or else Is_Unconstrained_Or_Tagged_Item (Item_Id); + + Item_Is_Output := Appears_In (Subp_Outputs, Item_Id); + + else + -- A protected type acts as a formal parameter of mode IN + -- when it applies to a protected function. + + if Ekind (Spec_Id) = E_Function then + Item_Is_Input := True; + Item_Is_Output := False; + + -- Otherwise the protected type acts as a formal of mode + -- IN OUT. + + else + Item_Is_Input := True; + Item_Is_Output := True; + end if; end if; - if Appears_In (Subp_Outputs, Item_Id) then + -- Task types + + when E_Task_Type => + + -- When pragma Global is present it determines the mode of + -- the object. + + if Global_Seen then + Item_Is_Input := + Appears_In (Subp_Inputs, Item_Id) + or else Is_Unconstrained_Or_Tagged_Item (Item_Id); + + Item_Is_Output := Appears_In (Subp_Outputs, Item_Id); + + -- Otherwise task types act as IN OUT parameters + + else + Item_Is_Input := True; Item_Is_Output := True; end if; - -- Otherwise the variable has a default IN OUT mode - - else - Item_Is_Input := True; - Item_Is_Output := True; - end if; - end if; + when others => + raise Program_Error; + end case; end Find_Role; ---------------- @@ -5069,7 +5116,7 @@ package body Sem_Prag is -- pragma is inserted in its declarative part. elsif From_Aspect_Specification (N) - and then Ent = Current_Scope + and then Ent = Current_Scope and then Nkind (Unit_Declaration_Node (Ent)) = N_Subprogram_Body then @@ -28300,7 +28347,7 @@ package body Sem_Prag is if Nkind (Clause) = N_Null then null; - -- A dependency cause appears as component association + -- A dependency clause appears as component association elsif Nkind (Clause) = N_Component_Association then Collect_Dependency_Item @@ -28424,21 +28471,15 @@ package body Sem_Prag is Subp_Decl := Unit_Declaration_Node (Subp_Id); Spec_Id := Unique_Defining_Entity (Subp_Decl); - -- Process all [generic] formal parameters + -- Process all formal parameters Formal := First_Entity (Spec_Id); while Present (Formal) loop - if Ekind_In (Formal, E_Generic_In_Parameter, - E_In_Out_Parameter, - E_In_Parameter) - then + if Ekind_In (Formal, E_In_Out_Parameter, E_In_Parameter) then Append_New_Elmt (Formal, Subp_Inputs); end if; - if Ekind_In (Formal, E_Generic_In_Out_Parameter, - E_In_Out_Parameter, - E_Out_Parameter) - then + if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then Append_New_Elmt (Formal, Subp_Outputs); -- Out parameters can act as inputs when the related type is diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 3ca92ce3fb7..5ea7b0b8b03 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -764,7 +764,7 @@ package body Sem_Util is if Inside_A_Generic then Gen := Current_Scope; - while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop + while Present (Gen) and then Ekind (Gen) /= E_Generic_Package loop Gen := Scope (Gen); end loop;