diff options
| author | Pierre-Marie de Rodat <pmderodat@gcc.gnu.org> | 2017-09-25 10:07:11 +0000 |
|---|---|---|
| committer | Pierre-Marie de Rodat <pmderodat@gcc.gnu.org> | 2017-09-25 10:07:11 +0000 |
| commit | 851e9f19e27e1f840f9a978fc7103397043d8826 (patch) | |
| tree | bbf6e9f5960f6e784986aa1c87d0fa80e3ccf36c | |
| parent | 61b1489667e08d7b1ef6672682906072df7bc369 (diff) | |
| download | gcc-851e9f19e27e1f840f9a978fc7103397043d8826.zip gcc-851e9f19e27e1f840f9a978fc7103397043d8826.tar.gz gcc-851e9f19e27e1f840f9a978fc7103397043d8826.tar.bz2 | |
[multiple changes]
2017-09-25 Justin Squirek <squirek@adacore.com>
* aspects.adb, bindgen.adb, clean.adb, erroutc.adb, exp_ch13.adb,
exp_dbug.adb, exp_unst.adb, exp_util.adb, frontend.adb, gnat1drv.adb,
gnatdll.adb, gnatlink.adb, gnatls.adb, gnatname.adb, gnatxref.adb,
gnatfind.adb, libgnat/a-cfhama.ads, libgnat/a-exetim__mingw.adb,
libgnat/a-strmap.adb, libgnat/a-teioed.adb, libgnat/g-alvety.ads,
libgnat/g-expect.adb, libgnat/g-regist.adb, libgnat/g-socket.adb,
libgnat/g-socthi__mingw.ads, libgnat/s-stausa.adb,
libgnat/s-tsmona__linux.adb, libgnat/s-tsmona__mingw.adb,
libgnarl/s-taenca.adb, libgnarl/s-tassta.adb, libgnarl/s-tarest.adb,
libgnarl/s-tpobop.adb, make.adb, makeusg.adb, namet.adb, output.ads,
put_scos.adb, repinfo.adb, rtsfind.adb, scn.ads, sem_attr.adb,
sem_aux.ads, sem_warn.ads, targparm.adb, xr_tabls.adb, xref_lib.adb:
Removal of ineffective use-clauses.
* exp_ch9.adb (Is_Simple_Barrier_Name): Check for false positives with
constant folded barriers.
* ghost.adb, sprint.adb, sem_ch10.adb, sem_warn.adb: Change access to
Subtype_Marks and Names list in use-clause nodes to their new singular
counterparts (e.g. Subtype_Mark, Name).
* par.adb, par-ch8.adb (Append_Use_Clause): Created to set
Prev_Ids and More_Ids in use-clause nodes.
(P_Use_Clause): Modify to take a list as a parameter.
(P_Use_Package_Clause, P_Use_Type_Clause): Divide names and
subtype_marks within an aggregate use-clauses into individual clauses.
* par-ch3.adb, par-ch10.adb, par-ch12.adb: Trivally modify call to
P_Use_Clause to match its new behavior.
* sem.adb (Analyze): Mark use clauses for non-overloaded entities.
* sem_ch4.adb (Try_One_Interp): Add sanity check to handle previous
errors.
* sem_ch6.adb (Analyze_Generic_Subprogram_Body,
Analyze_Subprogram_Body_Helper): Update use clause chain at the end of
the declarative region.
* sem_ch7.adb (Analyze_Package_Body_Helper): Update use clause chain
after analysis (Analyze_Package_Specification): Update use clause chain
when there is no body.
* sem_ch8.ads, sem_ch8.adb (Analyze_Use_Package, Analyze_Use_Type): Add
parameter to determine weither the installation of scopes should also
propagate on the use-clause "chain".
(Mark_Use_Clauses): Created to traverse use-clause chains and determine
what constitutes a valid "use" of a clause.
(Update_Use_Clause_Chain): Created to aggregate common machinary used
to clean up use-clause chains (and warn on ineffectiveness) at the end
of declaritive regions.
* sem_ch8.adb (Analyze_Package_Name): Created to perform analysis on a
package name from a use-package clause.
(Analyze_Package_Name_List): Created to perform analysis on a list of
package names (similar to Analyze_Package_Name).
(Find_Most_Prev): Created to traverse to the beginning of a given
use-clause chain.
(Most_Decendant_Use_Clause): Create to identify which clause from a
given set is highest in scope (not always the most prev).
(Use_One_Package, Use_One_Type): Major cleanup and reorganization to
handle the new chaining algorithm, also many changes related to
redundant clauses. A new parameter has also been added to force
installation to handle certain cases.
* sem_ch9.adb (Analyze_Entry_Body, Analyze_Protected_Body,
Analyze_Task_Body): Mark use clauses on relevant entities.
* sem_ch10.adb, sem_ch10.ads (Install_Context_Clauses,
Install_Parents): Add parameter to determine weither the installation
of scopes should also propagate on the use-clause "chain".
* sem_ch12.adb (Inline_Instance_Body): Add flag in call to
Install_Context to avoid redundant chaining of use-clauses.
* sem_ch13.adb: Minor reformatting.
* sem_res.adb (Resolve): Mark use clauses on operators.
(Resolve_Call, Resolve_Entity_Name): Mark use clauses on relevant
entities.
* sinfo.adb, sinfo.ads (Is_Effective_Use_Clause,
Set_Is_Effective_Use_Clause): Add new flag to N_Use_Clause nodes to
represent any given clause's usage/reference/necessity.
(Prev_Use_Clause, Set_Prev_Use_Clause): Add new field to N_Use_Clause
nodes to allow loose chaining of redundant clauses.
(Set_Used_Operations, Set_Subtype_Mark, Set_Prev_Ids, Set_Names,
Set_More_Ids, Set_Name): Modify set procedure calls to reflect
reorganization in node fields.
* types.ads (Source_File_Index): Adjust index bounds.
(No_Access_To_Source_File): New constant.
2017-09-25 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Analyze_One_Aspect): In ASIS mode make a full copy of
the expression to be used in the generated attribute specification
(rather than relocating it) to avoid resolving a potentially malformed
tree when the expression is resolved through an ASIS-specific call to
Resolve_Aspect_Expressions. This manifests itself as a crash on a
function with parameter associations.
From-SVN: r253144
73 files changed, 1660 insertions, 903 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 28fa8f1..2657531 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,90 @@ +2017-09-25 Justin Squirek <squirek@adacore.com> + + * aspects.adb, bindgen.adb, clean.adb, erroutc.adb, exp_ch13.adb, + exp_dbug.adb, exp_unst.adb, exp_util.adb, frontend.adb, gnat1drv.adb, + gnatdll.adb, gnatlink.adb, gnatls.adb, gnatname.adb, gnatxref.adb, + gnatfind.adb, libgnat/a-cfhama.ads, libgnat/a-exetim__mingw.adb, + libgnat/a-strmap.adb, libgnat/a-teioed.adb, libgnat/g-alvety.ads, + libgnat/g-expect.adb, libgnat/g-regist.adb, libgnat/g-socket.adb, + libgnat/g-socthi__mingw.ads, libgnat/s-stausa.adb, + libgnat/s-tsmona__linux.adb, libgnat/s-tsmona__mingw.adb, + libgnarl/s-taenca.adb, libgnarl/s-tassta.adb, libgnarl/s-tarest.adb, + libgnarl/s-tpobop.adb, make.adb, makeusg.adb, namet.adb, output.ads, + put_scos.adb, repinfo.adb, rtsfind.adb, scn.ads, sem_attr.adb, + sem_aux.ads, sem_warn.ads, targparm.adb, xr_tabls.adb, xref_lib.adb: + Removal of ineffective use-clauses. + * exp_ch9.adb (Is_Simple_Barrier_Name): Check for false positives with + constant folded barriers. + * ghost.adb, sprint.adb, sem_ch10.adb, sem_warn.adb: Change access to + Subtype_Marks and Names list in use-clause nodes to their new singular + counterparts (e.g. Subtype_Mark, Name). + * par.adb, par-ch8.adb (Append_Use_Clause): Created to set + Prev_Ids and More_Ids in use-clause nodes. + (P_Use_Clause): Modify to take a list as a parameter. + (P_Use_Package_Clause, P_Use_Type_Clause): Divide names and + subtype_marks within an aggregate use-clauses into individual clauses. + * par-ch3.adb, par-ch10.adb, par-ch12.adb: Trivally modify call to + P_Use_Clause to match its new behavior. + * sem.adb (Analyze): Mark use clauses for non-overloaded entities. + * sem_ch4.adb (Try_One_Interp): Add sanity check to handle previous + errors. + * sem_ch6.adb (Analyze_Generic_Subprogram_Body, + Analyze_Subprogram_Body_Helper): Update use clause chain at the end of + the declarative region. + * sem_ch7.adb (Analyze_Package_Body_Helper): Update use clause chain + after analysis (Analyze_Package_Specification): Update use clause chain + when there is no body. + * sem_ch8.ads, sem_ch8.adb (Analyze_Use_Package, Analyze_Use_Type): Add + parameter to determine weither the installation of scopes should also + propagate on the use-clause "chain". + (Mark_Use_Clauses): Created to traverse use-clause chains and determine + what constitutes a valid "use" of a clause. + (Update_Use_Clause_Chain): Created to aggregate common machinary used + to clean up use-clause chains (and warn on ineffectiveness) at the end + of declaritive regions. + * sem_ch8.adb (Analyze_Package_Name): Created to perform analysis on a + package name from a use-package clause. + (Analyze_Package_Name_List): Created to perform analysis on a list of + package names (similar to Analyze_Package_Name). + (Find_Most_Prev): Created to traverse to the beginning of a given + use-clause chain. + (Most_Decendant_Use_Clause): Create to identify which clause from a + given set is highest in scope (not always the most prev). + (Use_One_Package, Use_One_Type): Major cleanup and reorganization to + handle the new chaining algorithm, also many changes related to + redundant clauses. A new parameter has also been added to force + installation to handle certain cases. + * sem_ch9.adb (Analyze_Entry_Body, Analyze_Protected_Body, + Analyze_Task_Body): Mark use clauses on relevant entities. + * sem_ch10.adb, sem_ch10.ads (Install_Context_Clauses, + Install_Parents): Add parameter to determine weither the installation + of scopes should also propagate on the use-clause "chain". + * sem_ch12.adb (Inline_Instance_Body): Add flag in call to + Install_Context to avoid redundant chaining of use-clauses. + * sem_ch13.adb: Minor reformatting. + * sem_res.adb (Resolve): Mark use clauses on operators. + (Resolve_Call, Resolve_Entity_Name): Mark use clauses on relevant + entities. + * sinfo.adb, sinfo.ads (Is_Effective_Use_Clause, + Set_Is_Effective_Use_Clause): Add new flag to N_Use_Clause nodes to + represent any given clause's usage/reference/necessity. + (Prev_Use_Clause, Set_Prev_Use_Clause): Add new field to N_Use_Clause + nodes to allow loose chaining of redundant clauses. + (Set_Used_Operations, Set_Subtype_Mark, Set_Prev_Ids, Set_Names, + Set_More_Ids, Set_Name): Modify set procedure calls to reflect + reorganization in node fields. + * types.ads (Source_File_Index): Adjust index bounds. + (No_Access_To_Source_File): New constant. + +2017-09-25 Ed Schonberg <schonberg@adacore.com> + + * sem_ch13.adb (Analyze_One_Aspect): In ASIS mode make a full copy of + the expression to be used in the generated attribute specification + (rather than relocating it) to avoid resolving a potentially malformed + tree when the expression is resolved through an ASIS-specific call to + Resolve_Aspect_Expressions. This manifests itself as a crash on a + function with parameter associations. + 2017-09-25 Yannick Moy <moy@adacore.com> * exp_spark.adb (Expand_SPARK_Indexed_Component, diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index d5ec072..821f4b5 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -35,7 +35,7 @@ with Nlists; use Nlists; with Sinfo; use Sinfo; with Tree_IO; use Tree_IO; -with GNAT.HTable; use GNAT.HTable; +with GNAT.HTable; package body Aspects is diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 59b43e0..a9ea20e 100644 --- a/gcc/ada/bindgen.adb +++ b/gcc/ada/bindgen.adb @@ -35,19 +35,17 @@ with Osint.B; use Osint.B; with Output; use Output; with Rident; use Rident; with Stringt; use Stringt; -with Table; use Table; +with Table; with Targparm; use Targparm; with Types; use Types; -with System.OS_Lib; use System.OS_Lib; +with System.OS_Lib; with System.WCh_Con; use System.WCh_Con; with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; with GNAT.HTable; package body Bindgen is - use Binde.Unit_Id_Tables; - Statement_Buffer : String (1 .. 1000); -- Buffer used for constructing output statements diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb index 2b3d033..891575e 100644 --- a/gcc/ada/clean.adb +++ b/gcc/ada/clean.adb @@ -31,7 +31,7 @@ with Osint; use Osint; with Osint.M; use Osint.M; with Switch; use Switch; with Table; -with Targparm; use Targparm; +with Targparm; with Types; use Types; with Ada.Command_Line; use Ada.Command_Line; diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index f81d337..b77d53d 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -41,7 +41,7 @@ with Output; use Output; with Sinput; use Sinput; with Snames; use Snames; with Stringt; use Stringt; -with Targparm; use Targparm; +with Targparm; with Uintp; use Uintp; with Widechar; use Widechar; diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 0e0bbca..4637d04 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.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- -- @@ -27,7 +27,7 @@ with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; with Exp_Ch3; use Exp_Ch3; -with Exp_Ch6; use Exp_Ch6; +with Exp_Ch6; with Exp_Imgv; use Exp_Imgv; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 0cd4fde..37399ad 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -6006,6 +6006,14 @@ package body Exp_Ch9 is -- reference will have been rewritten. if Expander_Active then + -- The expanded name may have been constant folded in which case + -- the original node is not necessarily an entity name (e.g. an + -- indexed component). + + if not Is_Entity_Name (Original_Node (N)) then + return False; + end if; + Renamed := Renamed_Object (Entity (Original_Node (N))); return diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb index 1b51d53..70c21c0 100644 --- a/gcc/ada/exp_dbug.adb +++ b/gcc/ada/exp_dbug.adb @@ -23,7 +23,7 @@ -- -- ------------------------------------------------------------------------------ -with Alloc; use Alloc; +with Alloc; with Atree; use Atree; with Debug; use Debug; with Einfo; use Einfo; diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 62d9d33..063b60f 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2014-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2014-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- -- @@ -31,7 +31,7 @@ with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; -with Opt; use Opt; +with Opt; with Output; use Output; with Rtsfind; use Rtsfind; with Sem; use Sem; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index b8c528e..c9650ce 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -65,8 +65,7 @@ with Ttypes; use Ttypes; with Urealp; use Urealp; with Validsw; use Validsw; -with GNAT.HTable; use GNAT.HTable; - +with GNAT.HTable; package body Exp_Util is --------------------------------------------------------- diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 378aacd..c550858 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -38,7 +38,7 @@ with Ghost; use Ghost; with Inline; use Inline; with Lib; use Lib; with Lib.Load; use Lib.Load; -with Lib.Xref; use Lib.Xref; +with Lib.Xref; with Live; use Live; with Namet; use Namet; with Nlists; use Nlists; @@ -49,21 +49,21 @@ with Prep; with Prepcomp; with Restrict; use Restrict; with Rident; use Rident; -with Rtsfind; use Rtsfind; +with Rtsfind; with Snames; use Snames; with Sprint; with Scn; use Scn; with Sem; use Sem; with Sem_Aux; -with Sem_Ch8; use Sem_Ch8; +with Sem_Ch8; with Sem_SCIL; with Sem_Elab; use Sem_Elab; with Sem_Prag; use Sem_Prag; -with Sem_Warn; use Sem_Warn; +with Sem_Warn; with Sinfo; use Sinfo; with Sinput; use Sinput; with Sinput.L; use Sinput.L; -with SCIL_LL; use SCIL_LL; +with SCIL_LL; with Tbuild; use Tbuild; with Types; use Types; @@ -168,7 +168,6 @@ begin -- Case of gnat.adc file present if Source_gnat_adc /= No_Source_File then - -- Parse the gnat.adc file for configuration pragmas Initialize_Scanner (No_Unit, Source_gnat_adc); diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb index 6640d6a..e7ca3bf 100644 --- a/gcc/ada/ghost.adb +++ b/gcc/ada/ghost.adb @@ -23,7 +23,7 @@ -- -- ------------------------------------------------------------------------------ -with Alloc; use Alloc; +with Alloc; with Aspects; use Aspects; with Atree; use Atree; with Einfo; use Einfo; @@ -1477,10 +1477,10 @@ package body Ghost is begin if Nkind (N) = N_Use_Package_Clause then - Nam := First (Names (N)); + Nam := Name (N); elsif Nkind (N) = N_Use_Type_Clause then - Nam := First (Subtype_Marks (N)); + Nam := Subtype_Mark (N); elsif Nkind (N) = N_With_Clause then Nam := Name (N); diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index c3377da..0e3bc27 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -27,7 +27,7 @@ with Atree; use Atree; with Back_End; use Back_End; with Checks; with Comperr; -with Csets; use Csets; +with Csets; with Debug; use Debug; with Elists; with Errout; use Errout; @@ -76,7 +76,7 @@ with Tree_Gen; with Treepr; use Treepr; with Ttypes; with Types; use Types; -with Uintp; use Uintp; +with Uintp; with Uname; use Uname; with Urealp; with Usage; diff --git a/gcc/ada/gnatdll.adb b/gcc/ada/gnatdll.adb index 94b39b8..736979a 100644 --- a/gcc/ada/gnatdll.adb +++ b/gcc/ada/gnatdll.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-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- -- @@ -28,7 +28,7 @@ with Gnatvsn; with MDLL.Fil; use MDLL.Fil; -with MDLL.Utl; use MDLL.Utl; +with MDLL.Utl; with Switch; use Switch; with Ada.Text_IO; use Ada.Text_IO; @@ -41,8 +41,6 @@ with GNAT.Command_Line; use GNAT.Command_Line; procedure Gnatdll is - use type GNAT.OS_Lib.Argument_List; - procedure Syntax; -- Print out usage diff --git a/gcc/ada/gnatfind.adb b/gcc/ada/gnatfind.adb index 0d030be..9e427ba 100644 --- a/gcc/ada/gnatfind.adb +++ b/gcc/ada/gnatfind.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -27,7 +27,7 @@ with Opt; with Osint; use Osint; with Switch; use Switch; with Types; use Types; -with Xr_Tabls; use Xr_Tabls; +with Xr_Tabls; with Xref_Lib; use Xref_Lib; with Ada.Command_Line; use Ada.Command_Line; diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 073c2c9..5e290eb 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1996-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1996-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- -- @@ -37,7 +37,7 @@ with Snames; with Switch; use Switch; with System; use System; with Table; -with Targparm; use Targparm; +with Targparm; with Types; with Ada.Command_Line; use Ada.Command_Line; diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb index a120ee4..925ae2c 100644 --- a/gcc/ada/gnatls.adb +++ b/gcc/ada/gnatls.adb @@ -29,7 +29,7 @@ with ALI; use ALI; with ALI.Util; use ALI.Util; with Binderr; use Binderr; with Butil; use Butil; -with Csets; use Csets; +with Csets; with Fname; use Fname; with Gnatvsn; use Gnatvsn; with Make_Util; use Make_Util; diff --git a/gcc/ada/gnatname.adb b/gcc/ada/gnatname.adb index 7540a1e..4a9973f 100644 --- a/gcc/ada/gnatname.adb +++ b/gcc/ada/gnatname.adb @@ -36,7 +36,7 @@ with Make_Util; use Make_Util; with Namet; use Namet; with Opt; with Osint; use Osint; -with Output; use Output; +with Output; with Switch; use Switch; with Table; with Tempdir; diff --git a/gcc/ada/gnatxref.adb b/gcc/ada/gnatxref.adb index c24fd49..e458d03 100644 --- a/gcc/ada/gnatxref.adb +++ b/gcc/ada/gnatxref.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -27,11 +27,11 @@ with Opt; with Osint; use Osint; with Types; use Types; with Switch; use Switch; -with Xr_Tabls; use Xr_Tabls; +with Xr_Tabls; with Xref_Lib; use Xref_Lib; with Ada.Command_Line; use Ada.Command_Line; -with Ada.Strings.Fixed; use Ada.Strings.Fixed; +with Ada.Strings.Fixed; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Command_Line; use GNAT.Command_Line; diff --git a/gcc/ada/gprep.adb b/gcc/ada/gprep.adb index cc7e243..825a537 100644 --- a/gcc/ada/gprep.adb +++ b/gcc/ada/gprep.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-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- -- @@ -249,6 +249,10 @@ package body GPrep is Fail ("unable to find definition file """ & Get_Name_String (Deffile_Name) & """"); + elsif Deffile = No_Access_To_Source_File then + Fail ("unabled to read definition file """ + & Get_Name_String (Deffile_Name) + & """"); end if; Scanner.Initialize_Scanner (Deffile); @@ -514,6 +518,10 @@ package body GPrep is Fail ("unable to find input file """ & Get_Name_String (Infile_Name) & """"); + elsif Infile = No_Access_To_Source_File then + Fail ("unable to read input file """ + & Get_Name_String (Infile_Name) + & """"); end if; -- Set Main_Source_File to the input file for the benefit of diff --git a/gcc/ada/libgnarl/a-exetim__mingw.adb b/gcc/ada/libgnarl/a-exetim__mingw.adb index 264ba9d..7555b16 100644 --- a/gcc/ada/libgnarl/a-exetim__mingw.adb +++ b/gcc/ada/libgnarl/a-exetim__mingw.adb @@ -153,7 +153,6 @@ 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/libgnarl/s-taenca.adb b/gcc/ada/libgnarl/s-taenca.adb index 1236194..dc5dcf0 100644 --- a/gcc/ada/libgnarl/s-taenca.adb +++ b/gcc/ada/libgnarl/s-taenca.adb @@ -42,7 +42,6 @@ package body System.Tasking.Entry_Calls is package STPO renames System.Task_Primitives.Operations; use Parameters; - use Task_Primitives; use Protected_Objects.Entries; use Protected_Objects.Operations; diff --git a/gcc/ada/libgnarl/s-tarest.adb b/gcc/ada/libgnarl/s-tarest.adb index 4bf2df6..daff5c1 100644 --- a/gcc/ada/libgnarl/s-tarest.adb +++ b/gcc/ada/libgnarl/s-tarest.adb @@ -72,7 +72,6 @@ package body System.Tasking.Restricted.Stages is use Parameters; use Task_Primitives.Operations; - use Task_Info; Tasks_Activation_Chain : Task_Id; -- Chain of all the tasks to activate diff --git a/gcc/ada/libgnarl/s-tassta.adb b/gcc/ada/libgnarl/s-tassta.adb index 346e5bf..44c054f 100644 --- a/gcc/ada/libgnarl/s-tassta.adb +++ b/gcc/ada/libgnarl/s-tassta.adb @@ -78,7 +78,6 @@ package body System.Tasking.Stages is use Parameters; use Task_Primitives; use Task_Primitives.Operations; - use Task_Info; ----------------------- -- Local Subprograms -- @@ -1045,7 +1044,6 @@ package body System.Tasking.Stages is function Secondary_Stack_Size return Storage_Elements.Storage_Offset is use System.Storage_Elements; - use System.Secondary_Stack; begin if Parameters.Sec_Stack_Dynamic then @@ -1539,7 +1537,6 @@ package body System.Tasking.Stages is pragma Import (Ada, To_Stderr, "__gnat_to_stderr"); use System.Soft_Links; - use System.Standard_Library; function To_Address is new Ada.Unchecked_Conversion diff --git a/gcc/ada/libgnarl/s-tpobop.adb b/gcc/ada/libgnarl/s-tpobop.adb index 242fe45..251ae87 100644 --- a/gcc/ada/libgnarl/s-tpobop.adb +++ b/gcc/ada/libgnarl/s-tpobop.adb @@ -60,7 +60,6 @@ package body System.Tasking.Protected_Objects.Operations is package STPO renames System.Task_Primitives.Operations; use Parameters; - use Task_Primitives; use Ada.Exceptions; use Entries; diff --git a/gcc/ada/libgnat/a-cfhama.ads b/gcc/ada/libgnat/a-cfhama.ads index e02accc..feaa3b1 100644 --- a/gcc/ada/libgnat/a-cfhama.ads +++ b/gcc/ada/libgnat/a-cfhama.ads @@ -808,8 +808,6 @@ private type Map (Capacity : Count_Type; Modulus : Hash_Type) is new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; - use HT_Types; - Empty_Map : constant Map := (Capacity => 0, Modulus => 0, others => <>); end Ada.Containers.Formal_Hashed_Maps; diff --git a/gcc/ada/libgnat/a-strmap.adb b/gcc/ada/libgnat/a-strmap.adb index a98556b..0f68f18 100644 --- a/gcc/ada/libgnat/a-strmap.adb +++ b/gcc/ada/libgnat/a-strmap.adb @@ -37,8 +37,6 @@ package body Ada.Strings.Maps is - use Ada.Characters.Latin_1; - --------- -- "-" -- --------- diff --git a/gcc/ada/libgnat/a-teioed.adb b/gcc/ada/libgnat/a-teioed.adb index 93e69f6..4260682 100644 --- a/gcc/ada/libgnat/a-teioed.adb +++ b/gcc/ada/libgnat/a-teioed.adb @@ -1019,7 +1019,6 @@ package body Ada.Text_IO.Editing is ------------------- procedure Debug_Integer (Value : Integer; S : String) is - use Ada.Text_IO; -- needed for > begin if Debug and then Value > 0 then diff --git a/gcc/ada/libgnat/g-alvety.ads b/gcc/ada/libgnat/g-alvety.ads index 623a5fc..a697e62 100644 --- a/gcc/ada/libgnat/g-alvety.ads +++ b/gcc/ada/libgnat/g-alvety.ads @@ -36,8 +36,6 @@ with GNAT.Altivec.Low_Level_Vectors; package GNAT.Altivec.Vector_Types is - use GNAT.Altivec.Low_Level_Vectors; - --------------------------------------------------- -- Vector type declarations [PIM-2.1 Data Types] -- --------------------------------------------------- diff --git a/gcc/ada/libgnat/g-expect.adb b/gcc/ada/libgnat/g-expect.adb index 4435b6a..5546601 100644 --- a/gcc/ada/libgnat/g-expect.adb +++ b/gcc/ada/libgnat/g-expect.adb @@ -907,8 +907,6 @@ package body GNAT.Expect is Status : not null access Integer; Err_To_Out : Boolean := False) return String is - use GNAT.Expect; - Process : Process_Descriptor; Output : String_Access := new String (1 .. 1024); diff --git a/gcc/ada/libgnat/g-regist.adb b/gcc/ada/libgnat/g-regist.adb index 5b097bb..02e07fd 100644 --- a/gcc/ada/libgnat/g-regist.adb +++ b/gcc/ada/libgnat/g-regist.adb @@ -184,9 +184,6 @@ package body GNAT.Registry is Sub_Key : String; Mode : Key_Mode := Read_Write) return HKEY is - use type REGSAM; - use type DWORD; - REG_OPTION_NON_VOLATILE : constant := 16#0#; C_Sub_Key : constant String := Sub_Key & ASCII.NUL; @@ -425,8 +422,6 @@ package body GNAT.Registry is Sub_Key : String; Mode : Key_Mode := Read_Only) return HKEY is - use type REGSAM; - C_Sub_Key : constant String := Sub_Key & ASCII.NUL; C_Mode : constant REGSAM := To_C_Mode (Mode); @@ -456,7 +451,6 @@ package body GNAT.Registry is Expand : Boolean := False) return String is use GNAT.Directory_Operations; - use type LONG; use type ULONG; Value : String (1 .. Max_Value_Size); diff --git a/gcc/ada/libgnat/g-socket.adb b/gcc/ada/libgnat/g-socket.adb index 9b2ad7f..519776e 100644 --- a/gcc/ada/libgnat/g-socket.adb +++ b/gcc/ada/libgnat/g-socket.adb @@ -2175,7 +2175,6 @@ package body GNAT.Sockets is Count : out Ada.Streams.Stream_Element_Count; Flags : Request_Flag_Type := No_Request_Flag) is - use SOSC; use Interfaces.C; Res : ssize_t; diff --git a/gcc/ada/libgnat/g-socthi__mingw.ads b/gcc/ada/libgnat/g-socthi__mingw.ads index 48f5aeb..fa76172 100644 --- a/gcc/ada/libgnat/g-socthi__mingw.ads +++ b/gcc/ada/libgnat/g-socthi__mingw.ads @@ -48,8 +48,6 @@ package GNAT.Sockets.Thin is package C renames Interfaces.C; - use type System.CRTL.ssize_t; - function Socket_Errno return Integer; -- Returns last socket error number diff --git a/gcc/ada/libgnat/s-stausa.adb b/gcc/ada/libgnat/s-stausa.adb index f652e7a..da5db75 100644 --- a/gcc/ada/libgnat/s-stausa.adb +++ b/gcc/ada/libgnat/s-stausa.adb @@ -35,7 +35,6 @@ with System.IO; package body System.Stack_Usage is use System.Storage_Elements; - use System; use System.IO; use Interfaces; diff --git a/gcc/ada/libgnat/s-tsmona__linux.adb b/gcc/ada/libgnat/s-tsmona__linux.adb index 8c1f8b4..49b73b6 100644 --- a/gcc/ada/libgnat/s-tsmona__linux.adb +++ b/gcc/ada/libgnat/s-tsmona__linux.adb @@ -38,8 +38,6 @@ separate (System.Traceback.Symbolic) package body Module_Name is - use System; - pragma Linker_Options ("-ldl"); function Is_Shared_Lib (Base : Address) return Boolean; diff --git a/gcc/ada/libgnat/s-tsmona__mingw.adb b/gcc/ada/libgnat/s-tsmona__mingw.adb index 46c35cd..3205c0a 100644 --- a/gcc/ada/libgnat/s-tsmona__mingw.adb +++ b/gcc/ada/libgnat/s-tsmona__mingw.adb @@ -37,8 +37,6 @@ separate (System.Traceback.Symbolic) package body Module_Name is - use System; - --------------------------------- -- Build_Cache_For_All_Modules -- --------------------------------- diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index cbd110d..75048d2 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -23,26 +23,26 @@ -- -- ------------------------------------------------------------------------------ -with ALI; use ALI; -with ALI.Util; use ALI.Util; +with ALI; use ALI; +with ALI.Util; use ALI.Util; with Csets; with Debug; with Fmap; with Fname; use Fname; -with Fname.SF; use Fname.SF; +with Fname.SF; with Fname.UF; use Fname.UF; with Gnatvsn; use Gnatvsn; with Hostparm; use Hostparm; with Makeusg; with Make_Util; use Make_Util; -with Namet; use Namet; -with Opt; use Opt; -with Osint.M; use Osint.M; -with Osint; use Osint; -with Output; use Output; +with Namet; use Namet; +with Opt; use Opt; +with Osint.M; use Osint.M; +with Osint; use Osint; +with Output; use Output; with SFN_Scan; with Sinput; -with Snames; use Snames; +with Snames; with Stringt; pragma Warnings (Off); @@ -52,7 +52,7 @@ pragma Warnings (On); with Switch; use Switch; with Switch.M; use Switch.M; with Table; -with Targparm; use Targparm; +with Targparm; with Tempdir; with Types; use Types; diff --git a/gcc/ada/makeusg.adb b/gcc/ada/makeusg.adb index 73361de..e596f32 100644 --- a/gcc/ada/makeusg.adb +++ b/gcc/ada/makeusg.adb @@ -24,7 +24,7 @@ ------------------------------------------------------------------------------ with Make_Util; -with Osint; use Osint; +with Osint; with Output; use Output; with Switch; use Switch; with Usage; diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index fd458a3..2dcbe1a 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -38,7 +38,7 @@ with Opt; use Opt; with Output; use Output; with System; use System; with Tree_IO; use Tree_IO; -with Widechar; use Widechar; +with Widechar; with Interfaces; use Interfaces; diff --git a/gcc/ada/output.ads b/gcc/ada/output.ads index 5fe0d44..21f69dd 100644 --- a/gcc/ada/output.ads +++ b/gcc/ada/output.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, 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,7 @@ -- writing error messages and informational output. It is also used by the -- debug source file output routines (see Sprint.Print_Debug_Line). -with Hostparm; use Hostparm; +with Hostparm; with Types; use Types; pragma Warnings (Off); diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb index eca327b..1dd3b76 100644 --- a/gcc/ada/par-ch10.adb +++ b/gcc/ada/par-ch10.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- -- @@ -970,7 +970,7 @@ package body Ch10 is -- Processing for USE clause elsif Token = Tok_Use then - Append (P_Use_Clause, Item_List); + P_Use_Clause (Item_List); -- Anything else is end of context clause diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb index 52f687e..e603d9c 100644 --- a/gcc/ada/par-ch12.adb +++ b/gcc/ada/par-ch12.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- -- @@ -167,7 +167,7 @@ package body Ch12 is end if; if Token = Tok_Use then - Append (P_Use_Clause, Decls); + P_Use_Clause (Decls); else -- Parse a generic parameter declaration diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 6553a95..54dd562 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -4411,7 +4411,7 @@ package body Ch3 is when Tok_Use => Check_Bad_Layout; - Append (P_Use_Clause, Decls); + P_Use_Clause (Decls); Done := False; when Tok_With => diff --git a/gcc/ada/par-ch8.adb b/gcc/ada/par-ch8.adb index b4eaf8c..456c863 100644 --- a/gcc/ada/par-ch8.adb +++ b/gcc/ada/par-ch8.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, 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- -- @@ -34,8 +34,50 @@ package body Ch8 is -- Local Subprograms -- ----------------------- - function P_Use_Package_Clause return Node_Id; - function P_Use_Type_Clause return Node_Id; + procedure Append_Use_Clause + (Item_List : List_Id; + Use_Node : Node_Id; + Is_First : in out Boolean; + Is_Last : in out Boolean); + -- Append a use_clause to the Item_List, appropriately setting the Prev_Ids + -- and More_Ids flags for each split use node. The flags Is_First and + -- Is_Last track position of subtype_marks or names within the original + -- use_clause. + + procedure P_Use_Package_Clause (Item_List : List_Id); + procedure P_Use_Type_Clause (Item_List : List_Id); + + ----------------------- + -- Append_Use_Clause -- + ----------------------- + + procedure Append_Use_Clause + (Item_List : List_Id; + Use_Node : Node_Id; + Is_First : in out Boolean; + Is_Last : in out Boolean) + is + begin + if Token /= Tok_Comma then + if not Is_First then + Set_Prev_Ids (Use_Node); + end if; + + Append (Use_Node, Item_List); + Is_Last := True; + else + Set_More_Ids (Use_Node); + + if not Is_First then + Set_Prev_Ids (Use_Node); + else + Is_First := False; + end if; + + Append (Use_Node, Item_List); + Scan; -- Past comma + end if; + end Append_Use_Clause; --------------------- -- 8.4 Use Clause -- @@ -47,14 +89,14 @@ package body Ch8 is -- Error recovery: cannot raise Error_Resync - function P_Use_Clause return Node_Id is + procedure P_Use_Clause (Item_List : List_Id) is begin Scan; -- past USE if Token = Tok_Type or else Token = Tok_All then - return P_Use_Type_Clause; + P_Use_Type_Clause (Item_List); else - return P_Use_Package_Clause; + P_Use_Package_Clause (Item_List); end if; end P_Use_Clause; @@ -68,26 +110,32 @@ package body Ch8 is -- Error recovery: cannot raise Error_Resync - function P_Use_Package_Clause return Node_Id is + procedure P_Use_Package_Clause (Item_List : List_Id) is + Is_First : Boolean := True; + Is_Last : Boolean := False; Use_Node : Node_Id; + Use_Sloc : constant Source_Ptr := Prev_Token_Ptr; begin - Use_Node := New_Node (N_Use_Package_Clause, Prev_Token_Ptr); - Set_Names (Use_Node, New_List); - if Token = Tok_Package then Error_Msg_SC ("PACKAGE should not appear here"); - Scan; -- past PACKAGE + Scan; -- Past PACKAGE end if; + -- Loop through names in a single use_package_clause, generating an + -- N_Use_Package_Clause node for each name encountered. + loop - Append (P_Qualified_Simple_Name, Names (Use_Node)); - exit when Token /= Tok_Comma; - Scan; -- past comma + Use_Node := New_Node (N_Use_Package_Clause, Use_Sloc); + Set_Name (Use_Node, P_Qualified_Simple_Name); + + -- Locally chain each name's use-package node + + Append_Use_Clause (Item_List, Use_Node, Is_First, Is_Last); + exit when Is_Last; end loop; TF_Semicolon; - return Use_Node; end P_Use_Package_Clause; -------------------------- @@ -103,45 +151,53 @@ package body Ch8 is -- Error recovery: cannot raise Error_Resync - function P_Use_Type_Clause return Node_Id is - Use_Node : Node_Id; + procedure P_Use_Type_Clause (Item_List : List_Id) is All_Present : Boolean; + Is_First : Boolean := True; + Is_Last : Boolean := False; + Use_Node : Node_Id; Use_Sloc : constant Source_Ptr := Prev_Token_Ptr; begin if Token = Tok_All then Error_Msg_Ada_2012_Feature ("|`USE ALL TYPE`", Token_Ptr); All_Present := True; - Scan; -- past ALL + Scan; -- Past ALL if Token /= Tok_Type then Error_Msg_SC ("TYPE expected"); end if; - else pragma Assert (Token = Tok_Type); + else + pragma Assert (Token = Tok_Type); All_Present := False; end if; - Use_Node := New_Node (N_Use_Type_Clause, Use_Sloc); - Set_All_Present (Use_Node, All_Present); - Set_Subtype_Marks (Use_Node, New_List); - Set_Used_Operations (Use_Node, No_Elist); - if Ada_Version = Ada_83 then Error_Msg_SC ("(Ada 83) use type not allowed!"); end if; - Scan; -- past TYPE + Scan; -- Past TYPE + + -- Loop through subtype_marks in one use_type_clause, generating a + -- separate N_Use_Type_Clause node for each subtype_mark encountered. loop - Append (P_Subtype_Mark, Subtype_Marks (Use_Node)); + Use_Node := New_Node (N_Use_Type_Clause, Use_Sloc); + Set_All_Present (Use_Node, All_Present); + Set_Used_Operations (Use_Node, No_Elist); + + Set_Subtype_Mark (Use_Node, P_Subtype_Mark); + No_Constraint; - exit when Token /= Tok_Comma; - Scan; -- past comma + + -- Locally chain each subtype_mark's use-type node + + Append_Use_Clause (Item_List, Use_Node, Is_First, Is_Last); + exit when Is_Last; end loop; TF_Semicolon; - return Use_Node; end P_Use_Type_Clause; ------------------------------- @@ -163,9 +219,9 @@ package body Ch8 is -- Parsed by P_Identifier_Declarations (3.3.1) - ---------------------------------------- + ------------------------------------------- -- 8.5.2 Exception Renaming Declaration -- - ---------------------------------------- + ------------------------------------------- -- Parsed by P_Identifier_Declarations (3.3.1) diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 4145907..280d8a1 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -867,7 +867,7 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is ------------- package Ch8 is - function P_Use_Clause return Node_Id; + procedure P_Use_Clause (Item_List : List_Id); end Ch8; ------------- diff --git a/gcc/ada/put_scos.adb b/gcc/ada/put_scos.adb index c420090..fa8a7a8 100644 --- a/gcc/ada/put_scos.adb +++ b/gcc/ada/put_scos.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2009-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2009-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- -- @@ -23,9 +23,9 @@ -- -- ------------------------------------------------------------------------------ -with Namet; use Namet; -with Opt; use Opt; -with SCOs; use SCOs; +with Namet; +with Opt; +with SCOs; use SCOs; procedure Put_SCOs is Current_SCO_Unit : SCO_Unit_Index := 0; diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb index a62c48b..630d592 100644 --- a/gcc/ada/repinfo.adb +++ b/gcc/ada/repinfo.adb @@ -29,7 +29,7 @@ -- -- ------------------------------------------------------------------------------ -with Alloc; use Alloc; +with Alloc; with Atree; use Atree; with Casing; use Casing; with Debug; use Debug; @@ -45,7 +45,7 @@ with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; -with Table; use Table; +with Table; with Uname; use Uname; with Urealp; use Urealp; diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index 8bedff6..e3af27d 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -30,7 +30,7 @@ with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; -with Exp_Dist; use Exp_Dist; +with Exp_Dist; with Fname; use Fname; with Fname.UF; use Fname.UF; with Ghost; use Ghost; diff --git a/gcc/ada/scn.ads b/gcc/ada/scn.ads index 77ebadc..10e4ad3 100644 --- a/gcc/ada/scn.ads +++ b/gcc/ada/scn.ads @@ -29,7 +29,7 @@ with Casing; use Casing; with Errout; use Errout; with Scng; -with Style; use Style; +with Style; -- use Style; with Types; use Types; package Scn is diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 35d0d48..e121e59 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -732,6 +732,18 @@ package body Sem is Debug_A_Exit ("analyzing ", N, " (done)"); + -- Mark relevant use-type and use-package clauses as effective using the + -- original node, because constant folding may have occurred and removed + -- references that need to be examined. If the node in question is + -- overloaded then this is deferred until resolution. + + if Nkind (Original_Node (N)) in N_Op + and then Present (Entity (Original_Node (N))) + and then not Is_Overloaded (Original_Node (N)) + then + Mark_Use_Clauses (Original_Node (N)); + end if; + -- Now that we have analyzed the node, we call the expander to perform -- possible expansion. We skip this for subexpressions, because we don't -- have the type yet, and the expander will need to know the type before diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 0930e8f..5bedc6c 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -47,7 +47,7 @@ with Opt; use Opt; with Restrict; use Restrict; with Rident; use Rident; with Rtsfind; use Rtsfind; -with Sdefault; use Sdefault; +with Sdefault; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; @@ -11797,6 +11797,15 @@ package body Sem_Attr is end if; end case; + -- Mark use clauses of the original prefix if the attribute is applied + -- to an entity. + + if Nkind (Original_Node (P)) in N_Has_Entity + and then Present (Entity (Original_Node (P))) + then + Mark_Use_Clauses (Original_Node (P)); + end if; + -- Normally the Freezing is done by Resolve but sometimes the Prefix -- is not resolved, in which case the freezing must be done now. diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 2ab9ef6..7da7b41 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -38,7 +38,7 @@ -- content of entities in the tree, so this package is used for routines that -- require more than minimal semantic knowledge. -with Alloc; use Alloc; +with Alloc; with Namet; use Namet; with Table; with Types; use Types; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 6da229c..b89d8d3 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -138,9 +138,12 @@ package body Sem_Ch10 is -- Check that the shadow entity is not already in the homonym chain, for -- example through a limited_with clause in a parent unit. - procedure Install_Context_Clauses (N : Node_Id); + procedure Install_Context_Clauses (N : Node_Id; Chain : Boolean := True); -- Subsidiary to Install_Context and Install_Parents. Process all with - -- and use clauses for current unit and its library unit if any. + -- and use clauses for current unit and its library unit if any. The flag + -- Chain is used to control the "chaining" or linking together of use-type + -- and use-package clauses to avoid circularities with reinstalling + -- clauses. procedure Install_Limited_Context_Clauses (N : Node_Id); -- Subsidiary to Install_Context. Process only limited with_clauses for @@ -159,7 +162,8 @@ package body Sem_Ch10 is -- is called when compiling the private part of a package, or installing -- the private declarations of a parent unit. - procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean); + procedure Install_Parents + (Lib_Unit : Node_Id; Is_Private : Boolean; Chain : Boolean := True); -- This procedure establishes the context for the compilation of a child -- unit. If Lib_Unit is a child library spec then the context of the parent -- is installed, and the parent itself made immediately visible, so that @@ -168,7 +172,9 @@ package body Sem_Ch10 is -- parents are loaded in the nested case. If Lib_Unit is a library body, -- the only effect of Install_Parents is to install the private decls of -- the parents, because the visible parent declarations will have been - -- installed as part of the context of the corresponding spec. + -- installed as part of the context of the corresponding spec. The flag + -- Chain is used to control the "chaining" or linking of use-type and + -- use-package clauses to avoid circularities when installing context. procedure Install_Siblings (U_Name : Entity_Id; N : Node_Id); -- In the compilation of a child unit, a child of any of the ancestor @@ -342,53 +348,45 @@ package body Sem_Ch10 is then -- Search through use clauses - Use_Item := First (Names (Cont_Item)); - while Present (Use_Item) and then not Used loop + Use_Item := Name (Cont_Item); - -- Case of a direct use of the one we are looking for + -- Case of a direct use of the one we are looking for - if Entity (Use_Item) = Nam_Ent then - Used := True; + if Entity (Use_Item) = Nam_Ent then + Used := True; - -- Handle nested case, as in "with P; use P.Q.R" + -- Handle nested case, as in "with P; use P.Q.R" - else - declare - UE : Node_Id; - - begin - -- Loop through prefixes looking for match + else + declare + UE : Node_Id; - UE := Use_Item; - while Nkind (UE) = N_Expanded_Name loop - if Same_Unit (Prefix (UE), Nam_Ent) then - Used := True; - exit; - end if; + begin + -- Loop through prefixes looking for match - UE := Prefix (UE); - end loop; - end; - end if; + UE := Use_Item; + while Nkind (UE) = N_Expanded_Name loop + if Same_Unit (Prefix (UE), Nam_Ent) then + Used := True; + exit; + end if; - Next (Use_Item); - end loop; + UE := Prefix (UE); + end loop; + end; + end if; -- USE TYPE clause elsif Nkind (Cont_Item) = N_Use_Type_Clause and then not Used_Type_Or_Elab then - Subt_Mark := First (Subtype_Marks (Cont_Item)); - while Present (Subt_Mark) - and then not Used_Type_Or_Elab - loop - if Same_Unit (Prefix (Subt_Mark), Nam_Ent) then - Used_Type_Or_Elab := True; - end if; - - Next (Subt_Mark); - end loop; + Subt_Mark := Subtype_Mark (Cont_Item); + if not Used_Type_Or_Elab + and then Same_Unit (Prefix (Subt_Mark), Nam_Ent) + then + Used_Type_Or_Elab := True; + end if; -- Pragma Elaborate or Elaborate_All @@ -426,7 +424,6 @@ package body Sem_Ch10 is is Nam_Ent : constant Entity_Id := Entity (Name (Clause)); Cont_Item : Node_Id; - Use_Item : Node_Id; begin Used := False; @@ -450,14 +447,9 @@ package body Sem_Ch10 is if Nkind (Cont_Item) = N_Use_Package_Clause and then not Used then - Use_Item := First (Names (Cont_Item)); - while Present (Use_Item) and then not Used loop - if Entity (Use_Item) = Nam_Ent then - Used := True; - end if; - - Next (Use_Item); - end loop; + if Entity (Name (Cont_Item)) = Nam_Ent then + Used := True; + end if; -- Package with clause. Avoid processing self, implicitly -- generated with clauses or limited with clauses. Note that @@ -2103,7 +2095,6 @@ package body Sem_Ch10 is procedure Analyze_Subunit_Context is Item : Node_Id; - Nam : Node_Id; Unit_Name : Entity_Id; begin @@ -2154,18 +2145,10 @@ package body Sem_Ch10 is end if; elsif Nkind (Item) = N_Use_Package_Clause then - Nam := First (Names (Item)); - while Present (Nam) loop - Analyze (Nam); - Next (Nam); - end loop; + Analyze (Name (Item)); elsif Nkind (Item) = N_Use_Type_Clause then - Nam := First (Subtype_Marks (Item)); - while Present (Nam) loop - Analyze (Nam); - Next (Nam); - end loop; + Analyze (Subtype_Mark (Item)); end if; Next (Item); @@ -2212,7 +2195,7 @@ package body Sem_Ch10 is Re_Install_Parents (Library_Unit (L), Scope (Scop)); end if; - Install_Context (L); + Install_Context (L, False); -- If the subunit occurs within a child unit, we must restore the -- immediate visibility of any siblings that may occur in context. @@ -2259,7 +2242,7 @@ package body Sem_Ch10 is for J in reverse 1 .. Num_Scopes loop U := Use_Clauses (J); Scope_Stack.Table (Scope_Stack.Last - J + 1).First_Use_Clause := U; - Install_Use_Clauses (U, Force_Installation => True); + Install_Use_Clauses (U); end loop; end Re_Install_Use_Clauses; @@ -2383,7 +2366,7 @@ package body Sem_Ch10 is end if; Re_Install_Use_Clauses; - Install_Context (N); + Install_Context (N, Chain => False); -- Restore state of suppress flags for current body @@ -3399,14 +3382,15 @@ package body Sem_Ch10 is -- Install_Context -- --------------------- - procedure Install_Context (N : Node_Id) is + procedure Install_Context (N : Node_Id; Chain : Boolean := True) is Lib_Unit : constant Node_Id := Unit (N); begin - Install_Context_Clauses (N); + Install_Context_Clauses (N, Chain); if Is_Child_Spec (Lib_Unit) then - Install_Parents (Lib_Unit, Private_Present (Parent (Lib_Unit))); + Install_Parents + (Lib_Unit, Private_Present (Parent (Lib_Unit)), Chain); end if; Install_Limited_Context_Clauses (N); @@ -3416,7 +3400,7 @@ package body Sem_Ch10 is -- Install_Context_Clauses -- ----------------------------- - procedure Install_Context_Clauses (N : Node_Id) is + procedure Install_Context_Clauses (N : Node_Id; Chain : Boolean := True) is Lib_Unit : constant Node_Id := Unit (N); Item : Node_Id; Uname_Node : Entity_Id; @@ -3567,12 +3551,12 @@ package body Sem_Ch10 is -- Case of USE PACKAGE clause elsif Nkind (Item) = N_Use_Package_Clause then - Analyze_Use_Package (Item); + Analyze_Use_Package (Item, Chain); -- Case of USE TYPE clause elsif Nkind (Item) = N_Use_Type_Clause then - Analyze_Use_Type (Item); + Analyze_Use_Type (Item, Chain); -- case of PRAGMA @@ -3602,7 +3586,7 @@ package body Sem_Ch10 is or else (Nkind (Lib_Unit) = N_Subprogram_Body and then not Acts_As_Spec (N)) then - Install_Context (Library_Unit (N)); + Install_Context (Library_Unit (N), Chain); -- Only install private with-clauses of a spec that comes from -- source, excluding specs created for a subprogram body that is @@ -3716,7 +3700,6 @@ package body Sem_Ch10 is Item : Node_Id; Spec : Node_Id; WEnt : Entity_Id; - Nam : Node_Id; E : Entity_Id; E2 : Entity_Id; @@ -3749,43 +3732,36 @@ package body Sem_Ch10 is if Nkind (Item) = N_Use_Package_Clause then - -- Traverse the list of packages + E := Entity (Name (Item)); - Nam := First (Names (Item)); - while Present (Nam) loop - E := Entity (Nam); + pragma Assert (Present (Parent (E))); - pragma Assert (Present (Parent (E))); - - if Nkind (Parent (E)) = N_Package_Renaming_Declaration - and then Renamed_Entity (E) = WEnt - then - -- The unlimited view is visible through use clause and - -- renamings. There is no need to generate the error - -- message here because Is_Visible_Through_Renamings - -- takes care of generating the precise error message. + if Nkind (Parent (E)) = N_Package_Renaming_Declaration + and then Renamed_Entity (E) = WEnt + then + -- The unlimited view is visible through use clause and + -- renamings. There is no need to generate the error + -- message here because Is_Visible_Through_Renamings + -- takes care of generating the precise error message. - return; + return; - elsif Nkind (Parent (E)) = N_Package_Specification then + elsif Nkind (Parent (E)) = N_Package_Specification then - -- The use clause may refer to a local package. - -- Check all the enclosing scopes. + -- The use clause may refer to a local package. + -- Check all the enclosing scopes. - E2 := E; - while E2 /= Standard_Standard and then E2 /= WEnt loop - E2 := Scope (E2); - end loop; + E2 := E; + while E2 /= Standard_Standard and then E2 /= WEnt loop + E2 := Scope (E2); + end loop; - if E2 = WEnt then - Error_Msg_N - ("unlimited view visible through use clause ", W); - return; - end if; + if E2 = WEnt then + Error_Msg_N + ("unlimited view visible through use clause ", W); + return; end if; - - Next (Nam); - end loop; + end if; end if; Next (Item); @@ -4088,7 +4064,8 @@ package body Sem_Ch10 is -- Install_Parents -- --------------------- - procedure Install_Parents (Lib_Unit : Node_Id; Is_Private : Boolean) is + procedure Install_Parents + (Lib_Unit : Node_Id; Is_Private : Boolean; Chain : Boolean := True) is P : Node_Id; E_Name : Entity_Id; P_Name : Entity_Id; @@ -4145,12 +4122,12 @@ package body Sem_Ch10 is if Is_Child_Spec (P) then Install_Parents (P, - Is_Private or else Private_Present (Parent (Lib_Unit))); + Is_Private or else Private_Present (Parent (Lib_Unit)), Chain); end if; -- Now we can install the context for this parent - Install_Context_Clauses (Parent_Spec (Lib_Unit)); + Install_Context_Clauses (Parent_Spec (Lib_Unit), Chain); Install_Limited_Context_Clauses (Parent_Spec (Lib_Unit)); Install_Siblings (P_Name, Parent (Lib_Unit)); diff --git a/gcc/ada/sem_ch10.ads b/gcc/ada/sem_ch10.ads index d4b28cd..2843d9e 100644 --- a/gcc/ada/sem_ch10.ads +++ b/gcc/ada/sem_ch10.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, 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- -- @@ -34,10 +34,12 @@ package Sem_Ch10 is procedure Analyze_Protected_Body_Stub (N : Node_Id); procedure Analyze_Subunit (N : Node_Id); - procedure Install_Context (N : Node_Id); + procedure Install_Context (N : Node_Id; Chain : Boolean := True); -- Installs the entities from the context clause of the given compilation -- unit into the visibility chains. This is done before analyzing a unit. - -- For a child unit, install context of parents as well. + -- For a child unit, install context of parents as well. The flag Chain is + -- used to control the "chaining" or linking of use-type and use-package + -- clauses to avoid circularities when reinstalling context clauses. procedure Install_Private_With_Clauses (P : Entity_Id); -- Install the private with_clauses of a compilation unit, when compiling diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 44dc801..ec270f3 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -4840,7 +4840,7 @@ package body Sem_Ch12 is end loop; if Removed then - Install_Context (Curr_Comp); + Install_Context (Curr_Comp, Chain => False); if Present (Curr_Scope) and then Is_Child_Unit (Curr_Scope) diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 04ed408..79b22cd 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2264,13 +2264,29 @@ package body Sem_Ch13 is end if; end if; - -- Construct the attribute definition clause - - Aitem := - Make_Attribute_Definition_Clause (Loc, - Name => Ent, - Chars => Chars (Id), - Expression => Relocate_Node (Expr)); + -- Construct the attribute_definition_clause. The expression + -- in the aspect specification is simply shared with the + -- constructed attribute, because it will be fully analyzed + -- when the attribute is processed. However, in ASIS mode + -- the aspect expression itself is preanalyzed and resolved + -- to catch visibility errors that are otherwise caught + -- later, and we create a separate copy of the expression + -- to prevent analysis of a malformed tree (e.g. a function + -- call with parameter associations). + + if ASIS_Mode then + Aitem := + Make_Attribute_Definition_Clause (Loc, + Name => Ent, + Chars => Chars (Id), + Expression => New_Copy_Tree (Expr)); + else + Aitem := + Make_Attribute_Definition_Clause (Loc, + Name => Ent, + Chars => Chars (Id), + Expression => Relocate_Node (Expr)); + end if; -- If the address is specified, then we treat the entity as -- referenced, to avoid spurious warnings. This is analogous diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 28da823..8801fb7 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6477,9 +6477,17 @@ package body Sem_Ch4 is -------------------- procedure Try_One_Interp (T1 : Entity_Id) is - Bas : constant Entity_Id := Base_Type (T1); + Bas : Entity_Id; begin + -- Perform a sanity check in case of previous errors + + if No (T1) then + return; + end if; + + Bas := Base_Type (T1); + -- If the operator is an expanded name, then the type of the operand -- must be defined in the corresponding scope. If the type is -- universal, the context will impose the correct type. An anonymous diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index d33d59a..e3aa50b 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1132,6 +1132,7 @@ package body Sem_Ch5 is end if; Check_References (Ent); + Update_Use_Clause_Chain; End_Scope; if Unblocked_Exit_Count = 0 then diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 468c112..9ef0aca 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -1498,6 +1498,7 @@ package body Sem_Ch6 is end; Process_End_Label (Handled_Statement_Sequence (N), 't', Current_Scope); + Update_Use_Clause_Chain; End_Scope; Check_Subprogram_Order (N); @@ -4357,6 +4358,7 @@ package body Sem_Ch6 is -- Deal with end of scope processing for the body Process_End_Label (HSS, 't', Current_Scope); + Update_Use_Clause_Chain; End_Scope; -- If we are compiling an entry wrapper, remove the enclosing diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 030d4f0..ba7ff3c 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -945,6 +945,7 @@ package body Sem_Ch7 is Set_Last_Entity (Spec_Id, Empty); end if; + Update_Use_Clause_Chain; End_Package_Scope (Spec_Id); -- All entities declared in body are not visible @@ -1796,6 +1797,18 @@ package body Sem_Ch7 is then Unit_Requires_Body_Info (Id); end if; + + -- Nested package specs that do not require bodies are not checked for + -- ineffective use clauses due to the possbility of subunits. This is + -- because at this stage it is impossible to tell whether there will be + -- a separate body. + + if not Unit_Requires_Body (Id) + and then Is_Compilation_Unit (Id) + and then not Is_Private_Descendant (Id) + then + Update_Use_Clause_Chain; + end if; end Analyze_Package_Specification; -------------------------------------- diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 8947841..d86818a 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -65,7 +65,7 @@ with Stand; use Stand; with Sinfo; use Sinfo; with Sinfo.CN; use Sinfo.CN; with Snames; use Snames; -with Style; use Style; +with Style; with Table; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -402,11 +402,6 @@ package body Sem_Ch8 is -- The renaming operation is intrinsic because the compiler must in -- fact generate a wrapper for it (6.3.1 (10 1/2)). - function Applicable_Use (Pack_Name : Node_Id) return Boolean; - -- Common code to Use_One_Package and Set_Use, to determine whether use - -- clause must be processed. Pack_Name is an entity name that references - -- the package in question. - procedure Attribute_Renaming (N : Node_Id); -- Analyze renaming of attribute as subprogram. The renaming declaration N -- is rewritten as a subprogram body that returns the attribute reference @@ -469,19 +464,21 @@ package body Sem_Ch8 is -- but is a reasonable heuristic on the use of nested generics. The -- proper solution requires a full renaming model. - function Has_Implicit_Character_Literal (N : Node_Id) return Boolean; - -- Find a type derived from Character or Wide_Character in the prefix of N. - -- Used to resolved qualified names whose selector is a character literal. - - function Has_Private_With (E : Entity_Id) return Boolean; - -- Ada 2005 (AI-262): Determines if the current compilation unit has a - -- private with on E. + function Entity_Of_Unit (U : Node_Id) return Entity_Id; + -- Return the appropriate entity for determining which unit has a deeper + -- scope: the defining entity for U, unless U is a package instance, in + -- which case we retrieve the entity of the instance spec. procedure Find_Expanded_Name (N : Node_Id); -- The input is a selected component known to be an expanded name. Verify -- legality of selector given the scope denoted by prefix, and change node -- N into a expanded name with a properly set Entity field. + function Find_Most_Prev (Use_Clause : Node_Id) return Node_Id; + -- Find the most previous use clause (that is, the first one to appear in + -- the source) by traversing the previous clause chain that exists in both + -- N_Use_Package_Clause nodes and N_Use_Type_Clause nodes. + function Find_Renamed_Entity (N : Node_Id; Nam : Node_Id; @@ -493,6 +490,14 @@ package body Sem_Ch8 is -- indicates that the renaming is the one generated for an actual subpro- -- gram in an instance, for which special visibility checks apply. + function Has_Implicit_Character_Literal (N : Node_Id) return Boolean; + -- Find a type derived from Character or Wide_Character in the prefix of N. + -- Used to resolved qualified names whose selector is a character literal. + + function Has_Private_With (E : Entity_Id) return Boolean; + -- Ada 2005 (AI-262): Determines if the current compilation unit has a + -- private with on E. + function Has_Implicit_Operator (N : Node_Id) return Boolean; -- N is an expanded name whose selector is an operator name (e.g. P."+"). -- declarative part contains an implicit declaration of an operator if it @@ -507,30 +512,33 @@ package body Sem_Ch8 is -- specification are discarded and replaced with those of the renamed -- subprogram, which are then used to recheck the default values. - function Is_Appropriate_For_Record (T : Entity_Id) return Boolean; - -- Prefix is appropriate for record if it is of a record type, or an access - -- to such. - function Is_Appropriate_For_Entry_Prefix (T : Entity_Id) return Boolean; -- True if it is of a task type, a protected type, or else an access to one -- of these types. - procedure Note_Redundant_Use (Clause : Node_Id); - -- Mark the name in a use clause as redundant if the corresponding entity - -- is already use-visible. Emit a warning if the use clause comes from - -- source and the proper warnings are enabled. + function Is_Appropriate_For_Record (T : Entity_Id) return Boolean; + -- Prefix is appropriate for record if it is of a record type, or an access + -- to such. + + function Most_Descendant_Use_Clause + (Clause1 : Entity_Id; + Clause2 : Entity_Id) return Entity_Id; + -- Determine which use clause parameter is the most descendant in terms of + -- scope. procedure Premature_Usage (N : Node_Id); -- Diagnose usage of an entity before it is visible - procedure Use_One_Package (P : Entity_Id; N : Node_Id); + procedure Use_One_Package + (N : Node_Id; Pack_Name : Entity_Id := Empty; Force : Boolean := False); -- Make visible entities declared in package P potentially use-visible -- in the current context. Also used in the analysis of subunits, when -- re-installing use clauses of parent units. N is the use_clause that -- names P (and possibly other packages). - procedure Use_One_Type (Id : Node_Id; Installed : Boolean := False); - -- Id is the subtype mark from a use type clause. This procedure makes + procedure Use_One_Type + (Id : Node_Id; Installed : Boolean := False; Force : Boolean := False); + -- Id is the subtype mark from a use_type_clause. This procedure makes -- the primitive operators of the type potentially use-visible. The -- boolean flag Installed indicates that the clause is being reinstalled -- after previous analysis, and primitive operations are already chained @@ -3437,7 +3445,7 @@ package body Sem_Ch8 is -- addition the renamed entity may depend on the generic formals of -- the enclosing generic. - if Is_Actual and then not Inside_A_Generic then + if Is_Actual and not Inside_A_Generic then Freeze_Before (N, Old_S); Freeze_Actual_Profile; Set_Has_Delayed_Freeze (New_S, False); @@ -3624,6 +3632,25 @@ package body Sem_Ch8 is Analyze (N); end if; end if; + + -- Check if we are looking at an Ada 2012 defaulted formal subprogram + -- and mark any use_package_clauses that affect the visibility of the + -- implicit generic actual. + + if From_Default (N) + and then Is_Generic_Actual_Subprogram (New_S) + and then Present (Alias (New_S)) + then + Mark_Use_Clauses (Alias (New_S)); + + -- Check intrinsic operators used as generic actuals since they may + -- make a use_type_clause effective. + + elsif Is_Generic_Actual_Subprogram (New_S) + and then Is_Intrinsic_Subprogram (New_S) + then + Mark_Use_Clauses (New_S); + end if; end Analyze_Subprogram_Renaming; ------------------------- @@ -3637,11 +3664,78 @@ package body Sem_Ch8 is -- use. If the package is an open scope, i.e. if the use clause occurs -- within the package itself, ignore it. - procedure Analyze_Use_Package (N : Node_Id) is + procedure Analyze_Use_Package (N : Node_Id; Chain : Boolean := True) is + + procedure Analyze_Package_Name (Clause : Node_Id); + -- Perform analysis on a package name from a use_package_clause + + procedure Analyze_Package_Name_List (Head_Clause : Node_Id); + -- Similar to Analyze_Package_Name but iterates over all the names + -- in a use clause. + + -------------------------- + -- Analyze_Package_Name -- + -------------------------- + + procedure Analyze_Package_Name (Clause : Node_Id) is + Pack : constant Node_Id := Name (Clause); + Pref : Node_Id; + + begin + pragma Assert (Nkind (Clause) = N_Use_Package_Clause); + Analyze (Pack); + + -- Verify that the package standard is not directly named in a + -- use_package_clause. + + if Nkind (Parent (Clause)) = N_Compilation_Unit + and then Nkind (Pack) = N_Expanded_Name + then + Pref := Prefix (Pack); + + while Nkind (Pref) = N_Expanded_Name loop + Pref := Prefix (Pref); + end loop; + + if Entity (Pref) = Standard_Standard then + Error_Msg_N + ("predefined package Standard cannot appear in a " + & "context clause", Pref); + end if; + end if; + end Analyze_Package_Name; + + ------------------------------- + -- Analyze_Package_Name_List -- + ------------------------------- + + procedure Analyze_Package_Name_List (Head_Clause : Node_Id) is + Curr : Node_Id; + + begin + -- Due to the way source use clauses are split during parsing we are + -- forced to simply iterate through all entities in scope until the + -- clause representing the last name in the list is found. + + Curr := Head_Clause; + while Present (Curr) loop + Analyze_Package_Name (Curr); + + -- Stop iterating over the names in the use clause when we are at + -- the last one. + + exit when not More_Ids (Curr) and then Prev_Ids (Curr); + Next (Curr); + end loop; + end Analyze_Package_Name_List; + + -- Local variables + Ghost_Id : Entity_Id := Empty; Living_Id : Entity_Id := Empty; Pack : Entity_Id; - Pack_Name : Node_Id; + + -- Start of processing for Analyze_Use_Package begin Check_SPARK_05_Restriction ("use clause is not allowed", N); @@ -3661,107 +3755,89 @@ package body Sem_Ch8 is Error_Msg_N ("use clause not allowed in predefined spec", N); end if; - -- Chain clause to list of use clauses in current scope + -- Loop through all package names from the original use clause in + -- order to analyze referenced packages. A use_package_clause with only + -- one name does not have More_Ids or Prev_Ids set, while a clause with + -- More_Ids only starts the chain produced by the parser. - if Nkind (Parent (N)) /= N_Compilation_Unit then - Chain_Use_Clause (N); + if not More_Ids (N) and then not Prev_Ids (N) then + Analyze_Package_Name (N); + elsif More_Ids (N) and then not Prev_Ids (N) then + Analyze_Package_Name_List (N); end if; - -- Loop through package names to identify referenced packages - - Pack_Name := First (Names (N)); - while Present (Pack_Name) loop - Analyze (Pack_Name); - - if Nkind (Parent (N)) = N_Compilation_Unit - and then Nkind (Pack_Name) = N_Expanded_Name - then - declare - Pref : Node_Id; - - begin - Pref := Prefix (Pack_Name); - while Nkind (Pref) = N_Expanded_Name loop - Pref := Prefix (Pref); - end loop; + if not Is_Entity_Name (Name (N)) then + Error_Msg_N ("& is not a package", Name (N)); - if Entity (Pref) = Standard_Standard then - Error_Msg_N - ("predefined package Standard cannot appear in a context " - & "clause", Pref); - end if; - end; - end if; + return; + end if; + Pack := Entity (Name (N)); - Next (Pack_Name); - end loop; + if Chain then + Chain_Use_Clause (N); + end if; - -- Loop through package names to mark all entities as potentially use - -- visible. + -- There are many cases where scopes are manipulated during analysis, so + -- check that Pack's current use clause has not already been chained + -- before setting its previous use clause. - Pack_Name := First (Names (N)); - while Present (Pack_Name) loop - if Is_Entity_Name (Pack_Name) then - Pack := Entity (Pack_Name); + if Ekind (Pack) = E_Package + and then Present (Current_Use_Clause (Pack)) + and then Current_Use_Clause (Pack) /= N + and then No (Prev_Use_Clause (N)) + then + Set_Prev_Use_Clause (N, Current_Use_Clause (Pack)); + end if; - if Ekind (Pack) /= E_Package and then Etype (Pack) /= Any_Type then - if Ekind (Pack) = E_Generic_Package then - Error_Msg_N -- CODEFIX - ("a generic package is not allowed in a use clause", - Pack_Name); + -- Mark all entities as potentially use visible. - elsif Ekind_In (Pack, E_Generic_Function, E_Generic_Package) - then - Error_Msg_N -- CODEFIX - ("a generic subprogram is not allowed in a use clause", - Pack_Name); + if Ekind (Pack) /= E_Package and then Etype (Pack) /= Any_Type then + if Ekind (Pack) = E_Generic_Package then + Error_Msg_N -- CODEFIX + ("a generic package is not allowed in a use clause", + Name (N)); - elsif Ekind_In (Pack, E_Function, E_Procedure, E_Operator) then - Error_Msg_N -- CODEFIX - ("a subprogram is not allowed in a use clause", - Pack_Name); + elsif Ekind_In (Pack, E_Generic_Function, E_Generic_Package) + then + Error_Msg_N -- CODEFIX + ("a generic subprogram is not allowed in a use clause", + Name (N)); - else - Error_Msg_N ("& is not allowed in a use clause", Pack_Name); - end if; + elsif Ekind_In (Pack, E_Function, E_Procedure, E_Operator) then + Error_Msg_N -- CODEFIX + ("a subprogram is not allowed in a use clause", + Name (N)); - else - if Nkind (Parent (N)) = N_Compilation_Unit then - Check_In_Previous_With_Clause (N, Pack_Name); - end if; + else + Error_Msg_N ("& is not allowed in a use clause", Name (N)); + end if; - if Applicable_Use (Pack_Name) then - Use_One_Package (Pack, N); - end if; + else + if Nkind (Parent (N)) = N_Compilation_Unit then + Check_In_Previous_With_Clause (N, Name (N)); + end if; - -- Capture the first Ghost package and the first living package + Use_One_Package (N, Name (N)); - if Is_Entity_Name (Pack_Name) then - Pack := Entity (Pack_Name); + -- Capture the first Ghost package and the first living package - if Is_Ghost_Entity (Pack) then - if No (Ghost_Id) then - Ghost_Id := Pack; - end if; + if Is_Entity_Name (Name (N)) then + Pack := Entity (Name (N)); - elsif No (Living_Id) then - Living_Id := Pack; - end if; + if Is_Ghost_Entity (Pack) then + if No (Ghost_Id) then + Ghost_Id := Pack; end if; - end if; - - -- Report error because name denotes something other than a package - else - Error_Msg_N ("& is not a package", Pack_Name); + elsif No (Living_Id) then + Living_Id := Pack; + end if; end if; - - Next (Pack_Name); - end loop; + end if; -- Detect a mixture of Ghost packages and living packages within the - -- same use package clause. Ideally one would split a use package clause - -- with multiple names into multiple use package clauses with a single + -- same use_package_clause. Ideally one would split a use_package_clause + -- with multiple names into multiple use_package_clauses with a single -- name, however clients of the front end would have to adapt to this -- change. @@ -3783,21 +3859,39 @@ package body Sem_Ch8 is -- Analyze_Use_Type -- ---------------------- - procedure Analyze_Use_Type (N : Node_Id) is - E : Entity_Id; - Ghost_Id : Entity_Id := Empty; - Id : Node_Id; - Living_Id : Entity_Id := Empty; + procedure Analyze_Use_Type (N : Node_Id; Chain : Boolean := True) is + E : Entity_Id; + Id : Node_Id; begin Set_Hidden_By_Use_Clause (N, No_Elist); - -- Chain clause to list of use clauses in current scope + -- Chain clause to list of use clauses in current scope when flagged - if Nkind (Parent (N)) /= N_Compilation_Unit then + if Chain then Chain_Use_Clause (N); end if; + -- Obtain the base type of the type denoted within the use_type_clause's + -- subtype mark. + + Id := Subtype_Mark (N); + Find_Type (Id); + E := Base_Type (Entity (Id)); + + -- There are many cases where a use_type_clause may be reanalyzed due to + -- manipulation of the scope stack so we much guard against those cases + -- here, otherwise, we must add the new use_type_clause to the previous + -- use_type_clause chain in order to mark redundant use_type_clauses as + -- used. + + if Present (Current_Use_Clause (E)) + and then Current_Use_Clause (E) /= N + and then No (Prev_Use_Clause (N)) + then + Set_Prev_Use_Clause (N, Current_Use_Clause (E)); + end if; + -- If the Used_Operations list is already initialized, the clause has -- been analyzed previously, and it is being reinstalled, for example -- when the clause appears in a package spec and we are compiling the @@ -3806,15 +3900,10 @@ package body Sem_Ch8 is if Present (Used_Operations (N)) then declare - Mark : Node_Id; Elmt : Elmt_Id; begin - Mark := First (Subtype_Marks (N)); - while Present (Mark) loop - Use_One_Type (Mark, Installed => True); - Next (Mark); - end loop; + Use_One_Type (Subtype_Mark (N), Installed => True); Elmt := First_Elmt (Used_Operations (N)); while Present (Elmt) loop @@ -3830,133 +3919,69 @@ package body Sem_Ch8 is -- made use-visible by the clause. Set_Used_Operations (N, New_Elmt_List); - Id := First (Subtype_Marks (N)); - while Present (Id) loop - Find_Type (Id); - E := Entity (Id); - - if E /= Any_Type then - Use_One_Type (Id); + E := Entity (Id); - if Nkind (Parent (N)) = N_Compilation_Unit then - if Nkind (Id) = N_Identifier then - Error_Msg_N ("type is not directly visible", Id); + if E /= Any_Type then + Use_One_Type (Id); - elsif Is_Child_Unit (Scope (E)) - and then Scope (E) /= System_Aux_Id - then - Check_In_Previous_With_Clause (N, Prefix (Id)); - end if; - end if; - - else - -- If the use_type_clause appears in a compilation unit context, - -- check whether it comes from a unit that may appear in a - -- limited_with_clause, for a better error message. + if Nkind (Parent (N)) = N_Compilation_Unit then + if Nkind (Id) = N_Identifier then + Error_Msg_N ("type is not directly visible", Id); - if Nkind (Parent (N)) = N_Compilation_Unit - and then Nkind (Id) /= N_Identifier + elsif Is_Child_Unit (Scope (E)) + and then Scope (E) /= System_Aux_Id then - declare - Item : Node_Id; - Pref : Node_Id; - - function Mentioned (Nam : Node_Id) return Boolean; - -- Check whether the prefix of expanded name for the type - -- appears in the prefix of some limited_with_clause. - - --------------- - -- Mentioned -- - --------------- - - function Mentioned (Nam : Node_Id) return Boolean is - begin - return Nkind (Name (Item)) = N_Selected_Component - and then Chars (Prefix (Name (Item))) = Chars (Nam); - end Mentioned; - - begin - Pref := Prefix (Id); - Item := First (Context_Items (Parent (N))); - while Present (Item) and then Item /= N loop - if Nkind (Item) = N_With_Clause - and then Limited_Present (Item) - and then Mentioned (Pref) - then - Change_Error_Text - (Get_Msg_Id, "premature usage of incomplete type"); - end if; - - Next (Item); - end loop; - end; + Check_In_Previous_With_Clause (N, Prefix (Id)); end if; end if; - -- Capture the first Ghost type and the first living type - - if Is_Ghost_Entity (E) then - if No (Ghost_Id) then - Ghost_Id := E; - end if; + else + -- If the use_type_clause appears in a compilation unit context, + -- check whether it comes from a unit that may appear in a + -- limited_with_clause, for a better error message. - elsif No (Living_Id) then - Living_Id := E; - end if; + if Nkind (Parent (N)) = N_Compilation_Unit + and then Nkind (Id) /= N_Identifier + then + declare + Item : Node_Id; + Pref : Node_Id; - Next (Id); - end loop; + function Mentioned (Nam : Node_Id) return Boolean; + -- Check whether the prefix of expanded name for the type + -- appears in the prefix of some limited_with_clause. - -- Detect a mixture of Ghost types and living types within the same use - -- type clause. Ideally one would split a use type clause with multiple - -- marks into multiple use type clauses with a single mark, however - -- clients of the front end will have to adapt to this change. + --------------- + -- Mentioned -- + --------------- - if Present (Ghost_Id) and then Present (Living_Id) then - Error_Msg_N - ("use clause cannot mention ghost and non-ghost ghost types", N); + function Mentioned (Nam : Node_Id) return Boolean is + begin + return Nkind (Name (Item)) = N_Selected_Component + and then Chars (Prefix (Name (Item))) = Chars (Nam); + end Mentioned; - Error_Msg_Sloc := Sloc (Ghost_Id); - Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id); + begin + Pref := Prefix (Id); + Item := First (Context_Items (Parent (N))); + while Present (Item) and then Item /= N loop + if Nkind (Item) = N_With_Clause + and then Limited_Present (Item) + and then Mentioned (Pref) + then + Change_Error_Text + (Get_Msg_Id, "premature usage of incomplete type"); + end if; - Error_Msg_Sloc := Sloc (Living_Id); - Error_Msg_NE ("\& # declared as non-ghost", N, Living_Id); + Next (Item); + end loop; + end; + end if; end if; Mark_Ghost_Clause (N); end Analyze_Use_Type; - -------------------- - -- Applicable_Use -- - -------------------- - - function Applicable_Use (Pack_Name : Node_Id) return Boolean is - Pack : constant Entity_Id := Entity (Pack_Name); - - begin - if In_Open_Scopes (Pack) then - if Warn_On_Redundant_Constructs and then Pack = Current_Scope then - Error_Msg_NE -- CODEFIX - ("& is already use-visible within itself?r?", Pack_Name, Pack); - end if; - - return False; - - elsif In_Use (Pack) then - Note_Redundant_Use (Pack_Name); - return False; - - elsif Present (Renamed_Object (Pack)) - and then In_Use (Renamed_Object (Pack)) - then - Note_Redundant_Use (Pack_Name); - return False; - - else - return True; - end if; - end Applicable_Use; - ------------------------ -- Attribute_Renaming -- ------------------------ @@ -4186,21 +4211,27 @@ package body Sem_Ch8 is Level : Int := Scope_Stack.Last; begin + -- Common case + if not Is_Compilation_Unit (Current_Scope) or else not Is_Child_Unit (Current_Scope) then - null; -- Common case + null; + + -- Common case for compilation unit - elsif Defining_Entity (Parent (N)) = Current_Scope then - null; -- Common case for compilation unit + elsif Defining_Entity (N => Parent (N), + Empty_On_Errors => True) = Current_Scope + then + null; else -- If declaration appears in some other scope, it must be in some -- parent unit when compiling a child. - Pack := Defining_Entity (Parent (N)); + Pack := Defining_Entity (Parent (N), Empty_On_Errors => True); if not In_Open_Scopes (Pack) then - null; -- default as well + null; -- If the use clause appears in an ancestor and we are in the -- private part of the immediate parent, the use clauses are @@ -4547,11 +4578,11 @@ package body Sem_Ch8 is --------------------- procedure End_Use_Clauses (Clause : Node_Id) is - U : Node_Id; + U : Node_Id; begin - -- Remove Use_Type clauses first, because they affect the - -- visibility of operators in subsequent used packages. + -- Remove use_type_clauses first, because they affect the visibility of + -- operators in subsequent used packages. U := Clause; while Present (U) loop @@ -4577,8 +4608,8 @@ package body Sem_Ch8 is --------------------- procedure End_Use_Package (N : Node_Id) is - Pack_Name : Node_Id; Pack : Entity_Id; + Pack_Name : Node_Id; Id : Entity_Id; Elmt : Elmt_Id; @@ -4603,43 +4634,64 @@ package body Sem_Ch8 is -- Start of processing for End_Use_Package begin - Pack_Name := First (Names (N)); - while Present (Pack_Name) loop + Pack_Name := Name (N); - -- Test that Pack_Name actually denotes a package before processing + -- Test that Pack_Name actually denotes a package before processing - if Is_Entity_Name (Pack_Name) - and then Ekind (Entity (Pack_Name)) = E_Package - then - Pack := Entity (Pack_Name); + if Is_Entity_Name (Pack_Name) + and then Ekind (Entity (Pack_Name)) = E_Package + then + Pack := Entity (Pack_Name); - if In_Open_Scopes (Pack) then - null; + if In_Open_Scopes (Pack) then + null; - elsif not Redundant_Use (Pack_Name) then - Set_In_Use (Pack, False); - Set_Current_Use_Clause (Pack, Empty); + elsif not Redundant_Use (Pack_Name) then + Set_In_Use (Pack, False); + Set_Current_Use_Clause (Pack, Empty); - Id := First_Entity (Pack); - while Present (Id) loop + Id := First_Entity (Pack); + while Present (Id) loop - -- Preserve use-visibility of operators that are primitive - -- operators of a type that is use-visible through an active - -- use_type clause. + -- Preserve use-visibility of operators that are primitive + -- operators of a type that is use-visible through an active + -- use_type_clause. - if Nkind (Id) = N_Defining_Operator_Symbol - and then - (Is_Primitive_Operator_In_Use (Id, First_Formal (Id)) - or else - (Present (Next_Formal (First_Formal (Id))) - and then - Is_Primitive_Operator_In_Use - (Id, Next_Formal (First_Formal (Id))))) - then - null; - else - Set_Is_Potentially_Use_Visible (Id, False); - end if; + if Nkind (Id) = N_Defining_Operator_Symbol + and then + (Is_Primitive_Operator_In_Use (Id, First_Formal (Id)) + or else + (Present (Next_Formal (First_Formal (Id))) + and then + Is_Primitive_Operator_In_Use + (Id, Next_Formal (First_Formal (Id))))) + then + null; + else + Set_Is_Potentially_Use_Visible (Id, False); + end if; + + if Is_Private_Type (Id) + and then Present (Full_View (Id)) + then + Set_Is_Potentially_Use_Visible (Full_View (Id), False); + end if; + + Next_Entity (Id); + end loop; + + if Present (Renamed_Object (Pack)) then + Set_In_Use (Renamed_Object (Pack), False); + Set_Current_Use_Clause (Renamed_Object (Pack), Empty); + end if; + + if Chars (Pack) = Name_System + and then Scope (Pack) = Standard_Standard + and then Present_System_Aux + then + Id := First_Entity (System_Aux_Id); + while Present (Id) loop + Set_Is_Potentially_Use_Visible (Id, False); if Is_Private_Type (Id) and then Present (Full_View (Id)) @@ -4650,38 +4702,12 @@ package body Sem_Ch8 is Next_Entity (Id); end loop; - if Present (Renamed_Object (Pack)) then - Set_In_Use (Renamed_Object (Pack), False); - Set_Current_Use_Clause (Renamed_Object (Pack), Empty); - end if; - - if Chars (Pack) = Name_System - and then Scope (Pack) = Standard_Standard - and then Present_System_Aux - then - Id := First_Entity (System_Aux_Id); - while Present (Id) loop - Set_Is_Potentially_Use_Visible (Id, False); - - if Is_Private_Type (Id) - and then Present (Full_View (Id)) - then - Set_Is_Potentially_Use_Visible (Full_View (Id), False); - end if; - - Next_Entity (Id); - end loop; - - Set_In_Use (System_Aux_Id, False); - end if; - - else - Set_Redundant_Use (Pack_Name, False); + Set_In_Use (System_Aux_Id, False); end if; + else + Set_Redundant_Use (Pack_Name, False); end if; - - Next (Pack_Name); - end loop; + end if; if Present (Hidden_By_Use_Clause (N)) then Elmt := First_Elmt (Hidden_By_Use_Clause (N)); @@ -4714,30 +4740,26 @@ package body Sem_Ch8 is ------------------ procedure End_Use_Type (N : Node_Id) is - Elmt : Elmt_Id; - Id : Entity_Id; - T : Entity_Id; + Elmt : Elmt_Id; + Id : Entity_Id; + T : Entity_Id; -- Start of processing for End_Use_Type begin - Id := First (Subtype_Marks (N)); - while Present (Id) loop - - -- A call to Rtsfind may occur while analyzing a use_type clause, - -- in which case the type marks are not resolved yet, and there is - -- nothing to remove. + Id := Subtype_Mark (N); - if not Is_Entity_Name (Id) or else No (Entity (Id)) then - goto Continue; - end if; + -- A call to Rtsfind may occur while analyzing a use_type_clause, in + -- which case the type marks are not resolved yet, so guard against that + -- here. + if Is_Entity_Name (Id) and then Present (Entity (Id)) then T := Entity (Id); if T = Any_Type or else From_Limited_With (T) then null; - -- Note that the use_type clause may mention a subtype of the type + -- Note that the use_type_clause may mention a subtype of the type -- whose primitive operations have been made visible. Here as -- elsewhere, it is the base type that matters for visibility. @@ -4750,10 +4772,7 @@ package body Sem_Ch8 is Set_Current_Use_Clause (T, Empty); Set_Current_Use_Clause (Base_Type (T), Empty); end if; - - <<Continue>> - Next (Id); - end loop; + end if; if Is_Empty_Elmt_List (Used_Operations (N)) then return; @@ -4767,6 +4786,21 @@ package body Sem_Ch8 is end if; end End_Use_Type; + -------------------- + -- Entity_Of_Unit -- + -------------------- + + function Entity_Of_Unit (U : Node_Id) return Entity_Id is + begin + if Nkind (U) = N_Package_Instantiation + and then Analyzed (U) + then + return Defining_Entity (Instance_Spec (U)); + else + return Defining_Entity (U); + end if; + end Entity_Of_Unit; + ---------------------- -- Find_Direct_Name -- ---------------------- @@ -5384,6 +5418,17 @@ package body Sem_Ch8 is end; end if; + -- Although the marking of use clauses happens at the end of + -- Find_Direct_Name, a certain case where a generic actual satisfies + -- a use clause must be checked here due to how the generic machinery + -- handles the analysis of said actuals. + + if In_Instance + and then Nkind (Parent (N)) = N_Generic_Association + then + Mark_Use_Clauses (Entity (N)); + end if; + return; end if; @@ -5561,7 +5606,7 @@ package body Sem_Ch8 is goto Done; elsif Is_Predefined_Unit (Current_Sem_Unit) then - -- A use-clause in the body of a system file creates conflict + -- A use clause in the body of a system file creates conflict -- with some entity in a user scope, while rtsfind is active. -- Keep only the entity coming from another predefined unit. @@ -5843,6 +5888,20 @@ package body Sem_Ch8 is end if; end; + -- Mark relevant use-type and use-package clauses as effective if the + -- node in question is not overloaded and therefore does not require + -- resolution. + -- + -- Note: Generic actual subprograms do not follow the normal resolution + -- path, so ignore the fact that they are overloaded and mark them + -- anyway. + + if Nkind (N) not in N_Subexpr + or else not Is_Overloaded (N) + then + Mark_Use_Clauses (N); + end if; + -- Come here with entity set <<Done>> @@ -6460,9 +6519,34 @@ package body Sem_Ch8 is Generate_Reference (Id, N); end if; + -- Mark relevant use-type and use-package clauses as effective if the + -- node in question is not overloaded and therefore does not require + -- resolution. + + if Nkind (N) not in N_Subexpr or else not Is_Overloaded (N) then + Mark_Use_Clauses (N); + end if; + Check_Restriction_No_Use_Of_Entity (N); end Find_Expanded_Name; + -------------------- + -- Find_Most_Prev -- + -------------------- + + function Find_Most_Prev (Use_Clause : Node_Id) return Node_Id is + Curr : Node_Id; + begin + -- Loop through the Prev_Use_Clause chain + + Curr := Use_Clause; + while Present (Prev_Use_Clause (Curr)) loop + Curr := Prev_Use_Clause (Curr); + end loop; + + return Curr; + end Find_Most_Prev; + ------------------------- -- Find_Renamed_Entity -- ------------------------- @@ -8039,9 +8123,7 @@ package body Sem_Ch8 is (Clause : Node_Id; Force_Installation : Boolean := False) is - U : Node_Id; - P : Node_Id; - Id : Entity_Id; + U : Node_Id; begin U := Clause; @@ -8050,44 +8132,13 @@ package body Sem_Ch8 is -- Case of USE package if Nkind (U) = N_Use_Package_Clause then - P := First (Names (U)); - while Present (P) loop - Id := Entity (P); - - if Ekind (Id) = E_Package then - if In_Use (Id) then - Note_Redundant_Use (P); - - elsif Present (Renamed_Object (Id)) - and then In_Use (Renamed_Object (Id)) - then - Note_Redundant_Use (P); - - elsif Force_Installation or else Applicable_Use (P) then - Use_One_Package (Id, U); - - end if; - end if; - - Next (P); - end loop; + Use_One_Package (U, Name (U), True); -- Case of USE TYPE else - P := First (Subtype_Marks (U)); - while Present (P) loop - if not Is_Entity_Name (P) - or else No (Entity (P)) - then - null; + Use_One_Type (Subtype_Mark (U), Force => Force_Installation); - elsif Entity (P) /= Any_Type then - Use_One_Type (P); - end if; - - Next (P); - end loop; end if; Next_Use_Clause (U); @@ -8145,196 +8196,268 @@ package body Sem_Ch8 is and then Has_Components (Designated_Type (T)))); end Is_Appropriate_For_Record; - ------------------------ - -- Note_Redundant_Use -- - ------------------------ + ---------------------- + -- Mark_Use_Clauses -- + ---------------------- - procedure Note_Redundant_Use (Clause : Node_Id) is - Pack_Name : constant Entity_Id := Entity (Clause); - Cur_Use : constant Node_Id := Current_Use_Clause (Pack_Name); - Decl : constant Node_Id := Parent (Clause); + procedure Mark_Use_Clauses (Id : Node_Or_Entity_Id) is - Prev_Use : Node_Id := Empty; - Redundant : Node_Id := Empty; - -- The Use_Clause which is actually redundant. In the simplest case it - -- is Pack itself, but when we compile a body we install its context - -- before that of its spec, in which case it is the use_clause in the - -- spec that will appear to be redundant, and we want the warning to be - -- placed on the body. Similar complications appear when the redundancy - -- is between a child unit and one of its ancestors. + procedure Mark_Parameters (Call : Entity_Id); + -- Perform use_type_clause marking for all parameters in a subprogram + -- or operator call. - begin - Set_Redundant_Use (Clause, True); + procedure Mark_Use_Package (Pak : Entity_Id); + -- Move up the Prev_Use_Clause chain for packages denoted by Pak - + -- marking each clause in the chain as effective in the process. - if not Comes_From_Source (Clause) - or else In_Instance - or else not Warn_On_Redundant_Constructs - then - return; - end if; + procedure Mark_Use_Type (E : Entity_Id); + -- Similar to Do_Use_Package_Marking except we move up the + -- Prev_Use_Clause chain for the type denoted by E. - if not Is_Compilation_Unit (Current_Scope) then + --------------------- + -- Mark_Parameters -- + --------------------- - -- If the use_clause is in an inner scope, it is made redundant by - -- some clause in the current context, with one exception: If we're - -- compiling a nested package body, and the use_clause comes from the - -- corresponding spec, the clause is not necessarily fully redundant, - -- so we should not warn. If a warning was warranted, it would have - -- been given when the spec was processed. + procedure Mark_Parameters (Call : Entity_Id) is + Curr : Node_Id; - if Nkind (Parent (Decl)) = N_Package_Specification then - declare - Package_Spec_Entity : constant Entity_Id := - Defining_Unit_Name (Parent (Decl)); - begin - if In_Package_Body (Package_Spec_Entity) then - return; - end if; - end; - end if; + begin + -- Move through all of the formals - Redundant := Clause; - Prev_Use := Cur_Use; + Curr := First_Formal (Call); + while Present (Curr) loop + Mark_Use_Type (Curr); - elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then - declare - Cur_Unit : constant Unit_Number_Type := Get_Source_Unit (Cur_Use); - New_Unit : constant Unit_Number_Type := Get_Source_Unit (Clause); - Scop : Entity_Id; + Curr := Next_Formal (Curr); + end loop; - begin - if Cur_Unit = New_Unit then + -- Handle the return type - -- Redundant clause in same body + Mark_Use_Type (Call); + end Mark_Parameters; - Redundant := Clause; - Prev_Use := Cur_Use; + ---------------------- + -- Mark_Use_Package -- + ---------------------- - elsif Cur_Unit = Current_Sem_Unit then + procedure Mark_Use_Package (Pak : Entity_Id) is + Curr : Node_Id; - -- If the new clause is not in the current unit it has been - -- analyzed first, and it makes the other one redundant. - -- However, if the new clause appears in a subunit, Cur_Unit - -- is still the parent, and in that case the redundant one - -- is the one appearing in the subunit. + begin + -- Ignore cases where the scope of the type is not a package + -- (e.g. Standard_Standard). - if Nkind (Unit (Cunit (New_Unit))) = N_Subunit then - Redundant := Clause; - Prev_Use := Cur_Use; + if Ekind (Pak) /= E_Package then + return; + end if; - -- Most common case: redundant clause in body, - -- original clause in spec. Current scope is spec entity. + Curr := Current_Use_Clause (Pak); + while Present (Curr) + and then not Is_Effective_Use_Clause (Curr) + loop + -- We need to mark the previous use clauses as effective, but each + -- use clause may in turn render other use_package_clauses + -- effective. Additionally, it is possible to have a parent + -- package renamed as a child of itself so we must check the + -- prefix entity is not the same as the package we are marking. + + if Nkind (Name (Curr)) /= N_Identifier + and then Present (Prefix (Name (Curr))) + and then Entity (Prefix (Name (Curr))) /= Pak + then + Mark_Use_Package (Entity (Prefix (Name (Curr)))); - elsif - Current_Scope = - Defining_Entity ( - Unit (Library_Unit (Cunit (Current_Sem_Unit)))) - then - Redundant := Cur_Use; - Prev_Use := Clause; + -- It is also possible to have a child package without a prefix + -- that relies on a previous use_package_clause. - else - -- The new clause may appear in an unrelated unit, when - -- the parents of a generic are being installed prior to - -- instantiation. In this case there must be no warning. - -- We detect this case by checking whether the current top - -- of the stack is related to the current compilation. - - Scop := Current_Scope; - while Present (Scop) and then Scop /= Standard_Standard loop - if Is_Compilation_Unit (Scop) - and then not Is_Child_Unit (Scop) - then - return; + elsif Nkind (Name (Curr)) = N_Identifier + and then Is_Child_Unit (Entity (Name (Curr))) + then + Mark_Use_Package (Scope (Entity (Name (Curr)))); + end if; - elsif Scop = Cunit_Entity (Current_Sem_Unit) then - exit; - end if; + -- Mark the use_package_clause as effective and move up the chain - Scop := Scope (Scop); - end loop; + Set_Is_Effective_Use_Clause (Curr); - Redundant := Cur_Use; - Prev_Use := Clause; - end if; + Curr := Prev_Use_Clause (Curr); + end loop; + end Mark_Use_Package; - elsif New_Unit = Current_Sem_Unit then - Redundant := Clause; - Prev_Use := Cur_Use; + ------------------- + -- Mark_Use_Type -- + ------------------- - else - -- Neither is the current unit, so they appear in parent or - -- sibling units. Warning will be emitted elsewhere. + procedure Mark_Use_Type (E : Entity_Id) is + Curr : Node_Id; - return; + begin + -- Ignore void types and unresolved string literals and primitives + + if Nkind (E) = N_String_Literal + or else Nkind (Etype (E)) not in N_Entity + or else not Is_Type (Etype (E)) + then + return; + end if; + + -- The package containing the type or operator function being used + -- may be in use as well, so mark any use_package_clauses for it as + -- effective. There are also additional sanity checks performed here + -- for ignoring previous errors. + + Mark_Use_Package (Scope (Base_Type (Etype (E)))); + if Nkind (E) in N_Op + and then Present (Entity (E)) + and then Present (Scope (Entity (E))) + then + Mark_Use_Package (Scope (Entity (E))); + end if; + + Curr := Current_Use_Clause (Base_Type (Etype (E))); + while Present (Curr) + and then not Is_Effective_Use_Clause (Curr) + loop + -- Current use_type_clause may render other use_package_clauses + -- effective. + + if Nkind (Subtype_Mark (Curr)) /= N_Identifier + and then Present (Prefix (Subtype_Mark (Curr))) + then + Mark_Use_Package (Entity (Prefix (Subtype_Mark (Curr)))); end if; - end; - elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration - and then Present (Parent_Spec (Unit (Cunit (Current_Sem_Unit)))) - then - -- Use_clause is in child unit of current unit, and the child unit - -- appears in the context of the body of the parent, so it has been - -- installed first, even though it is the redundant one. Depending on - -- their placement in the context, the visible or the private parts - -- of the two units, either might appear as redundant, but the - -- message has to be on the current unit. - - if Get_Source_Unit (Cur_Use) = Current_Sem_Unit then - Redundant := Cur_Use; - Prev_Use := Clause; - else - Redundant := Clause; - Prev_Use := Cur_Use; + -- Mark the use_type_clause as effective and move up the chain + + Set_Is_Effective_Use_Clause (Curr); + + Curr := Prev_Use_Clause (Curr); + end loop; + end Mark_Use_Type; + + -- Start of processing for Mark_Use_Clauses + + begin + -- Use clauses in and of themselves do not count as a "use" of a + -- package. + + if Nkind_In (Parent (Id), N_Use_Type_Clause, N_Use_Package_Clause) then + return; + end if; + + -- Handle entities + + if Nkind (Id) in N_Entity then + + -- Mark the entity's package + + if Is_Potentially_Use_Visible (Id) then + Mark_Use_Package (Scope (Id)); end if; - -- If the new use clause appears in the private part of a parent unit - -- it may appear to be redundant w.r.t. a use clause in a child unit, - -- but the previous use clause was needed in the visible part of the - -- child, and no warning should be emitted. + -- Mark enumeration literals - if Nkind (Parent (Decl)) = N_Package_Specification - and then - List_Containing (Decl) = Private_Declarations (Parent (Decl)) + if Ekind (Id) = E_Enumeration_Literal then + Mark_Use_Type (Id); + + -- Mark primitives + + elsif (Ekind (Id) in Overloadable_Kind + or else Ekind_In + (Ekind (Id), E_Generic_Function, E_Generic_Procedure)) + and then (Is_Potentially_Use_Visible (Id) + or else Is_Intrinsic_Subprogram (Id)) then - declare - Par : constant Entity_Id := Defining_Entity (Parent (Decl)); - Spec : constant Node_Id := - Specification (Unit (Cunit (Current_Sem_Unit))); + Mark_Parameters (Id); + end if; - begin - if Is_Compilation_Unit (Par) - and then Par /= Cunit_Entity (Current_Sem_Unit) - and then Parent (Cur_Use) = Spec - and then - List_Containing (Cur_Use) = Visible_Declarations (Spec) - then - return; + -- Handle nodes + + else + -- Mark operators + + if Nkind (Id) in N_Op then + + -- At this point the left operand may not be resolved if we are + -- encountering multiple operators next to eachother in an + -- expression. + + if Nkind (Id) in N_Binary_Op + and then not (Nkind (Left_Opnd (Id)) in N_Op) + then + Mark_Use_Type (Left_Opnd (Id)); + end if; + + Mark_Use_Type (Right_Opnd (Id)); + Mark_Use_Type (Id); + + -- Mark entity identifiers + + elsif Nkind (Id) in N_Has_Entity + and then (Is_Potentially_Use_Visible (Entity (Id)) + or else (Is_Generic_Instance (Entity (Id)) + and then Is_Immediately_Visible (Entity (Id)))) + then + -- Ignore fully qualified names as they do not count as a "use" of + -- a package. + + if Nkind_In (Id, N_Identifier, N_Operator_Symbol) + or else (Present (Prefix (Id)) + and then Scope (Entity (Id)) /= Entity (Prefix (Id))) + then + -- There is a case whereby a unary operator is used within a + -- qualified expression, so mark the parameters as well as the + -- entity. + + if Nkind (Entity (Id)) = N_Defining_Operator_Symbol then + Mark_Parameters (Entity (Id)); end if; - end; + + Mark_Use_Package (Scope (Entity (Id))); + end if; end if; + end if; + end Mark_Use_Clauses; - -- Finally, if the current use clause is in the context then - -- the clause is redundant when it is nested within the unit. + -------------------------------- + -- Most_Descendant_Use_Clause -- + -------------------------------- - elsif Nkind (Parent (Cur_Use)) = N_Compilation_Unit - and then Nkind (Parent (Parent (Clause))) /= N_Compilation_Unit - and then Get_Source_Unit (Cur_Use) = Get_Source_Unit (Clause) - then - Redundant := Clause; - Prev_Use := Cur_Use; + function Most_Descendant_Use_Clause + (Clause1 : Entity_Id; + Clause2 : Entity_Id) return Entity_Id + is + Scope1, Scope2 : Entity_Id; - else - null; + begin + if Clause1 = Clause2 then + return Clause1; end if; - if Present (Redundant) then - Error_Msg_Sloc := Sloc (Prev_Use); - Error_Msg_NE -- CODEFIX - ("& is already use-visible through previous use clause #??", - Redundant, Pack_Name); + -- We determine which one is the most descendant by the scope distance + -- to the ultimate parent unit. + + Scope1 := Entity_Of_Unit (Unit (Parent (Clause1))); + Scope2 := Entity_Of_Unit (Unit (Parent (Clause2))); + while Scope1 /= Standard_Standard + and then Scope2 /= Standard_Standard + loop + Scope1 := Scope (Scope1); + Scope2 := Scope (Scope2); + + if not Present (Scope1) then + return Clause1; + elsif not Present (Scope2) then + return Clause2; + end if; + end loop; + + if Scope1 = Standard_Standard then + return Clause1; end if; - end Note_Redundant_Use; + + return Clause2; + end Most_Descendant_Use_Clause; --------------- -- Pop_Scope -- @@ -8400,9 +8523,9 @@ package body Sem_Ch8 is Scope_Stack.Decrement_Last; end Pop_Scope; - --------------- + ---------------- -- Push_Scope -- - --------------- + ---------------- procedure Push_Scope (S : Entity_Id) is E : constant Entity_Id := Scope (S); @@ -8776,7 +8899,8 @@ package body Sem_Ch8 is and then Scope_Stack.Table (SS_Last).Entity /= Standard_Standard and then Handle_Use then - Install_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause); + Install_Use_Clauses (Scope_Stack.Table (SS_Last).First_Use_Clause, + Force_Installation => True); end if; end Restore_Scope_Stack; @@ -8873,10 +8997,7 @@ package body Sem_Ch8 is ------------- procedure Set_Use (L : List_Id) is - Decl : Node_Id; - Pack_Name : Node_Id; - Pack : Entity_Id; - Id : Entity_Id; + Decl : Node_Id; begin if Present (L) then @@ -8884,52 +9005,412 @@ package body Sem_Ch8 is while Present (Decl) loop if Nkind (Decl) = N_Use_Package_Clause then Chain_Use_Clause (Decl); + Use_One_Package (Decl, Name (Decl)); + + elsif Nkind (Decl) = N_Use_Type_Clause then + Chain_Use_Clause (Decl); + Use_One_Type (Subtype_Mark (Decl)); + + end if; + + Next (Decl); + end loop; + end if; + end Set_Use; + + ----------------------------- + -- Update_Use_Clause_Chain -- + ----------------------------- + + procedure Update_Use_Clause_Chain is - Pack_Name := First (Names (Decl)); - while Present (Pack_Name) loop - Pack := Entity (Pack_Name); + procedure Update_Chain_In_Scope (Level : Int); + -- Iterate through one level in the scope stack verifying each use-type + -- clause within said level is used then reset the Current_Use_Clause + -- to a redundant use clause outside of the current ending scope if such + -- a clause exists. - if Ekind (Pack) = E_Package - and then Applicable_Use (Pack_Name) + --------------------------- + -- Update_Chain_In_Scope -- + --------------------------- + + procedure Update_Chain_In_Scope (Level : Int) is + Curr : Node_Id; + N : Node_Id; + + begin + -- Loop through all use clauses within the scope dictated by Level + + Curr := Scope_Stack.Table (Level).First_Use_Clause; + while Present (Curr) loop + + -- Retrieve the subtype mark or name within the current current + -- use clause. + + if Nkind (Curr) = N_Use_Type_Clause then + N := Subtype_Mark (Curr); + else + N := Name (Curr); + end if; + + -- If warnings for unreferenced entities are enabled and the + -- current use clause has not been marked effective. + + if Check_Unreferenced + and then Comes_From_Source (Curr) + and then not Is_Effective_Use_Clause (Curr) + and then not In_Instance + then + + -- We are dealing with a potentially unused use_package_clause + + if Nkind (Curr) = N_Use_Package_Clause then + + -- Renamings and formal subprograms may cause the associated + -- to be marked as effective instead of the original. + + if not (Present (Associated_Node (N)) + and then Present + (Current_Use_Clause (Associated_Node (N))) + and then Is_Effective_Use_Clause + (Current_Use_Clause (Associated_Node (N)))) then - Use_One_Package (Pack, Decl); + Error_Msg_Node_1 := Entity (N); + Error_Msg_NE ("ineffective use clause for package &?", + Curr, Entity (N)); end if; - Next (Pack_Name); - end loop; + -- We are dealing with an unused use_type_clause - elsif Nkind (Decl) = N_Use_Type_Clause then - Chain_Use_Clause (Decl); + else + Error_Msg_Node_1 := Etype (N); + Error_Msg_NE ("ineffective use clause for }?", + Curr, Etype (N)); + end if; + end if; - Id := First (Subtype_Marks (Decl)); - while Present (Id) loop - if Entity (Id) /= Any_Type then - Use_One_Type (Id); - end if; + -- Verify that we haven't already processed a redundant + -- use_type_clause within the same scope before we move the + -- current use clause up to a previous one for type T. - Next (Id); - end loop; + if Present (Prev_Use_Clause (Curr)) then + Set_Current_Use_Clause (Entity (N), Prev_Use_Clause (Curr)); end if; - Next (Decl); + Curr := Next_Use_Clause (Curr); end loop; + end Update_Chain_In_Scope; + + -- Start of processing for Update_Use_Clause_Chain + + begin + Update_Chain_In_Scope (Scope_Stack.Last); + + -- Deal with use clauses within the context area if the current + -- scope is a compilation unit. + + if Is_Compilation_Unit (Current_Scope) then + + pragma Assert (Scope_Stack.Last /= Scope_Stack.First); + + Update_Chain_In_Scope (Scope_Stack.Last - 1); end if; - end Set_Use; + end Update_Use_Clause_Chain; --------------------- -- Use_One_Package -- --------------------- - procedure Use_One_Package (P : Entity_Id; N : Node_Id) is + procedure Use_One_Package + (N : Node_Id; + Pack_Name : Entity_Id := Empty; + Force : Boolean := False) + is + + procedure Note_Redundant_Use (Clause : Node_Id); + -- Mark the name in a use clause as redundant if the corresponding + -- entity is already use-visible. Emit a warning if the use clause comes + -- from source and the proper warnings are enabled. + + ------------------------ + -- Note_Redundant_Use -- + ------------------------ + + procedure Note_Redundant_Use (Clause : Node_Id) is + Pack_Name : constant Entity_Id := Entity (Clause); + Decl : constant Node_Id := Parent (Clause); + + Cur_Use : Node_Id := Current_Use_Clause (Pack_Name); + Prev_Use : Node_Id := Empty; + Redundant : Node_Id := Empty; + -- The Use_Clause which is actually redundant. In the simplest case + -- it is Pack itself, but when we compile a body we install its + -- context before that of its spec, in which case it is the + -- use_clause in the spec that will appear to be redundant, and we + -- want the warning to be placed on the body. Similar complications + -- appear when the redundancy is between a child unit and one of its + -- ancestors. + + begin + -- Could be renamed... + + if No (Cur_Use) then + Cur_Use := Current_Use_Clause (Renamed_Entity (Pack_Name)); + end if; + + Set_Redundant_Use (Clause, True); + + if not Comes_From_Source (Clause) + or else In_Instance + or else not Warn_On_Redundant_Constructs + then + return; + end if; + + if not Is_Compilation_Unit (Current_Scope) then + + -- If the use_clause is in an inner scope, it is made redundant by + -- some clause in the current context, with one exception: If we + -- are compiling a nested package body, and the use_clause comes + -- from then corresponding spec, the clause is not necessarily + -- fully redundant, so we should not warn. If a warning was + -- warranted, it would have been given when the spec was + -- processed. + + if Nkind (Parent (Decl)) = N_Package_Specification then + declare + Package_Spec_Entity : constant Entity_Id := + Defining_Unit_Name (Parent (Decl)); + begin + if In_Package_Body (Package_Spec_Entity) then + return; + end if; + end; + end if; + + Redundant := Clause; + Prev_Use := Cur_Use; + + elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then + declare + Cur_Unit : constant Unit_Number_Type := + Get_Source_Unit (Cur_Use); + New_Unit : constant Unit_Number_Type := + Get_Source_Unit (Clause); + Scop : Entity_Id; + + begin + if Cur_Unit = New_Unit then + + -- Redundant clause in same body + + Redundant := Clause; + Prev_Use := Cur_Use; + + elsif Cur_Unit = Current_Sem_Unit then + + -- If the new clause is not in the current unit it has been + -- analyzed first, and it makes the other one redundant. + -- However, if the new clause appears in a subunit, Cur_Unit + -- is still the parent, and in that case the redundant one + -- is the one appearing in the subunit. + + if Nkind (Unit (Cunit (New_Unit))) = N_Subunit then + Redundant := Clause; + Prev_Use := Cur_Use; + + -- Most common case: redundant clause in body, + -- original clause in spec. Current scope is spec entity. + + elsif Current_Scope = Cunit_Entity (Current_Sem_Unit) then + Redundant := Cur_Use; + Prev_Use := Clause; + + else + -- The new clause may appear in an unrelated unit, when + -- the parents of a generic are being installed prior to + -- instantiation. In this case there must be no warning. + -- We detect this case by checking whether the current + -- top of the stack is related to the current + -- compilation. + + Scop := Current_Scope; + while Present (Scop) + and then Scop /= Standard_Standard + loop + if Is_Compilation_Unit (Scop) + and then not Is_Child_Unit (Scop) + then + return; + + elsif Scop = Cunit_Entity (Current_Sem_Unit) then + exit; + end if; + + Scop := Scope (Scop); + end loop; + + Redundant := Cur_Use; + Prev_Use := Clause; + end if; + + elsif New_Unit = Current_Sem_Unit then + Redundant := Clause; + Prev_Use := Cur_Use; + + else + -- Neither is the current unit, so they appear in parent or + -- sibling units. Warning will be emitted elsewhere. + + return; + end if; + end; + + elsif Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Declaration + and then Present (Parent_Spec (Unit (Cunit (Current_Sem_Unit)))) + then + -- Use_clause is in child unit of current unit, and the child unit + -- appears in the context of the body of the parent, so it has + -- been installed first, even though it is the redundant one. + -- Depending on their placement in the context, the visible or the + -- private parts of the two units, either might appear as + -- redundant, but the message has to be on the current unit. + + if Get_Source_Unit (Cur_Use) = Current_Sem_Unit then + Redundant := Cur_Use; + Prev_Use := Clause; + else + Redundant := Clause; + Prev_Use := Cur_Use; + end if; + + -- If the new use clause appears in the private part of a parent + -- unit it may appear to be redundant w.r.t. a use clause in a + -- child unit, but the previous use clause was needed in the + -- visible part of the child, and no warning should be emitted. + + if Nkind (Parent (Decl)) = N_Package_Specification + and then + List_Containing (Decl) = Private_Declarations (Parent (Decl)) + then + declare + Par : constant Entity_Id := Defining_Entity (Parent (Decl)); + Spec : constant Node_Id := + Specification (Unit (Cunit (Current_Sem_Unit))); + + begin + if Is_Compilation_Unit (Par) + and then Par /= Cunit_Entity (Current_Sem_Unit) + and then Parent (Cur_Use) = Spec + and then + List_Containing (Cur_Use) = Visible_Declarations (Spec) + then + return; + end if; + end; + end if; + + -- Finally, if the current use clause is in the context then + -- the clause is redundant when it is nested within the unit. + + elsif Nkind (Parent (Cur_Use)) = N_Compilation_Unit + and then Nkind (Parent (Parent (Clause))) /= N_Compilation_Unit + and then Get_Source_Unit (Cur_Use) = Get_Source_Unit (Clause) + then + Redundant := Clause; + Prev_Use := Cur_Use; + + end if; + + if Present (Redundant) then + -- Make sure we are looking at most-descendant use_package_clause + -- by traversing the chain with Find_Most_Prev and then verifying + -- there is no scope manipulation via Most_Descendant_Use_Clause. + + if Nkind (Prev_Use) = N_Use_Package_Clause + and then + (Nkind (Parent (Prev_Use)) /= N_Compilation_Unit + or else Most_Descendant_Use_Clause + (Prev_Use, Find_Most_Prev (Prev_Use)) /= Prev_Use) + then + Prev_Use := Find_Most_Prev (Prev_Use); + end if; + + Error_Msg_Sloc := Sloc (Prev_Use); + Error_Msg_NE -- CODEFIX + ("& is already use-visible through previous use clause #??", + Redundant, Pack_Name); + end if; + end Note_Redundant_Use; + + -- Local variables + Id : Entity_Id; Prev : Entity_Id; Current_Instance : Entity_Id := Empty; Real_P : Entity_Id; Private_With_OK : Boolean := False; + P : Entity_Id; + + -- Start of processing for Use_One_Package begin - if Ekind (P) /= E_Package then - return; + -- Use_One_Package may have been called recursively to handle an + -- implicit use for a auxiliary system package, so set P accordingly + -- and skip redundancy checks. + + if No (Pack_Name) and then Present_System_Aux (N) then + P := System_Aux_Id; + + -- Check for redundant use_package_clauses + + else + -- Ignore cases where we are dealing with a non user defined package + -- like Standard_Standard or something other than a valid package. + + if not Is_Entity_Name (Pack_Name) + or else No (Entity (Pack_Name)) + or else Ekind (Entity (Pack_Name)) /= E_Package + then + return; + end if; + + -- When a renaming exists we must check it for redundancy. The + -- original package would have already been seen at this point. + + if Present (Renamed_Object (Entity (Pack_Name))) then + P := Renamed_Object (Entity (Pack_Name)); + else + P := Entity (Pack_Name); + end if; + + -- Check for redundant clauses then set the current use clause for + -- P if were are not "forcing" an installation from a scope + -- reinstallation that is done throughout analysis for various + -- reasons. + + if In_Use (P) then + Note_Redundant_Use (Pack_Name); + if not Force then + Set_Current_Use_Clause (P, N); + end if; + return; + + -- Warn about detected redundant clauses + + elsif In_Open_Scopes (P) and not Force then + if Warn_On_Redundant_Constructs and then P = Current_Scope then + Error_Msg_NE -- CODEFIX + ("& is already use-visible within itself?r?", + Pack_Name, P); + end if; + return; + end if; + + -- Set P back to the non-renamed package so that visiblilty of the + -- entities within the package can be properly set below. + + P := Entity (Pack_Name); end if; Set_In_Use (P); @@ -9113,16 +9594,17 @@ package body Sem_Ch8 is and then Scope (Real_P) = Standard_Standard and then Present_System_Aux (N) then - Use_One_Package (System_Aux_Id, N); + Use_One_Package (N); end if; - end Use_One_Package; ------------------ -- Use_One_Type -- ------------------ - procedure Use_One_Type (Id : Node_Id; Installed : Boolean := False) is + procedure Use_One_Type + (Id : Node_Id; Installed : Boolean := False; Force : Boolean := False) + is Elmt : Elmt_Id; Is_Known_Used : Boolean; Op_List : Elist_Id; @@ -9174,8 +9656,8 @@ package body Sem_Ch8 is Ent : Entity_Id; function Is_Class_Wide_Operation_Of - (Op : Entity_Id; - T : Entity_Id) return Boolean; + (Op : Entity_Id; + T : Entity_Id) return Boolean; -- Determine whether a subprogram has a class-wide parameter or -- result that is T'Class. @@ -9232,19 +9714,26 @@ package body Sem_Ch8 is -- Start of processing for Use_One_Type begin + if Entity (Id) = Any_Type then + return; + end if; + -- It is the type determined by the subtype mark (8.4(8)) whose -- operations become potentially use-visible. T := Base_Type (Entity (Id)); - -- Either the type itself is used, the package where it is declared - -- is in use or the entity is declared in the current package, thus + -- Either the type itself is used, the package where it is declared is + -- in use or the entity is declared in the current package, thus -- use-visible. - Is_Known_Used := - In_Use (T) - or else In_Use (Scope (T)) - or else Scope (T) = Current_Scope; + Is_Known_Used := (In_Use (T) + and then ((Present (Current_Use_Clause (T)) + and then All_Present + (Current_Use_Clause (T))) + or else not All_Present (Parent (Id)))) + or else In_Use (Scope (T)) + or else Scope (T) = Current_Scope; Set_Redundant_Use (Id, Is_Known_Used or else Is_Potentially_Use_Visible (T)); @@ -9255,7 +9744,7 @@ package body Sem_Ch8 is elsif In_Open_Scopes (Scope (T)) then null; - -- A limited view cannot appear in a use_type clause. However, an access + -- A limited view cannot appear in a use_type_clause. However, an access -- type whose designated type is limited has the flag but is not itself -- a limited view unless we only have a limited view of its enclosing -- package. @@ -9274,13 +9763,28 @@ package body Sem_Ch8 is -- even if it is redundant at the place of the instantiation. elsif Redundant_Use (Id) then + + -- We must avoid incorrectly setting the Current_Use_Clause when we + -- are working with a redundant clause that has already been linked + -- in the Prev_Use_Clause chain, otherwise the chain will break. + + if Present (Current_Use_Clause (T)) + and then Present (Prev_Use_Clause (Current_Use_Clause (T))) + and then Parent (Id) = Prev_Use_Clause (Current_Use_Clause (T)) + then + null; + else + Set_Current_Use_Clause (T, Parent (Id)); + end if; + Set_Used_Operations (Parent (Id), New_Elmt_List); -- If the subtype mark designates a subtype in a different package, -- we have to check that the parent type is visible, otherwise the - -- use type clause is a noop. Not clear how to do that??? + -- use_type_clause is a no-op. Not clear how to do that??? else + Set_Current_Use_Clause (T, Parent (Id)); Set_In_Use (T); -- If T is tagged, primitive operators on class-wide operands @@ -9290,8 +9794,6 @@ package body Sem_Ch8 is Set_In_Use (Class_Wide_Type (T)); end if; - Set_Current_Use_Clause (T, Parent (Id)); - -- Iterate over primitive operations of the type. If an operation is -- already use_visible, it is the result of a previous use_clause, -- and already appears on the corresponding entity chain. If the @@ -9335,7 +9837,8 @@ package body Sem_Ch8 is -- If warning on redundant constructs, check for unnecessary WITH - if Warn_On_Redundant_Constructs + if not Force + and then Warn_On_Redundant_Constructs and then Is_Known_Used -- with P; with P; use P; @@ -9362,39 +9865,19 @@ package body Sem_Ch8 is if Present (Current_Use_Clause (T)) then Use_Clause_Known : declare - Clause1 : constant Node_Id := Parent (Id); - Clause2 : constant Node_Id := Current_Use_Clause (T); + Clause1 : constant Node_Id := Find_Most_Prev + (Current_Use_Clause (T)); + Clause2 : constant Node_Id := Parent (Id); Ent1 : Entity_Id; Ent2 : Entity_Id; Err_No : Node_Id; Unit1 : Node_Id; Unit2 : Node_Id; - function Entity_Of_Unit (U : Node_Id) return Entity_Id; - -- Return the appropriate entity for determining which unit - -- has a deeper scope: the defining entity for U, unless U - -- is a package instance, in which case we retrieve the - -- entity of the instance spec. - - -------------------- - -- Entity_Of_Unit -- - -------------------- - - function Entity_Of_Unit (U : Node_Id) return Entity_Id is - begin - if Nkind (U) = N_Package_Instantiation - and then Analyzed (U) - then - return Defining_Entity (Instance_Spec (U)); - else - return Defining_Entity (U); - end if; - end Entity_Of_Unit; - -- Start of processing for Use_Clause_Known begin - -- If both current use type clause and the use type clause + -- If both current use_type_clause and the use_type_clause -- for the type are at the compilation unit level, one of -- the units must be an ancestor of the other, and the -- warning belongs on the descendant. @@ -9418,14 +9901,7 @@ package body Sem_Ch8 is -- of the other, or one of them is in a subunit, report -- redundancy on the later one. - if Unit1 = Unit2 then - Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); - Error_Msg_NE -- CODEFIX - ("& is already use-visible through previous " - & "use_type_clause #??", Clause1, T); - return; - - elsif Nkind (Unit1) = N_Subunit then + if Unit1 = Unit2 or else Nkind (Unit1) = N_Subunit then Error_Msg_Sloc := Sloc (Current_Use_Clause (T)); Error_Msg_NE -- CODEFIX ("& is already use-visible through previous " @@ -9443,7 +9919,7 @@ package body Sem_Ch8 is return; end if; - -- There is a redundant use type clause in a child unit. + -- There is a redundant use_type_clause in a child unit. -- Determine which of the units is more deeply nested. -- If a unit is a package instance, retrieve the entity -- and its scope from the instance spec. @@ -9489,13 +9965,22 @@ package body Sem_Ch8 is end; end if; - Error_Msg_NE -- CODEFIX - ("& is already use-visible through previous " - & "use_type_clause #??", Err_No, Id); + if Parent (Id) /= Err_No then + if Most_Descendant_Use_Clause + (Err_No, Parent (Id)) = Parent (Id) + then + Error_Msg_Sloc := Sloc (Err_No); + Err_No := Parent (Id); + end if; + + Error_Msg_NE -- CODEFIX + ("& is already use-visible through previous " + & "use_type_clause #??", Err_No, Id); + end if; - -- Case where current use type clause and the use type - -- clause for the type are not both at the compilation unit - -- level. In this case we don't have location information. + -- Case where current use_type_clause and use_type_clause + -- for the type are not both at the compilation unit level. + -- In this case we don't have location information. else Error_Msg_NE -- CODEFIX @@ -9516,7 +10001,8 @@ package body Sem_Ch8 is -- The package where T is declared is already used elsif In_Use (Scope (T)) then - Error_Msg_Sloc := Sloc (Current_Use_Clause (Scope (T))); + Error_Msg_Sloc := Sloc (Find_Most_Prev + (Current_Use_Clause (Scope (T)))); Error_Msg_NE -- CODEFIX ("& is already use-visible through package use clause #??", Id, T); diff --git a/gcc/ada/sem_ch8.ads b/gcc/ada/sem_ch8.ads index ae63e17..e87f5aa 100644 --- a/gcc/ada/sem_ch8.ads +++ b/gcc/ada/sem_ch8.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -52,8 +52,18 @@ package Sem_Ch8 is procedure Analyze_Object_Renaming (N : Node_Id); procedure Analyze_Package_Renaming (N : Node_Id); procedure Analyze_Subprogram_Renaming (N : Node_Id); - procedure Analyze_Use_Package (N : Node_Id); - procedure Analyze_Use_Type (N : Node_Id); + + procedure Analyze_Use_Package (N : Node_Id; + Chain : Boolean := True); + -- Analyze a use package clause and control (through the Chain + -- parameter) whether to add N to the use clause chain for the name + -- denoted within use clause N in case we are reanalyzing a use clause + -- because of stack manipulation. + + procedure Analyze_Use_Type (N : Node_Id; + Chain : Boolean := True); + -- Similar to Analyze_Use_Package except the Chain parameter applies + -- to the type within N's subtype mark Current_Use_Clause. procedure End_Scope; -- Called at end of scope. On exit from blocks and bodies (subprogram, @@ -131,6 +141,10 @@ package Sem_Ch8 is -- Analyze_Subunit.Re_Install_Use_Clauses to insure that, after the -- analysis of the subunit, the parent's environment is again identical. + procedure Mark_Use_Clauses (Id : Node_Or_Entity_Id); + -- Mark a given entity or node Id's relevant use clauses as effective, + -- including redundant ones and ones outside of the current scope. + procedure Push_Scope (S : Entity_Id); -- Make new scope stack entry, pushing S, the entity for a scope onto the -- top of the scope table. The current setting of the scope suppress flags @@ -174,6 +188,10 @@ package Sem_Ch8 is -- and set the potentially use-visible flags of imported entities before -- analyzing the corresponding package body. + procedure Update_Use_Clause_Chain; + -- Called at the end of a declarative region to detect unused use type + -- clauses and maintain the Current_Use_Clause for type entities. + procedure ws; -- Debugging routine for use in gdb: dump all entities on scope stack diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 2fb8ebd..cbebe26 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -1447,6 +1447,7 @@ package body Sem_Ch9 is -- Process the end label, and terminate the scope Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name); + Update_Use_Clause_Chain; End_Scope; -- If this is an entry family, remove the loop created to provide @@ -1851,6 +1852,7 @@ package body Sem_Ch9 is Check_Completion (Body_Id); Check_References (Spec_Id); Process_End_Label (N, 't', Ref_Id); + Update_Use_Clause_Chain; End_Scope; -- When a Lock_Free aspect specification/pragma forces the lock-free @@ -2991,6 +2993,7 @@ package body Sem_Ch9 is end; Process_End_Label (HSS, 't', Ref_Id); + Update_Use_Clause_Chain; End_Scope; end Analyze_Task_Body; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 5087fe6..803ad0e 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -3010,6 +3010,14 @@ package body Sem_Res is Resolve_Unchecked_Type_Conversion (N, Ctx_Type); end case; + -- Mark relevant use-type and use-package clauses as effective using + -- the original node because constant folding may have occured and + -- removed references that need to be examined. + + if Nkind (Original_Node (N)) in N_Op then + Mark_Use_Clauses (Original_Node (N)); + end if; + -- Ada 2012 (AI05-0149): Apply an (implicit) conversion to an -- expression of an anonymous access type that occurs in the context -- of a named general access type, except when the expression is that @@ -6724,6 +6732,8 @@ package body Sem_Res is end if; end if; + Mark_Use_Clauses (Subp); + Warn_On_Overlapping_Actuals (Nam, N); end Resolve_Call; @@ -7279,6 +7289,8 @@ package body Sem_Res is Check_Ghost_Context (E, N); end if; end if; + + Mark_Use_Clauses (E); end Resolve_Entity_Name; ------------------- diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 278d6b6..f20d9df 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -2225,29 +2225,21 @@ package body Sem_Warn is ---------------------- function Check_Use_Clause (N : Node_Id) return Traverse_Result is - Nam : Node_Id; - begin - if Nkind (N) = N_Use_Package_Clause then - Nam := First (Names (N)); - while Present (Nam) loop - if Entity (Nam) = Pack then - - -- Suppress message if any serious errors detected - -- that turn off expansion, and thus result in false - -- positives for this warning. - - if Serious_Errors_Detected = 0 then - Error_Msg_Qual_Level := 1; - Error_Msg_NE -- CODEFIX - ("?u?no entities of package& are referenced!", - Nam, Pack); - Error_Msg_Qual_Level := 0; - end if; - end if; - - Next (Nam); - end loop; + if Nkind (N) = N_Use_Package_Clause + and then Entity (Name (N)) = Pack + then + -- Suppress message if any serious errors detected that turn + -- off expansion, and thus result in false positives for + -- this warning. + + if Serious_Errors_Detected = 0 then + Error_Msg_Qual_Level := 1; + Error_Msg_NE -- CODEFIX + ("?u?no entities of package& are referenced!", + Name (N), Pack); + Error_Msg_Qual_Level := 0; + end if; end if; return OK; diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads index e19c1c7..de43c29 100644 --- a/gcc/ada/sem_warn.ads +++ b/gcc/ada/sem_warn.ads @@ -27,7 +27,7 @@ -- about uses of uninitialized variables and unused with's. It also has -- some unrelated routines related to the generation of warnings. -with Alloc; use Alloc; +with Alloc; with Table; with Types; use Types; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 4a902e8..4eb1c8c 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -298,7 +298,8 @@ package body Sinfo is or else NT (N).Nkind in N_Has_Entity or else NT (N).Nkind = N_Aggregate or else NT (N).Nkind = N_Extension_Aggregate - or else NT (N).Nkind = N_Selected_Component); + or else NT (N).Nkind = N_Selected_Component + or else NT (N).Nkind = N_Use_Package_Clause); return Node4 (N); end Associated_Node; @@ -1646,7 +1647,7 @@ package body Sinfo is pragma Assert (False or else NT (N).Nkind = N_Use_Package_Clause or else NT (N).Nkind = N_Use_Type_Clause); - return Elist4 (N); + return Elist5 (N); end Hidden_By_Use_Clause; function High_Bound @@ -1882,6 +1883,15 @@ package body Sinfo is return Flag18 (N); end Is_Dynamic_Coextension; + function Is_Effective_Use_Clause + (N : Node_Id) return Boolean is + begin + pragma Assert (False + or else NT (N).Nkind = N_Use_Package_Clause + or else NT (N).Nkind = N_Use_Type_Clause); + return Flag1 (N); + end Is_Effective_Use_Clause; + function Is_Elsif (N : Node_Id) return Boolean is begin @@ -2254,7 +2264,9 @@ package body Sinfo is or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Object_Declaration - or else NT (N).Nkind = N_Parameter_Specification); + or else NT (N).Nkind = N_Parameter_Specification + or else NT (N).Nkind = N_Use_Package_Clause + or else NT (N).Nkind = N_Use_Type_Clause); return Flag5 (N); end More_Ids; @@ -2328,6 +2340,7 @@ package body Sinfo is or else NT (N).Nkind = N_Requeue_Statement or else NT (N).Nkind = N_Subprogram_Renaming_Declaration or else NT (N).Nkind = N_Subunit + or else NT (N).Nkind = N_Use_Package_Clause or else NT (N).Nkind = N_Variant_Part or else NT (N).Nkind = N_With_Clause); return Node2 (N); @@ -2337,8 +2350,7 @@ package body Sinfo is (N : Node_Id) return List_Id is begin pragma Assert (False - or else NT (N).Nkind = N_Abort_Statement - or else NT (N).Nkind = N_Use_Package_Clause); + or else NT (N).Nkind = N_Abort_Statement); return List2 (N); end Names; @@ -2723,10 +2735,21 @@ package body Sinfo is or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Object_Declaration - or else NT (N).Nkind = N_Parameter_Specification); + or else NT (N).Nkind = N_Parameter_Specification + or else NT (N).Nkind = N_Use_Package_Clause + or else NT (N).Nkind = N_Use_Type_Clause); return Flag6 (N); end Prev_Ids; + function Prev_Use_Clause + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Use_Package_Clause + or else NT (N).Nkind = N_Use_Type_Clause); + return Node1 (N); + end Prev_Use_Clause; + function Print_In_Hex (N : Node_Id) return Boolean is begin @@ -3133,7 +3156,8 @@ package body Sinfo is or else NT (N).Nkind = N_Qualified_Expression or else NT (N).Nkind = N_Subtype_Indication or else NT (N).Nkind = N_Type_Conversion - or else NT (N).Nkind = N_Unchecked_Type_Conversion); + or else NT (N).Nkind = N_Unchecked_Type_Conversion + or else NT (N).Nkind = N_Use_Type_Clause); return Node4 (N); end Subtype_Mark; @@ -3141,8 +3165,7 @@ package body Sinfo is (N : Node_Id) return List_Id is begin pragma Assert (False - or else NT (N).Nkind = N_Unconstrained_Array_Definition - or else NT (N).Nkind = N_Use_Type_Clause); + or else NT (N).Nkind = N_Unconstrained_Array_Definition); return List2 (N); end Subtype_Marks; @@ -3338,7 +3361,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Use_Type_Clause); - return Elist5 (N); + return Elist2 (N); end Used_Operations; function Was_Expression_Function @@ -3609,7 +3632,8 @@ package body Sinfo is or else NT (N).Nkind in N_Has_Entity or else NT (N).Nkind = N_Aggregate or else NT (N).Nkind = N_Extension_Aggregate - or else NT (N).Nkind = N_Selected_Component); + or else NT (N).Nkind = N_Selected_Component + or else NT (N).Nkind = N_Use_Package_Clause); Set_Node4 (N, Val); -- semantic field, no parent set end Set_Associated_Node; @@ -4948,7 +4972,7 @@ package body Sinfo is pragma Assert (False or else NT (N).Nkind = N_Use_Package_Clause or else NT (N).Nkind = N_Use_Type_Clause); - Set_Elist4 (N, Val); + Set_Elist5 (N, Val); end Set_Hidden_By_Use_Clause; procedure Set_High_Bound @@ -5184,6 +5208,15 @@ package body Sinfo is Set_Flag18 (N, Val); end Set_Is_Dynamic_Coextension; + procedure Set_Is_Effective_Use_Clause + (N : Node_Id; Val : Boolean := True) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Use_Package_Clause + or else NT (N).Nkind = N_Use_Type_Clause); + Set_Flag1 (N, Val); + end Set_Is_Effective_Use_Clause; + procedure Set_Is_Elsif (N : Node_Id; Val : Boolean := True) is begin @@ -5556,7 +5589,9 @@ package body Sinfo is or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Object_Declaration - or else NT (N).Nkind = N_Parameter_Specification); + or else NT (N).Nkind = N_Parameter_Specification + or else NT (N).Nkind = N_Use_Package_Clause + or else NT (N).Nkind = N_Use_Type_Clause); Set_Flag5 (N, Val); end Set_More_Ids; @@ -5630,6 +5665,7 @@ package body Sinfo is or else NT (N).Nkind = N_Requeue_Statement or else NT (N).Nkind = N_Subprogram_Renaming_Declaration or else NT (N).Nkind = N_Subunit + or else NT (N).Nkind = N_Use_Package_Clause or else NT (N).Nkind = N_Variant_Part or else NT (N).Nkind = N_With_Clause); Set_Node2_With_Parent (N, Val); @@ -5639,8 +5675,7 @@ package body Sinfo is (N : Node_Id; Val : List_Id) is begin pragma Assert (False - or else NT (N).Nkind = N_Abort_Statement - or else NT (N).Nkind = N_Use_Package_Clause); + or else NT (N).Nkind = N_Abort_Statement); Set_List2_With_Parent (N, Val); end Set_Names; @@ -6025,10 +6060,21 @@ package body Sinfo is or else NT (N).Nkind = N_Formal_Object_Declaration or else NT (N).Nkind = N_Number_Declaration or else NT (N).Nkind = N_Object_Declaration - or else NT (N).Nkind = N_Parameter_Specification); + or else NT (N).Nkind = N_Parameter_Specification + or else NT (N).Nkind = N_Use_Package_Clause + or else NT (N).Nkind = N_Use_Type_Clause); Set_Flag6 (N, Val); end Set_Prev_Ids; + procedure Set_Prev_Use_Clause + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Use_Package_Clause + or else NT (N).Nkind = N_Use_Type_Clause); + Set_Node1 (N, Val); -- semantic field, no parent set + end Set_Prev_Use_Clause; + procedure Set_Print_In_Hex (N : Node_Id; Val : Boolean := True) is begin @@ -6418,7 +6464,8 @@ package body Sinfo is or else NT (N).Nkind = N_Qualified_Expression or else NT (N).Nkind = N_Subtype_Indication or else NT (N).Nkind = N_Type_Conversion - or else NT (N).Nkind = N_Unchecked_Type_Conversion); + or else NT (N).Nkind = N_Unchecked_Type_Conversion + or else NT (N).Nkind = N_Use_Type_Clause); Set_Node4_With_Parent (N, Val); end Set_Subtype_Mark; @@ -6426,8 +6473,7 @@ package body Sinfo is (N : Node_Id; Val : List_Id) is begin pragma Assert (False - or else NT (N).Nkind = N_Unconstrained_Array_Definition - or else NT (N).Nkind = N_Use_Type_Clause); + or else NT (N).Nkind = N_Unconstrained_Array_Definition); Set_List2_With_Parent (N, Val); end Set_Subtype_Marks; @@ -6640,7 +6686,7 @@ package body Sinfo is begin pragma Assert (False or else NT (N).Nkind = N_Use_Type_Clause); - Set_Elist5 (N, Val); + Set_Elist2 (N, Val); end Set_Used_Operations; procedure Set_Was_Expression_Function diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index a5a6413..87b6542 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1596,7 +1596,7 @@ package Sinfo is -- added to the size of the prefix. The flag also prevents the infinite -- expansion of the same attribute in the said context. - -- Hidden_By_Use_Clause (Elist4-Sem) + -- Hidden_By_Use_Clause (Elist5-Sem) -- An entity list present in use clauses that appear within -- instantiations. For the resolution of local entities, entities -- introduced by these use clauses have priority over global ones, and @@ -1721,6 +1721,10 @@ package Sinfo is -- coextension must be deallocated and finalized at the same time as -- the enclosing object. + -- Is_Effective_Use_Clause (Flag1-Sem) + -- Present in both N_Use_Type_Clause and N_Use_Package_Clause to indicate + -- a use clause is "used" in the current source. + -- Is_Entry_Barrier_Function (Flag8-Sem) -- This flag is set on N_Subprogram_Declaration and N_Subprogram_Body -- nodes which emulate the barrier function of a protected entry body. @@ -2137,6 +2141,11 @@ package Sinfo is -- ASIS processing (data decomposition annex) to determine if a field is -- present or not. + -- Prev_Use_Clause (Node1-Sem) + -- Present in both N_Use_Package_Clause and N_Use_Type_Clause. Used in + -- detection of ineffective use clauses by allowing a chain of related + -- clauses together to avoid traversing the current scope stack. + -- Print_In_Hex (Flag13-Sem) -- Set on an N_Integer_Literal node to indicate that the value should be -- printed in hexadecimal in the sprint listing. Has no effect on @@ -2338,7 +2347,7 @@ package Sinfo is -- initialized. Used to warn if the corresponding actual type is not -- a fully initialized type. - -- Used_Operations (Elist5-Sem) + -- Used_Operations (Elist2-Sem) -- Present in N_Use_Type_Clause nodes. Holds the list of operations that -- are made potentially use-visible by the clause. Simplifies processing -- on exit from the scope of the use_type_clause, in particular in the @@ -5687,9 +5696,14 @@ package Sinfo is -- N_Use_Package_Clause -- Sloc points to USE - -- Names (List2) + -- Prev_Use_Clause (Node1-Sem) + -- Name (Node2) -- Next_Use_Clause (Node3-Sem) - -- Hidden_By_Use_Clause (Elist4-Sem) + -- Associated_Node (Node4-Sem) + -- Hidden_By_Use_Clause (Elist5-Sem) + -- Is_Effective_Use_Clause (Flag1) + -- More_Ids (Flag5) (set to False if no more identifiers in list) + -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) -------------------------- -- 8.4 Use Type Clause -- @@ -5703,10 +5717,14 @@ package Sinfo is -- N_Use_Type_Clause -- Sloc points to USE - -- Subtype_Marks (List2) + -- Prev_Use_Clause (Node1-Sem) + -- Used_Operations (Elist2-Sem) -- Next_Use_Clause (Node3-Sem) - -- Hidden_By_Use_Clause (Elist4-Sem) - -- Used_Operations (Elist5-Sem) + -- Subtype_Mark (Node4) + -- Hidden_By_Use_Clause (Elist5-Sem) + -- Is_Effective_Use_Clause (Flag1) + -- More_Ids (Flag5) (set to False if no more identifiers in list) + -- Prev_Ids (Flag6) (set to False if no previous identifiers in list) -- All_Present (Flag15) ------------------------------- @@ -9455,7 +9473,7 @@ package Sinfo is (N : Node_Id) return Boolean; -- Flag11 function Hidden_By_Use_Clause - (N : Node_Id) return Elist_Id; -- Elist4 + (N : Node_Id) return Elist_Id; -- Elist5 function High_Bound (N : Node_Id) return Node_Id; -- Node2 @@ -9535,6 +9553,9 @@ package Sinfo is function Is_Dynamic_Coextension (N : Node_Id) return Boolean; -- Flag18 + function Is_Effective_Use_Clause + (N : Node_Id) return Boolean; -- Flag1 + function Is_Elsif (N : Node_Id) return Boolean; -- Flag13 @@ -9802,6 +9823,9 @@ package Sinfo is function Prev_Ids (N : Node_Id) return Boolean; -- Flag6 + function Prev_Use_Clause + (N : Node_Id) return Node_Id; -- Node1 + function Print_In_Hex (N : Node_Id) return Boolean; -- Flag13 @@ -9995,7 +10019,7 @@ package Sinfo is (N : Node_Id) return Node_Id; -- Node3 function Used_Operations - (N : Node_Id) return Elist_Id; -- Elist5 + (N : Node_Id) return Elist_Id; -- Elist2 function Was_Expression_Function (N : Node_Id) return Boolean; -- Flag18 @@ -10511,7 +10535,7 @@ package Sinfo is (N : Node_Id; Val : Boolean := True); -- Flag11 procedure Set_Hidden_By_Use_Clause - (N : Node_Id; Val : Elist_Id); -- Elist4 + (N : Node_Id; Val : Elist_Id); -- Elist5 procedure Set_High_Bound (N : Node_Id; Val : Node_Id); -- Node2 @@ -10591,6 +10615,9 @@ package Sinfo is procedure Set_Is_Dynamic_Coextension (N : Node_Id; Val : Boolean := True); -- Flag18 + procedure Set_Is_Effective_Use_Clause + (N : Node_Id; Val : Boolean := True); -- Flag1 + procedure Set_Is_Elsif (N : Node_Id; Val : Boolean := True); -- Flag13 @@ -10858,6 +10885,9 @@ package Sinfo is procedure Set_Prev_Ids (N : Node_Id; Val : Boolean := True); -- Flag6 + procedure Set_Prev_Use_Clause + (N : Node_Id; Val : Node_Id); -- Node1 + procedure Set_Print_In_Hex (N : Node_Id; Val : Boolean := True); -- Flag13 @@ -11051,7 +11081,7 @@ package Sinfo is (N : Node_Id; Val : Node_Id); -- Node3 procedure Set_Used_Operations - (N : Node_Id; Val : Elist_Id); -- Elist5 + (N : Node_Id; Val : Elist_Id); -- Elist2 procedure Set_Was_Expression_Function (N : Node_Id; Val : Boolean := True); -- Flag18 @@ -12053,18 +12083,18 @@ package Sinfo is 5 => True), -- Subtype_Indication (Node5) N_Use_Package_Clause => - (1 => False, -- unused - 2 => True, -- Names (List2) + (1 => False, -- Prev_Use_Clause (Node1-Sem) + 2 => True, -- Name (Node2) 3 => False, -- Next_Use_Clause (Node3-Sem) - 4 => False, -- Hidden_By_Use_Clause (Elist4-Sem) - 5 => False), -- unused + 4 => False, -- Associated_Node (Node4-Sem) + 5 => False), -- Hidden_By_Use_Clause (Elist5-Sem) N_Use_Type_Clause => - (1 => False, -- unused - 2 => True, -- Subtype_Marks (List2) + (1 => False, -- Prev_Use_Clause (Node1-Sem) + 2 => False, -- Used_Operations (Elist2-Sem) 3 => False, -- Next_Use_Clause (Node3-Sem) - 4 => False, -- Hidden_By_Use_Clause (Elist4-Sem) - 5 => False), -- unused + 4 => True, -- Subtype_Mark (Node4) + 5 => False), -- Hidden_By_Use_Clause (Elist5-Sem) N_Object_Renaming_Declaration => (1 => True, -- Defining_Identifier (Node1) @@ -13053,6 +13083,7 @@ package Sinfo is pragma Inline (Is_Delayed_Aspect); pragma Inline (Is_Disabled); pragma Inline (Is_Dynamic_Coextension); + pragma Inline (Is_Effective_Use_Clause); pragma Inline (Is_Elsif); pragma Inline (Is_Entry_Barrier_Function); pragma Inline (Is_Expanded_Build_In_Place_Call); @@ -13141,6 +13172,7 @@ package Sinfo is pragma Inline (Premature_Use); pragma Inline (Present_Expr); pragma Inline (Prev_Ids); + pragma Inline (Prev_Use_Clause); pragma Inline (Print_In_Hex); pragma Inline (Private_Declarations); pragma Inline (Private_Present); @@ -13400,6 +13432,7 @@ package Sinfo is pragma Inline (Set_Is_Delayed_Aspect); pragma Inline (Set_Is_Disabled); pragma Inline (Set_Is_Dynamic_Coextension); + pragma Inline (Set_Is_Effective_Use_Clause); pragma Inline (Set_Is_Elsif); pragma Inline (Set_Is_Entry_Barrier_Function); pragma Inline (Set_Is_Expanded_Build_In_Place_Call); @@ -13489,6 +13522,7 @@ package Sinfo is pragma Inline (Set_Premature_Use); pragma Inline (Set_Present_Expr); pragma Inline (Set_Prev_Ids); + pragma Inline (Set_Prev_Use_Clause); pragma Inline (Set_Print_In_Hex); pragma Inline (Set_Private_Declarations); pragma Inline (Set_Private_Present); diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index d97a1f7..6e29310 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -3435,12 +3435,12 @@ package body Sprint is when N_Use_Package_Clause => Write_Indent_Str_Sloc ("use "); - Sprint_Comma_List (Names (Node)); + Sprint_Node_Sloc (Name (Node)); Write_Char (';'); when N_Use_Type_Clause => Write_Indent_Str_Sloc ("use type "); - Sprint_Comma_List (Subtype_Marks (Node)); + Sprint_Node_Sloc (Subtype_Mark (Node)); Write_Char (';'); when N_Validate_Unchecked_Conversion => diff --git a/gcc/ada/targparm.adb b/gcc/ada/targparm.adb index 2ee9245..4855db5 100644 --- a/gcc/ada/targparm.adb +++ b/gcc/ada/targparm.adb @@ -24,7 +24,7 @@ ------------------------------------------------------------------------------ with Csets; use Csets; -with Opt; use Opt; +with Opt; with Osint; use Osint; with Output; use Output; diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index e0809f2..0d8eb06 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -572,12 +572,15 @@ package Types is No_Unit : constant Unit_Number_Type := -1; -- Special value used to signal no unit - type Source_File_Index is new Int range 0 .. Int'Last; + type Source_File_Index is new Int range -1 .. Int'Last; -- Type used to index the source file table (see package Sinput) No_Source_File : constant Source_File_Index := 0; -- Value used to indicate no source file present + No_Access_To_Source_File : constant Source_File_Index := -1; + -- Value used to indicate a source file is present but unreadable + ----------------------------------- -- Representation of Time Stamps -- ----------------------------------- diff --git a/gcc/ada/xr_tabls.adb b/gcc/ada/xr_tabls.adb index 8a6411c..8ae9e6d 100644 --- a/gcc/ada/xr_tabls.adb +++ b/gcc/ada/xr_tabls.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -36,7 +36,7 @@ with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Directory_Operations; use GNAT.Directory_Operations; -with GNAT.HTable; use GNAT.HTable; +with GNAT.HTable; with GNAT.Heap_Sort_G; package body Xr_Tabls is diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb index 9250841..b860978 100644 --- a/gcc/ada/xref_lib.adb +++ b/gcc/ada/xref_lib.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-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- -- @@ -30,7 +30,7 @@ with Types; use Types; with Unchecked_Deallocation; with Ada.Strings.Fixed; use Ada.Strings.Fixed; -with Ada.Text_IO; use Ada.Text_IO; +with Ada.Text_IO; with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.IO_Aux; use GNAT.IO_Aux; |