From d59179b15e717e87a5c27bc90e7d16f541caa740 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 2 May 2017 10:26:12 +0200 Subject: [PATCH] [multiple changes] 2017-05-02 Ed Schonberg * sem_ch6.adb (Fully_Conformant_Expressions): Two entity references are fully conformant if they are both expansions of the discriminant of a protected type, within one of the protected operations. One occurrence may be expanded into a constant declaration while the other is an input parameter to the corresponding generated subprogram. 2017-05-02 Justin Squirek * sem_ch3.adb (Check_For_Null_Excluding_Components): Created for recursivly searching composite-types for null-excluding access types and verifying them. (Analyze_Object_Declaration): Add a call to Check_Null_Excluding_Components for static verification of non-initialized objects. * checks.adb, checks.ads (Null_Exclusion_Static_Checks): Added a parameter for a composite-type's component and an extra case for printing component information. 2017-05-02 Yannick Moy * sem_ch10.adb (Analyze_Subunit): Take configuration pragma into account when restoring appropriate pragma for analysis of subunit. 2017-05-02 Justin Squirek * s-tasren.adb, s-tasini.adb, s-taprop-linux.adb, s-mudido-affinity.adb,, a-exetim-posix.adb, a-direio.adb, g-socket.adb, s-taenca.adb, s-fileio.adb: Remove unused use-type clauses from the runtime. From-SVN: r247465 --- gcc/ada/ChangeLog | 34 +++++++++ gcc/ada/a-direio.adb | 5 +- gcc/ada/a-exetim-posix.adb | 4 +- gcc/ada/checks.adb | 31 ++++++-- gcc/ada/checks.ads | 8 +- gcc/ada/g-socket.adb | 4 +- gcc/ada/s-fileio.adb | 4 +- gcc/ada/s-mudido-affinity.adb | 7 +- gcc/ada/s-taenca.adb | 4 +- gcc/ada/s-taprop-linux.adb | 4 +- gcc/ada/s-tasini.adb | 5 +- gcc/ada/s-tasren.adb | 4 +- gcc/ada/sem_ch10.adb | 18 ++++- gcc/ada/sem_ch3.adb | 136 ++++++++++++++++++++++++++++++---- gcc/ada/sem_ch6.adb | 10 +++ 15 files changed, 223 insertions(+), 55 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index daf086f41e7..5ef8c6d51db 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,37 @@ +2017-05-02 Ed Schonberg + + * sem_ch6.adb (Fully_Conformant_Expressions): Two entity + references are fully conformant if they are both expansions + of the discriminant of a protected type, within one of the + protected operations. One occurrence may be expanded into a + constant declaration while the other is an input parameter to + the corresponding generated subprogram. + +2017-05-02 Justin Squirek + + * sem_ch3.adb (Check_For_Null_Excluding_Components): Created for + recursivly searching composite-types for null-excluding access + types and verifying them. + (Analyze_Object_Declaration): Add a + call to Check_Null_Excluding_Components for static verification + of non-initialized objects. + * checks.adb, checks.ads (Null_Exclusion_Static_Checks): Added + a parameter for a composite-type's component and an extra case + for printing component information. + +2017-05-02 Yannick Moy + + * sem_ch10.adb (Analyze_Subunit): Take + configuration pragma into account when restoring appropriate + pragma for analysis of subunit. + +2017-05-02 Justin Squirek + + * s-tasren.adb, s-tasini.adb, s-taprop-linux.adb, + s-mudido-affinity.adb,, a-exetim-posix.adb, a-direio.adb, + g-socket.adb, s-taenca.adb, s-fileio.adb: Remove unused use-type + clauses from the runtime. + 2017-05-02 Eric Botcazou * freeze.adb (Check_Component_Storage_Order): Do not treat bit-packed diff --git a/gcc/ada/a-direio.adb b/gcc/ada/a-direio.adb index ba7bd70f53b..f5063145b75 100644 --- a/gcc/ada/a-direio.adb +++ b/gcc/ada/a-direio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-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- -- @@ -39,12 +39,9 @@ with System; use System; with System.CRTL; with System.File_Control_Block; with System.File_IO; -with System.Direct_IO; with System.Storage_Elements; with Ada.Unchecked_Conversion; -use type System.Direct_IO.Count; - package body Ada.Direct_IO is Zeroes : constant System.Storage_Elements.Storage_Array := diff --git a/gcc/ada/a-exetim-posix.adb b/gcc/ada/a-exetim-posix.adb index 9c7ad57166e..10000bf23e1 100644 --- a/gcc/ada/a-exetim-posix.adb +++ b/gcc/ada/a-exetim-posix.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2007-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2007-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- -- @@ -164,7 +164,7 @@ package body Ada.Execution_Time is SC : out Ada.Real_Time.Seconds_Count; TS : out Ada.Real_Time.Time_Span) is - use type Ada.Real_Time.Time; + begin Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS); end Split; diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 90d70ab9ed6..a5a57c4e0e9 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -4037,7 +4037,10 @@ package body Checks is -- Null_Exclusion_Static_Checks -- ---------------------------------- - procedure Null_Exclusion_Static_Checks (N : Node_Id) is + procedure Null_Exclusion_Static_Checks + (N : Node_Id; + Comp : Node_Id := Empty) + is Error_Node : Node_Id; Expr : Node_Id; Has_Null : constant Boolean := Has_Null_Exclusion (N); @@ -4119,11 +4122,27 @@ package body Checks is Set_Expression (N, Make_Null (Sloc (N))); Set_Etype (Expression (N), Etype (Defining_Identifier (N))); - Apply_Compile_Time_Constraint_Error - (N => Expression (N), - Msg => - "(Ada 2005) null-excluding objects must be initialized??", - Reason => CE_Null_Not_Allowed); + if Present (Comp) then + + -- Specialize the error message to indicate that we are dealing + -- with an uninitialized composite object that has a defaulted + -- null-excluding component. + + Error_Msg_Name_1 := Chars (Defining_Identifier (Comp)); + Error_Msg_Name_2 := Chars (Defining_Identifier (N)); + + Apply_Compile_Time_Constraint_Error + (N => Expression (N), + Msg => "(Ada 2005) null-excluding component % of object % " & + "must be initialized??", + Reason => CE_Null_Not_Allowed); + else + Apply_Compile_Time_Constraint_Error + (N => Expression (N), + Msg => + "(Ada 2005) null-excluding objects must be initialized??", + Reason => CE_Null_Not_Allowed); + end if; end if; -- Check that a null-excluding component, formal or object is not being diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 2c8ac1b06d0..3df5c687c51 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -915,8 +915,14 @@ package Checks is -- Chars (Related_Id)_FIRST/_LAST. For suggested use of these parameters -- see the warning in the body of Sem_Ch3.Process_Range_Expr_In_Decl. - procedure Null_Exclusion_Static_Checks (N : Node_Id); + procedure Null_Exclusion_Static_Checks + (N : Node_Id; + Comp : Node_Id := Empty); -- Ada 2005 (AI-231): Check bad usages of the null-exclusion issue + -- + -- When a value for Comp is supplied (as in the case of an uninitialized + -- null-excluding component within a composite object), a reported error + -- will indicate the offending component instead of the object itself. procedure Remove_Checks (Expr : Node_Id); -- Remove all checks from Expr except those that are only executed diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 07931af601c..688fc82a4e2 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2016, 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- -- @@ -2633,8 +2633,6 @@ package body GNAT.Sockets is ---------------------- function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is - use type C.size_t; - Aliases_Count : Natural; begin diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb index fdc99278cee..bc98a9f87b3 100644 --- a/gcc/ada/s-fileio.adb +++ b/gcc/ada/s-fileio.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-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- -- @@ -33,7 +33,6 @@ with Ada.Finalization; use Ada.Finalization; with Ada.IO_Exceptions; use Ada.IO_Exceptions; with Ada.Unchecked_Deallocation; -with Interfaces.C; with Interfaces.C_Streams; use Interfaces.C_Streams; with System.Case_Util; use System.Case_Util; @@ -48,7 +47,6 @@ package body System.File_IO is package SSL renames System.Soft_Links; use type CRTL.size_t; - use type Interfaces.C.int; ---------------------- -- Global Variables -- diff --git a/gcc/ada/s-mudido-affinity.adb b/gcc/ada/s-mudido-affinity.adb index df3b4a83b51..b0a5fdd1898 100644 --- a/gcc/ada/s-mudido-affinity.adb +++ b/gcc/ada/s-mudido-affinity.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -77,8 +77,6 @@ package body System.Multiprocessors.Dispatching_Domains is is Target : constant ST.Task_Id := Convert_Ids (T); - use type ST.Dispatching_Domain_Access; - begin -- The exception Dispatching_Domain_Error is propagated if T is already -- assigned to a Dispatching_Domain other than @@ -127,7 +125,6 @@ package body System.Multiprocessors.Dispatching_Domains is use type ST.Dispatching_Domain; use type ST.Dispatching_Domain_Access; - use type ST.Array_Allocated_Tasks; use type ST.Task_Id; T : ST.Task_Id; @@ -331,8 +328,6 @@ package body System.Multiprocessors.Dispatching_Domains is is Target : constant ST.Task_Id := Convert_Ids (T); - use type ST.Dispatching_Domain_Access; - begin -- The exception Dispatching_Domain_Error is propagated if CPU is not -- one of the processors of the Dispatching_Domain on which T is diff --git a/gcc/ada/s-taenca.adb b/gcc/ada/s-taenca.adb index b1e9b640ba8..9fa1384a14a 100644 --- a/gcc/ada/s-taenca.adb +++ b/gcc/ada/s-taenca.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -533,8 +533,6 @@ package body System.Tasking.Entry_Calls is Self_Id : constant Task_Id := Entry_Call.Self; Timedout : Boolean := False; - use type Ada.Exceptions.Exception_Id; - begin -- This procedure waits for the entry call to be served, with a timeout. -- It tries to cancel the call if the timeout expires before the call is diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index a435617805b..745f132c850 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -1525,8 +1525,6 @@ package body System.Task_Primitives.Operations is -- 's' Interrupt_State pragma set state to System (use "default" -- system handler) - use type System.Multiprocessors.CPU_Range; - begin Environment_Task_Id := Environment_Task; diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb index 48444431c52..21404d0cd52 100644 --- a/gcc/ada/s-tasini.adb +++ b/gcc/ada/s-tasini.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -38,8 +38,6 @@ pragma Polling (Off); -- routines in this package, and more to the point, if we try to poll it can -- cause infinite loops. -with Ada.Exceptions; - with System.Task_Primitives; with System.Task_Primitives.Operations; with System.Soft_Links; @@ -234,7 +232,6 @@ package body System.Tasking.Initialization is -- Call only when holding no locks procedure Do_Pending_Action (Self_ID : Task_Id) is - use type Ada.Exceptions.Exception_Id; begin pragma Assert (Self_ID = Self and then Self_ID.Deferral_Level = 0); diff --git a/gcc/ada/s-tasren.adb b/gcc/ada/s-tasren.adb index 34cf94c94aa..b5e85e15087 100644 --- a/gcc/ada/s-tasren.adb +++ b/gcc/ada/s-tasren.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -547,8 +547,6 @@ package body System.Tasking.Rendezvous is Source : Ada.Exceptions.Exception_Occurrence); pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); - use type STPE.Protection_Entries_Access; - begin -- The deferral level is critical here, since we want to raise an -- exception or allow abort to take place, if there is an exception or diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 1f6b237569f..07f9f8c730f 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -2288,10 +2288,10 @@ package body Sem_Ch10 is Pop_Scope; end Remove_Scope; - Saved_SM : constant SPARK_Mode_Type := SPARK_Mode; - Saved_SMP : constant Node_Id := SPARK_Mode_Pragma; + Saved_SM : SPARK_Mode_Type := SPARK_Mode; + Saved_SMP : Node_Id := SPARK_Mode_Pragma; -- Save the SPARK mode-related data to restore on exit. Removing - -- eclosing scopes and contexts to provide a clean environment for the + -- enclosing scopes and contexts to provide a clean environment for the -- context of the subunit will eliminate any previously set SPARK_Mode. -- Start of processing for Analyze_Subunit @@ -2351,6 +2351,15 @@ package body Sem_Ch10 is Analyze_Subunit_Context; + -- Take into account the effect of any SPARK_Mode configuration + -- pragma, which takes precedence over a different value of + -- SPARK_Mode inherited from the context of the stub. + + if SPARK_Mode /= None then + Saved_SM := SPARK_Mode; + Saved_SMP := SPARK_Mode_Pragma; + end if; + Re_Install_Parents (Lib_Unit, Par_Unit); Set_Is_Immediately_Visible (Par_Unit); @@ -2392,7 +2401,8 @@ package body Sem_Ch10 is Generate_Parent_References (Unit (N), Par_Unit); -- Reinstall the SPARK_Mode which was in effect prior to any scope and - -- context manipulations. + -- context manipulations, taking into account a possible SPARK_Mode + -- configuration pragma if present. Install_SPARK_Mode (Saved_SM, Saved_SMP); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index bf92e7d7ad3..245601595bb 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3588,6 +3588,13 @@ package body Sem_Ch3 is Prev_Entity : Entity_Id := Empty; + procedure Check_For_Null_Excluding_Components + (Obj_Typ : Entity_Id; + Obj_Decl : Node_Id); + -- Recursively verify that each null-excluding component of an object + -- declaration's type has explicit initialization, and generate + -- compile-time warnings for each one that does not. + function Count_Tasks (T : Entity_Id) return Uint; -- This function is called when a non-generic library level object of a -- task type is declared. Its function is to count the static number of @@ -3607,6 +3614,100 @@ package body Sem_Ch3 is -- Any other relevant delayed aspects on object declarations ??? + ----------------------------------------- + -- Check_For_Null_Excluding_Components -- + ----------------------------------------- + + procedure Check_For_Null_Excluding_Components + (Obj_Typ : Entity_Id; + Obj_Decl : Node_Id) + is + + procedure Check_Component + (Comp_Typ : Entity_Id; + Comp_Decl : Node_Id := Empty); + -- Perform compile-time null-exclusion checks on a given component + -- and all of its subcomponents, if any. + + --------------------- + -- Check_Component -- + --------------------- + + procedure Check_Component + (Comp_Typ : Entity_Id; + Comp_Decl : Node_Id := Empty) + is + Comp : Entity_Id; + T : Entity_Id; + + begin + -- Return without further checking if the component has explicit + -- initialization or does not come from source. + + if Present (Comp_Decl) then + if not Comes_From_Source (Comp_Decl) + or else Present (Expression (Comp_Decl)) + then + return; + end if; + end if; + + if Is_Incomplete_Or_Private_Type (Comp_Typ) + and then Present (Full_View (Comp_Typ)) + then + T := Full_View (Comp_Typ); + else + T := Comp_Typ; + end if; + + -- Verify a component of a null-excluding access type + + if Is_Access_Type (T) + and then Can_Never_Be_Null (T) + then + Null_Exclusion_Static_Checks (Obj_Decl, Comp_Decl); + + -- Check array type components + + elsif Is_Array_Type (T) then + -- There is no suitable component when the object is of an + -- array type. However, a namable component may appear at some + -- point during the recursive inspection, but not at the top + -- level. + + if Comp_Decl = Obj_Decl then + Check_Component (Component_Type (T)); + else + Check_Component (Component_Type (T), Comp_Decl); + end if; + + -- If T allows named components, then iterate through them, + -- recursively verifying all subcomponents. + + -- NOTE: Due to the complexities involved with checking components + -- of nontrivial types with discriminants (variant records and + -- the like), no static checking is performed on them. ??? + + elsif (Is_Concurrent_Type (T) + or else Is_Incomplete_Or_Private_Type (T) + or else Is_Record_Type (T)) + and then not Has_Discriminants (T) + then + Comp := First_Component (T); + while Present (Comp) loop + Check_Component (Etype (Comp), Parent (Comp)); + + Comp := Next_Component (Comp); + end loop; + end if; + end Check_Component; + + -- Start processing for Check_For_Null_Excluding_Components + + begin + Check_Component (Obj_Typ, Obj_Decl); + end Check_For_Null_Excluding_Components; + ----------------- -- Count_Tasks -- ----------------- @@ -3808,25 +3909,34 @@ package body Sem_Ch3 is -- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry -- out some static checks. - if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (T) then - + if Ada_Version >= Ada_2005 then -- In case of aggregates we must also take care of the correct -- initialization of nested aggregates bug this is done at the -- point of the analysis of the aggregate (see sem_aggr.adb) ??? - if Present (Expression (N)) - and then Nkind (Expression (N)) = N_Aggregate - then - null; + if Can_Never_Be_Null (T) then + + if Present (Expression (N)) + and then Nkind (Expression (N)) = N_Aggregate + then + null; + + else + declare + Save_Typ : constant Entity_Id := Etype (Id); + begin + Set_Etype (Id, T); -- Temp. decoration for static checks + Null_Exclusion_Static_Checks (N); + Set_Etype (Id, Save_Typ); + end; + end if; + + -- We might be dealing with an object of a composite type containing + -- null-excluding components without an aggregate, so we must verify + -- that such components have default initialization. else - declare - Save_Typ : constant Entity_Id := Etype (Id); - begin - Set_Etype (Id, T); -- Temp. decoration for static checks - Null_Exclusion_Static_Checks (N); - Set_Etype (Id, Save_Typ); - end; + Check_For_Null_Excluding_Components (T, N); end if; end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 17fd71d58bd..98c893b684b 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -8770,6 +8770,16 @@ package body Sem_Ch6 is and then Ekind (Entity (E1)) = E_Discriminant and then Ekind (Entity (E2)) = E_In_Parameter) + -- The discriminant of a protected type is transformed into + -- a local constant and then into a parameter of a protected + -- operation. + + or else (Ekind (Entity (E1)) = E_Constant + and then Ekind (Entity (E2)) = E_In_Parameter + and then Present (Discriminal_Link (Entity (E1))) + and then Discriminal_Link (Entity (E1)) = + Discriminal_Link (Entity (E2))) + -- AI12-050: The loop variables of quantified expressions -- match if they have the same identifier, even though they -- are different entities. -- 2.30.2