Commit 3ce5ca75 by Robert Dewar Committed by Arnaud Charlet

exp_ch3.adb, [...]: Minor code reorganization.

2010-10-05  Robert Dewar  <dewar@adacore.com>

	* exp_ch3.adb, exp_ch5.adb, exp_disp.adb, exp_dist.adb, gnatlink.adb,
	makeutl.adb, par-ch6.adb, prj-dect.adb, prj-env.adb, prj-env.ads,
	prj-ext.adb, prj-nmsc.adb, prj-part.adb, prj-pp.ads: Minor code
	reorganization.
	Minor reformatting.

From-SVN: r164979
parent 96d2756f
2010-10-05 Robert Dewar <dewar@adacore.com>
* exp_ch3.adb, exp_ch5.adb, exp_disp.adb, exp_dist.adb, gnatlink.adb,
makeutl.adb, par-ch6.adb, prj-dect.adb, prj-env.adb, prj-env.ads,
prj-ext.adb, prj-nmsc.adb, prj-part.adb, prj-pp.ads: Minor code
reorganization.
Minor reformatting.
2010-10-05 Ed Schonberg <schonberg@adacore.com> 2010-10-05 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Check_Parameterless_Call): If the prefix of 'Address is * sem_res.adb (Check_Parameterless_Call): If the prefix of 'Address is
......
...@@ -4892,8 +4892,8 @@ package body Exp_Ch3 is ...@@ -4892,8 +4892,8 @@ package body Exp_Ch3 is
-- Ityp!(Displace (Temp'Address, I'Tag)).all; -- Ityp!(Displace (Temp'Address, I'Tag)).all;
else else
-- Generate the equivalent record type and update -- Generate the equivalent record type and update the
-- the subtype indication to reference it -- subtype indication to reference it.
Expand_Subtype_From_Expr Expand_Subtype_From_Expr
(N => N, (N => N,
...@@ -4928,7 +4928,7 @@ package body Exp_Ch3 is ...@@ -4928,7 +4928,7 @@ package body Exp_Ch3 is
Expression => New_Expr)); Expression => New_Expr));
-- Dynamically reference the tag associated with the -- Dynamically reference the tag associated with the
-- interface -- interface.
Tag_Comp := Tag_Comp :=
Make_Function_Call (Loc, Make_Function_Call (Loc,
...@@ -4945,7 +4945,7 @@ package body Exp_Ch3 is ...@@ -4945,7 +4945,7 @@ package body Exp_Ch3 is
Rewrite (N, Rewrite (N,
Make_Object_Renaming_Declaration (Loc, Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Make_Temporary (Loc, 'D'), Defining_Identifier => Make_Temporary (Loc, 'D'),
Subtype_Mark => New_Occurrence_Of (Typ, Loc), Subtype_Mark => New_Occurrence_Of (Typ, Loc),
Name => Convert_Tag_To_Interface (Typ, Tag_Comp))); Name => Convert_Tag_To_Interface (Typ, Tag_Comp)));
Analyze (N, Suppress => All_Checks); Analyze (N, Suppress => All_Checks);
......
...@@ -1358,7 +1358,7 @@ package body Exp_Ch5 is ...@@ -1358,7 +1358,7 @@ package body Exp_Ch5 is
else else
Expr := Expr :=
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Rhs), Prefix => Duplicate_Subexpr (Rhs),
Selector_Name => New_Occurrence_Of (C, Loc)); Selector_Name => New_Occurrence_Of (C, Loc));
end if; end if;
...@@ -1366,7 +1366,7 @@ package body Exp_Ch5 is ...@@ -1366,7 +1366,7 @@ package body Exp_Ch5 is
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
Name => Name =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Lhs), Prefix => Duplicate_Subexpr (Lhs),
Selector_Name => Selector_Name =>
New_Occurrence_Of (Find_Component (L_Typ, C), Loc)), New_Occurrence_Of (Find_Component (L_Typ, C), Loc)),
Expression => Expr); Expression => Expr);
......
...@@ -481,11 +481,11 @@ package body Exp_Disp is ...@@ -481,11 +481,11 @@ package body Exp_Disp is
and then Is_Interface (Typ) and then Is_Interface (Typ)
and then and then
((Nkind (Expr) = N_Selected_Component ((Nkind (Expr) = N_Selected_Component
and then Is_Tag (Entity (Selector_Name (Expr)))) and then Is_Tag (Entity (Selector_Name (Expr))))
or else or else
(Nkind (Expr) = N_Function_Call (Nkind (Expr) = N_Function_Call
and then RTE_Available (RE_Displace) and then RTE_Available (RE_Displace)
and then Entity (Name (Expr)) = RTE (RE_Displace)))); and then Entity (Name (Expr)) = RTE (RE_Displace))));
Anon_Type := Create_Itype (E_Anonymous_Access_Type, Expr); Anon_Type := Create_Itype (E_Anonymous_Access_Type, Expr);
Set_Directly_Designated_Type (Anon_Type, Typ); Set_Directly_Designated_Type (Anon_Type, Typ);
...@@ -8023,7 +8023,7 @@ package body Exp_Disp is ...@@ -8023,7 +8023,7 @@ package body Exp_Disp is
Write_Int (Int (Alias (Prim))); Write_Int (Int (Alias (Prim)));
-- If the DTC_Entity attribute is already set we can also output -- If the DTC_Entity attribute is already set we can also output
-- the name of the interface covered by this primitive (if any) -- the name of the interface covered by this primitive (if any).
if Present (DTC_Entity (Alias (Prim))) if Present (DTC_Entity (Alias (Prim)))
and then Is_Interface (Scope (DTC_Entity (Alias (Prim)))) and then Is_Interface (Scope (DTC_Entity (Alias (Prim))))
......
...@@ -11044,7 +11044,6 @@ package body Exp_Dist is ...@@ -11044,7 +11044,6 @@ package body Exp_Dist is
begin begin
if Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then if Is_Tagged_Type (Typ) and then not Is_Frozen (Typ) then
null; null;
else else
Serial := Increment_Serial_Number; Serial := Increment_Serial_Number;
end if; end if;
......
...@@ -2001,6 +2001,7 @@ begin ...@@ -2001,6 +2001,7 @@ begin
for J in reverse Linker_Options.First .. Linker_Options.Last loop for J in reverse Linker_Options.First .. Linker_Options.Last loop
-- Remove flags that are not accepted -- Remove flags that are not accepted
if Linker_Options.Table (J)'Length = 0 if Linker_Options.Table (J)'Length = 0
or else Linker_Options.Table (J) (1 .. 2) = "-l" or else Linker_Options.Table (J) (1 .. 2) = "-l"
or else Linker_Options.Table (J) (1 .. 3) = "-Wl" or else Linker_Options.Table (J) (1 .. 3) = "-Wl"
......
...@@ -38,7 +38,7 @@ with Tempdir; ...@@ -38,7 +38,7 @@ with Tempdir;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Command_Line; use Ada.Command_Line;
with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.HTable; with GNAT.HTable;
......
...@@ -224,8 +224,10 @@ package body Ch6 is ...@@ -224,8 +224,10 @@ package body Ch6 is
-- case is for subunits. -- case is for subunits.
if Pf_Flags /= Pf_Decl_Gins_Pbod_Rnam_Stub if Pf_Flags /= Pf_Decl_Gins_Pbod_Rnam_Stub
and then Pf_Flags /= Pf_Decl_Pbod and then
and then Pf_Flags /= Pf_Pbod Pf_Flags /= Pf_Decl_Pbod
and then
Pf_Flags /= Pf_Pbod
then then
Error_Msg_SC ("overriding indicator not allowed here!"); Error_Msg_SC ("overriding indicator not allowed here!");
...@@ -374,11 +376,12 @@ package body Ch6 is ...@@ -374,11 +376,12 @@ package body Ch6 is
end if; end if;
else else
-- Skip extra parenthesis at end of formal part, and if -- Skip extra parenthesis at end of formal part
-- function scan result subtype.
Ignore (Tok_Right_Paren); Ignore (Tok_Right_Paren);
-- For function, scan result subtype
if Func then if Func then
TF_Return; TF_Return;
......
...@@ -179,7 +179,8 @@ package body Prj.Dect is ...@@ -179,7 +179,8 @@ package body Prj.Dect is
procedure Rename_Obsolescent_Attributes procedure Rename_Obsolescent_Attributes
(In_Tree : Project_Node_Tree_Ref; (In_Tree : Project_Node_Tree_Ref;
Attribute : Project_Node_Id; Attribute : Project_Node_Id;
Current_Package : Project_Node_Id) is Current_Package : Project_Node_Id)
is
begin begin
if Present (Current_Package) if Present (Current_Package)
and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
...@@ -214,7 +215,7 @@ package body Prj.Dect is ...@@ -214,7 +215,7 @@ package body Prj.Dect is
Flags : Processing_Flags) Flags : Processing_Flags)
is is
Qualif : constant Project_Qualifier := Qualif : constant Project_Qualifier :=
Project_Qualifier_Of (Project, In_Tree); Project_Qualifier_Of (Project, In_Tree);
Name : constant Name_Id := Name_Of (Current_Package, In_Tree); Name : constant Name_Id := Name_Of (Current_Package, In_Tree);
begin begin
if Qualif = Aggregate if Qualif = Aggregate
...@@ -239,8 +240,9 @@ package body Prj.Dect is ...@@ -239,8 +240,9 @@ package body Prj.Dect is
Flags : Processing_Flags) Flags : Processing_Flags)
is is
Qualif : constant Project_Qualifier := Qualif : constant Project_Qualifier :=
Project_Qualifier_Of (Project, In_Tree); Project_Qualifier_Of (Project, In_Tree);
Name : constant Name_Id := Name_Of (Attribute, In_Tree); Name : constant Name_Id := Name_Of (Attribute, In_Tree);
begin begin
case Qualif is case Qualif is
when Aggregate => when Aggregate =>
...@@ -308,6 +310,7 @@ package body Prj.Dect is ...@@ -308,6 +310,7 @@ package body Prj.Dect is
procedure Process_Attribute_Name is procedure Process_Attribute_Name is
Ignore : Boolean; Ignore : Boolean;
begin begin
Attribute_Name := Token_Name; Attribute_Name := Token_Name;
Set_Name_Of (Attribute, In_Tree, To => Attribute_Name); Set_Name_Of (Attribute, In_Tree, To => Attribute_Name);
......
...@@ -24,16 +24,17 @@ ...@@ -24,16 +24,17 @@
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with Fmap; with Fmap;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with Hostparm; with Hostparm;
with Makeutl; use Makeutl; with Makeutl; use Makeutl;
with Opt; with Opt;
with Osint; use Osint; with Osint; use Osint;
with Output; use Output; with Output; use Output;
with Prj.Com; use Prj.Com; with Prj.Com; use Prj.Com;
with Sdefault; with Sdefault;
with Tempdir; with Tempdir;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
package body Prj.Env is package body Prj.Env is
Buffer_Initial : constant := 1_000; Buffer_Initial : constant := 1_000;
...@@ -110,9 +111,10 @@ package body Prj.Env is ...@@ -110,9 +111,10 @@ package body Prj.Env is
-- Project that itself is not extended. -- Project that itself is not extended.
procedure Initialize_Project_Path procedure Initialize_Project_Path
(Self : in out Project_Search_Path; Target_Name : String); (Self : in out Project_Search_Path;
-- Initialize Current_Project_Path. Target_Name : String);
-- Does nothing if the path has already been initialized properly -- Initialize Current_Project_Path. Does nothing if the path has already
-- been initialized properly.
---------------------- ----------------------
-- Ada_Include_Path -- -- Ada_Include_Path --
...@@ -1780,7 +1782,8 @@ package body Prj.Env is ...@@ -1780,7 +1782,8 @@ package body Prj.Env is
----------------------------- -----------------------------
procedure Initialize_Project_Path procedure Initialize_Project_Path
(Self : in out Project_Search_Path; Target_Name : String) (Self : in out Project_Search_Path;
Target_Name : String)
is is
Add_Default_Dir : Boolean := True; Add_Default_Dir : Boolean := True;
First : Positive; First : Positive;
...@@ -1801,6 +1804,7 @@ package body Prj.Env is ...@@ -1801,6 +1804,7 @@ package body Prj.Env is
begin begin
-- If already initialized, nothing else to do -- If already initialized, nothing else to do
if Self.Path /= null if Self.Path /= null
and then Self.Path (Self.Path'First) /= '#' and then Self.Path (Self.Path'First) /= '#'
then then
......
...@@ -145,9 +145,9 @@ package Prj.Env is ...@@ -145,9 +145,9 @@ package Prj.Env is
(Project : Project_Id; (Project : Project_Id;
In_Tree : Project_Tree_Ref); In_Tree : Project_Tree_Ref);
-- Iterate through all the source directories of a project, including those -- Iterate through all the source directories of a project, including those
-- of imported or modified projects. -- of imported or modified projects. Only returns those directories that
-- Only returns those directories that potentially contain Ada sources (ie -- potentially contain Ada sources (ie ignore projects that have no Ada
-- ignore projects that have no Ada sources -- sources
generic generic
with procedure Action (Path : String); with procedure Action (Path : String);
...@@ -170,11 +170,10 @@ package Prj.Env is ...@@ -170,11 +170,10 @@ package Prj.Env is
procedure Add_Directories procedure Add_Directories
(Self : in out Project_Search_Path; (Self : in out Project_Search_Path;
Path : String); Path : String);
-- Add one or more directories to the path. -- Add one or more directories to the path. Directories added with this
-- Directories added with this procedure are added in order after the -- procedure are added in order after the current directory and before the
-- current directory and before the path given by the environment variable -- path given by the environment variable GPR_PROJECT_PATH. A value of "-"
-- GPR_PROJECT_PATH. A value of "-" will remove the default project -- will remove the default project directory from the project path.
-- directory from the project path.
-- --
-- Calls to this subprogram must be performed before the first call to -- Calls to this subprogram must be performed before the first call to
-- Find_Project below, or PATH will be added at the end of the search -- Find_Project below, or PATH will be added at the end of the search
...@@ -199,13 +198,14 @@ package Prj.Env is ...@@ -199,13 +198,14 @@ package Prj.Env is
Directory : String; Directory : String;
Path : out Namet.Path_Name_Type); Path : out Namet.Path_Name_Type);
-- Search for a the project with the given name either in Directory (which -- Search for a the project with the given name either in Directory (which
-- often will be the directory contain the project we are currently -- often will be the directory contain the project we are currently parsing
-- parsing and which we found a reference to another project), or in the -- and which we found a reference to another project), or in the project
-- project path. Extra_Project_Path contains additional directories to -- path. Extra_Project_Path contains additional directories to search.
-- search. --
-- Project_File_Name can optionally contain directories, and the extension -- Project_File_Name can optionally contain directories, and the extension
-- (.gpr) for the file name is optional. -- (.gpr) for the file name is optional.
-- Returns No_Name if no such project was found. --
-- Returns No_Name if no such project was found
private private
package Projects_Paths is new GNAT.Dynamic_HTables.Simple_HTable package Projects_Paths is new GNAT.Dynamic_HTables.Simple_HTable
......
...@@ -23,8 +23,8 @@ ...@@ -23,8 +23,8 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with Osint; use Osint; with Osint; use Osint;
with Prj.Tree; use Prj.Tree; with Prj.Tree; use Prj.Tree;
package body Prj.Ext is package body Prj.Ext is
......
...@@ -23,11 +23,6 @@ ...@@ -23,11 +23,6 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Dynamic_HTables;
with GNAT.Table;
with Err_Vars; use Err_Vars; with Err_Vars; use Err_Vars;
with Opt; use Opt; with Opt; use Opt;
with Osint; use Osint; with Osint; use Osint;
...@@ -45,6 +40,11 @@ with Ada.Strings; use Ada.Strings; ...@@ -45,6 +40,11 @@ with Ada.Strings; use Ada.Strings;
with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
with GNAT.Case_Util; use GNAT.Case_Util;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with GNAT.Dynamic_HTables;
with GNAT.Table;
package body Prj.Nmsc is package body Prj.Nmsc is
No_Continuation_String : aliased String := ""; No_Continuation_String : aliased String := "";
...@@ -4909,7 +4909,7 @@ package body Prj.Nmsc is ...@@ -4909,7 +4909,7 @@ package body Prj.Nmsc is
Languages : constant Variable_Value := Languages : constant Variable_Value :=
Prj.Util.Value_Of Prj.Util.Value_Of
(Name_Languages, Project.Decl.Attributes, Data.Tree); (Name_Languages, Project.Decl.Attributes, Data.Tree);
Remove_Source_Dirs : Boolean := False; Remove_Source_Dirs : Boolean := False;
......
...@@ -509,8 +509,10 @@ package body Prj.Part is ...@@ -509,8 +509,10 @@ package body Prj.Part is
exception exception
when Types.Unrecoverable_Error => when Types.Unrecoverable_Error =>
-- Unrecoverable_Error is raised when a line is too long. -- Unrecoverable_Error is raised when a line is too long.
-- A meaningful error message will be displayed later. -- A meaningful error message will be displayed later.
Project := Empty_Node; Project := Empty_Node;
end; end;
...@@ -535,7 +537,7 @@ package body Prj.Part is ...@@ -535,7 +537,7 @@ package body Prj.Part is
declare declare
Declaration : constant Project_Node_Id := Declaration : constant Project_Node_Id :=
Project_Declaration_Of (Project, In_Tree); Project_Declaration_Of (Project, In_Tree);
begin begin
Look_For_Virtual_Projects_For Look_For_Virtual_Projects_For
(Extended_Project_Of (Declaration, In_Tree), In_Tree, (Extended_Project_Of (Declaration, In_Tree), In_Tree,
...@@ -544,9 +546,9 @@ package body Prj.Part is ...@@ -544,9 +546,9 @@ package body Prj.Part is
-- Now, check the projects directly imported by the main project. -- Now, check the projects directly imported by the main project.
-- Remove from the potentially virtual any project extended by one -- Remove from the potentially virtual any project extended by one
-- of these imported projects. For non extending imported -- of these imported projects. For non extending imported projects,
-- projects, check that they do not belong to the project tree of -- check that they do not belong to the project tree of the project
-- the project being "extended-all" by the main project. -- being "extended-all" by the main project.
declare declare
With_Clause : Project_Node_Id; With_Clause : Project_Node_Id;
...@@ -930,11 +932,12 @@ package body Prj.Part is ...@@ -930,11 +932,12 @@ package body Prj.Part is
In_Tree : Project_Node_Tree_Ref; In_Tree : Project_Node_Tree_Ref;
Project : Project_Node_Id) Project : Project_Node_Id)
is is
With_Clause, Imported : Project_Node_Id; With_Clause : Project_Node_Id;
Imported : Project_Node_Id;
begin begin
if not Is_Extending_All (Project, In_Tree) then if not Is_Extending_All (Project, In_Tree) then
With_Clause := First_With_Clause_Of (Project, In_Tree); With_Clause := First_With_Clause_Of (Project, In_Tree);
while Present (With_Clause) loop while Present (With_Clause) loop
Imported := Project_Node_Of (With_Clause, In_Tree); Imported := Project_Node_Of (With_Clause, In_Tree);
...@@ -1174,7 +1177,7 @@ package body Prj.Part is ...@@ -1174,7 +1177,7 @@ package body Prj.Part is
end; end;
if Has_Circular_Dependencies if Has_Circular_Dependencies
(Flags, Normed_Path_Name, Canonical_Path_Name) (Flags, Normed_Path_Name, Canonical_Path_Name)
then then
Project := Empty_Node; Project := Empty_Node;
return; return;
...@@ -1641,18 +1644,17 @@ package body Prj.Part is ...@@ -1641,18 +1644,17 @@ package body Prj.Part is
Name_Len := Name_Len - 1; Name_Len := Name_Len - 1;
end loop; end loop;
-- If a dot was found, check if the parent project is imported -- If a dot was found, check if parent project is imported or extended
-- or extended.
if Name_Len > 0 then if Name_Len > 0 then
Name_Len := Name_Len - 1; Name_Len := Name_Len - 1;
declare declare
Parent_Name : constant Name_Id := Name_Find; Parent_Name : constant Name_Id := Name_Find;
Parent_Found : Boolean := False; Parent_Found : Boolean := False;
Parent_Node : Project_Node_Id := Empty_Node; Parent_Node : Project_Node_Id := Empty_Node;
With_Clause : Project_Node_Id := With_Clause : Project_Node_Id :=
First_With_Clause_Of (Project, In_Tree); First_With_Clause_Of (Project, In_Tree);
Imp_Proj_Name : Name_Id; Imp_Proj_Name : Name_Id;
begin begin
...@@ -1670,9 +1672,7 @@ package body Prj.Part is ...@@ -1670,9 +1672,7 @@ package body Prj.Part is
Imported_Loop : Imported_Loop :
while not Parent_Found and then Present (With_Clause) loop while not Parent_Found and then Present (With_Clause) loop
Parent_Node := Project_Node_Of (With_Clause, In_Tree); Parent_Node := Project_Node_Of (With_Clause, In_Tree);
Extension_Loop : while Present (Parent_Node) loop
Extension_Loop :
while Present (Parent_Node) loop
Imp_Proj_Name := Name_Of (Parent_Node, In_Tree); Imp_Proj_Name := Name_Of (Parent_Node, In_Tree);
Parent_Found := Imp_Proj_Name = Parent_Name; Parent_Found := Imp_Proj_Name = Parent_Name;
exit Imported_Loop when Parent_Found; exit Imported_Loop when Parent_Found;
......
...@@ -61,7 +61,7 @@ package Prj.PP is ...@@ -61,7 +61,7 @@ package Prj.PP is
-- Output a project file, using either the default output routines, or the -- Output a project file, using either the default output routines, or the
-- ones specified by W_Char, W_Eol and W_Str. -- ones specified by W_Char, W_Eol and W_Str.
-- --
-- Increment is the number of spaces for each indentation level. -- Increment is the number of spaces for each indentation level
-- --
-- W_Char, W_Eol and W_Str can be used to change the default output -- W_Char, W_Eol and W_Str can be used to change the default output
-- procedures. The default values force the output to Standard_Output. -- procedures. The default values force the output to Standard_Output.
...@@ -82,7 +82,7 @@ package Prj.PP is ...@@ -82,7 +82,7 @@ package Prj.PP is
-- Id is used to compute the display name of the project including its -- Id is used to compute the display name of the project including its
-- proper casing. -- proper casing.
-- --
-- Max_Line_Length is the maximum line length in the project file. -- Max_Line_Length is the maximum line length in the project file
private private
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment