Skip to content

R
riscv-gcc-1
Commit 3e2399ba by Arnaud Charlet
Options

[multiple changes] 

2010-06-18  Vincent Celier  <celier@adacore.com>

	* make.adb (Must_Compile): New Boolean global variable
	(Main_On_Command_Line): New Boolean global variable
	(Collect_Arguments_And_Compile): Do compile if Must_Compile is True,
	even when the project is externally built.
	(Start_Compile_If_Possible): Compile in -aL directories if
	Check_Readonly_Files is True. Do compile if Must_Compile is True, even
	when the project is externally built.
	(Gnatmake): Set Must_Compile and Check_Readonly_Files to True when
	invoked with -f -u and one or several mains on the command line.
	(Scan_Make_Arg): Set Main_On_Command_Line to True when at least one main
	is specified on the command line.

2010-06-18  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Build_Body_For_Inline): Handle extended_return_statements
	* exp_ch6.adb (Expand_Inlined_Call): when possible, inline a body
	containing extented_return statements.
	* exp_util.adb (Make_CW_Equivalent_Type): If the root type is already
	constrained, do not build subtype declaration.

From-SVN: r160962
parent c28408b7
Showing with 194 additions and 35 deletions
gcc/ada/ChangeLog
2010-06-18 Vincent Celier <celier@adacore.com>
* make.adb (Must_Compile): New Boolean global variable
(Main_On_Command_Line): New Boolean global variable
(Collect_Arguments_And_Compile): Do compile if Must_Compile is True,
even when the project is externally built.
(Start_Compile_If_Possible): Compile in -aL directories if
Check_Readonly_Files is True. Do compile if Must_Compile is True, even
when the project is externally built.
(Gnatmake): Set Must_Compile and Check_Readonly_Files to True when
invoked with -f -u and one or several mains on the command line.
(Scan_Make_Arg): Set Main_On_Command_Line to True when at least one main
is specified on the command line.
2010-06-18 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Build_Body_For_Inline): Handle extended_return_statements
* exp_ch6.adb (Expand_Inlined_Call): when possible, inline a body
containing extented_return statements.
* exp_util.adb (Make_CW_Equivalent_Type): If the root type is already
constrained, do not build subtype declaration.
2010-06-18 Robert Dewar <dewar@adacore.com> 2010-06-18 Robert Dewar <dewar@adacore.com>
* sem_res.adb (Analyze_Indexed_Component, Analyze_Selected_Component): * sem_res.adb (Analyze_Indexed_Component, Analyze_Selected_Component):
......
gcc/ada/exp_ch6.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -3297,6 +3297,9 @@ package body Exp_Ch6 is ...@@ -3297,6 +3297,9 @@ package body Exp_Ch6 is
Temp : Entity_Id; Temp : Entity_Id;
Temp_Typ : Entity_Id; Temp_Typ : Entity_Id;
Return_Object : Entity_Id := Empty;
-- Entity in declaration in an extended_return_statement
Is_Unc : constant Boolean := Is_Unc : constant Boolean :=
Is_Array_Type (Etype (Subp)) Is_Array_Type (Etype (Subp))
and then not Is_Constrained (Etype (Subp)); and then not Is_Constrained (Etype (Subp));
...@@ -3390,6 +3393,21 @@ package body Exp_Ch6 is ...@@ -3390,6 +3393,21 @@ package body Exp_Ch6 is
Rewrite (N, New_Copy (A)); Rewrite (N, New_Copy (A));
end if; end if;
end if; end if;
return Skip;
elsif Is_Entity_Name (N)
and then Chars (N) = Chars (Return_Object)
then
-- Occurrence within an extended return statement. The return
-- object is local to the body been inlined, and thus the generic
-- copy is not analyzed yet, so we match by name, and replace it
-- with target of call.
if Nkind (Targ) = N_Defining_Identifier then
Rewrite (N, New_Occurrence_Of (Targ, Loc));
else
Rewrite (N, New_Copy_Tree (Targ));
end if;
return Skip; return Skip;
...@@ -3397,8 +3415,7 @@ package body Exp_Ch6 is ...@@ -3397,8 +3415,7 @@ package body Exp_Ch6 is
if No (Expression (N)) then if No (Expression (N)) then
Make_Exit_Label; Make_Exit_Label;
Rewrite (N, Rewrite (N,
Make_Goto_Statement (Loc, Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
Name => New_Copy (Lab_Id)));
else else
if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
...@@ -3456,6 +3473,46 @@ package body Exp_Ch6 is ...@@ -3456,6 +3473,46 @@ package body Exp_Ch6 is
return OK; return OK;
elsif Nkind (N) = N_Extended_Return_Statement then
-- An extended return becomes a block whose first statement is
-- the assignment of the initial expression of the return object
-- to the target of the call itself.
declare
Return_Decl : constant Entity_Id :=
First (Return_Object_Declarations (N));
Assign : Node_Id;
begin
Return_Object := Defining_Identifier (Return_Decl);
if Present (Expression (Return_Decl)) then
if Nkind (Targ) = N_Defining_Identifier then
Assign :=
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Targ, Loc),
Expression => Expression (Return_Decl));
else
Assign :=
Make_Assignment_Statement (Loc,
Name => New_Copy (Targ),
Expression => Expression (Return_Decl));
end if;
Set_Assignment_OK (Name (Assign));
Prepend (Assign,
Statements (Handled_Statement_Sequence (N)));
end if;
Rewrite (N,
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Handled_Statement_Sequence (N)));
return OK;
end;
-- Remove pragma Unreferenced since it may refer to formals that -- Remove pragma Unreferenced since it may refer to formals that
-- are not visible in the inlined body, and in any case we will -- are not visible in the inlined body, and in any case we will
-- not be posting warnings on the inlined body so it is unneeded. -- not be posting warnings on the inlined body so it is unneeded.
...@@ -3866,6 +3923,11 @@ package body Exp_Ch6 is ...@@ -3866,6 +3923,11 @@ package body Exp_Ch6 is
then then
Targ := Name (Parent (N)); Targ := Name (Parent (N));
elsif Nkind (Parent (N)) = N_Object_Declaration
and then Is_Limited_Type (Etype (Subp))
then
Targ := Defining_Identifier (Parent (N));
else else
-- Replace call with temporary and create its declaration -- Replace call with temporary and create its declaration
......
gcc/ada/exp_util.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -3751,7 +3751,12 @@ package body Exp_Util is ...@@ -3751,7 +3751,12 @@ package body Exp_Util is
Sizexpr : Node_Id; Sizexpr : Node_Id;
begin begin
if not Has_Discriminants (Root_Typ) then -- If the root type is already constrained, there are no discriminants
-- in the expression.
if not Has_Discriminants (Root_Typ)
or else Is_Constrained (Root_Typ)
then
Constr_Root := Root_Typ; Constr_Root := Root_Typ;
else else
Constr_Root := Make_Temporary (Loc, 'R'); Constr_Root := Make_Temporary (Loc, 'R');
......
gcc/ada/make.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -202,6 +202,14 @@ package body Make is ...@@ -202,6 +202,14 @@ package body Make is
Unique_Compile_All_Projects : Boolean := False; Unique_Compile_All_Projects : Boolean := False;
-- Set to True if -U is used -- Set to True if -U is used
Must_Compile : Boolean := False;
-- True if gnatmake is invoked with -f -u and one or several mains on the
-- command line.
Main_On_Command_Line : Boolean := False;
-- True if gnatmake is invoked with one or several mains on the command
-- line.
RTS_Specified : String_Access := null; RTS_Specified : String_Access := null;
-- Used to detect multiple --RTS= switches -- Used to detect multiple --RTS= switches
...@@ -2243,12 +2251,14 @@ package body Make is ...@@ -2243,12 +2251,14 @@ package body Make is
if Arguments_Project = No_Project then if Arguments_Project = No_Project then
Add_Arguments (The_Saved_Gcc_Switches.all); Add_Arguments (The_Saved_Gcc_Switches.all);
elsif not Arguments_Project.Externally_Built then elsif not Arguments_Project.Externally_Built
or else Must_Compile
then
-- We get the project directory for the relative path -- We get the project directory for the relative path
-- switches and arguments. -- switches and arguments.
Arguments_Project := Ultimate_Extending_Project_Of Arguments_Project :=
(Arguments_Project); Ultimate_Extending_Project_Of (Arguments_Project);
-- If building a dynamic or relocatable library, compile with -- If building a dynamic or relocatable library, compile with
-- PIC option, if it exists. -- PIC option, if it exists.
...@@ -2258,7 +2268,6 @@ package body Make is ...@@ -2258,7 +2268,6 @@ package body Make is
then then
declare declare
PIC : constant String := MLib.Tgt.PIC_Option; PIC : constant String := MLib.Tgt.PIC_Option;
begin begin
if PIC /= "" then if PIC /= "" then
Add_Arguments ((1 => new String'(PIC))); Add_Arguments ((1 => new String'(PIC)));
...@@ -2726,7 +2735,9 @@ package body Make is ...@@ -2726,7 +2735,9 @@ package body Make is
-- check for an eventual library project, and use the full path. -- check for an eventual library project, and use the full path.
if Arguments_Project /= No_Project then if Arguments_Project /= No_Project then
if not Arguments_Project.Externally_Built then if not Arguments_Project.Externally_Built
or else Must_Compile
then
Prj.Env.Set_Ada_Paths Prj.Env.Set_Ada_Paths
(Arguments_Project, (Arguments_Project,
Project_Tree, Project_Tree,
...@@ -2742,7 +2753,7 @@ package body Make is ...@@ -2742,7 +2753,7 @@ package body Make is
begin begin
if Prj.Library if Prj.Library
and then not Prj.Externally_Built and then (not Prj.Externally_Built or else Must_Compile)
and then not Prj.Need_To_Build_Lib and then not Prj.Need_To_Build_Lib
then then
-- Add to the Q all sources of the project that have -- Add to the Q all sources of the project that have
...@@ -3272,8 +3283,9 @@ package body Make is ...@@ -3272,8 +3283,9 @@ package body Make is
Executable_Obsolete := True; Executable_Obsolete := True;
end if; end if;
In_Lib_Dir := Full_Lib_File /= No_File In_Lib_Dir := not Check_Readonly_Files
and then In_Ada_Lib_Dir (Full_Lib_File); and then Full_Lib_File /= No_File
and then In_Ada_Lib_Dir (Full_Lib_File);
-- Since the following requires a system call, we precompute it -- Since the following requires a system call, we precompute it
-- when needed. -- when needed.
...@@ -3350,6 +3362,7 @@ package body Make is ...@@ -3350,6 +3362,7 @@ package body Make is
if Arguments_Project = No_Project if Arguments_Project = No_Project
or else not Arguments_Project.Externally_Built or else not Arguments_Project.Externally_Built
or else Must_Compile
then then
-- Don't waste any time if we have to recompile anyway -- Don't waste any time if we have to recompile anyway
...@@ -4739,13 +4752,6 @@ package body Make is ...@@ -4739,13 +4752,6 @@ package body Make is
Display_Version ("GNATMAKE", "1995"); Display_Version ("GNATMAKE", "1995");
end if; end if;
if Main_Project /= No_Project
and then Main_Project.Externally_Built
then
Make_Failed
("nothing to do for a main project that is externally built");
end if;
if Osint.Number_Of_Files = 0 then if Osint.Number_Of_Files = 0 then
if Main_Project /= No_Project if Main_Project /= No_Project
and then Main_Project.Library and then Main_Project.Library
...@@ -5182,6 +5188,26 @@ package body Make is ...@@ -5182,6 +5188,26 @@ package body Make is
end; end;
end if; end if;
-- The combination of -f -u and one or several mains on the command line
-- implies -a.
if Force_Compilations
and then Unique_Compile
and then not Unique_Compile_All_Projects
and then Main_On_Command_Line
then
Check_Readonly_Files := True;
Must_Compile := True;
end if;
if Main_Project /= No_Project
and then not Must_Compile
and then Main_Project.Externally_Built
then
Make_Failed
("nothing to do for a main project that is externally built");
end if;
-- Get the target parameters, which are only needed for a couple of -- Get the target parameters, which are only needed for a couple of
-- cases in gnatmake. Protect against an exception, such as the case of -- cases in gnatmake. Protect against an exception, such as the case of
-- system.ads missing from the library, and fail gracefully. -- system.ads missing from the library, and fail gracefully.
...@@ -8219,6 +8245,10 @@ package body Make is ...@@ -8219,6 +8245,10 @@ package body Make is
-- If not a switch it must be a file name -- If not a switch it must be a file name
else else
if And_Save then
Main_On_Command_Line := True;
end if;
Add_File (Argv); Add_File (Argv);
Mains.Add_Main (Argv); Mains.Add_Main (Argv);
end if; end if;
......
gcc/ada/sem_ch6.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -3103,6 +3103,15 @@ package body Sem_Ch6 is ...@@ -3103,6 +3103,15 @@ package body Sem_Ch6 is
and then Has_Excluded_Statement (Statements (S)) and then Has_Excluded_Statement (Statements (S))
then then
return True; return True;
elsif Nkind (S) = N_Extended_Return_Statement then
if Has_Excluded_Statement
(Statements (Handled_Statement_Sequence (S)))
or else Present
(Exception_Handlers (Handled_Statement_Sequence (S)))
then
return True;
end if;
end if; end if;
Next (S); Next (S);
...@@ -3170,12 +3179,33 @@ package body Sem_Ch6 is ...@@ -3170,12 +3179,33 @@ package body Sem_Ch6 is
return Abandon; return Abandon;
end if; end if;
-- A return statement within an extended return is a noop
-- after inlining.
elsif No (Expression (N))
and then Nkind (Parent (Parent (N))) =
N_Extended_Return_Statement
then
return OK;
else else
-- Expression has wrong form -- Expression has wrong form
return Abandon; return Abandon;
end if; end if;
-- We can only inline a build-in-place function if
-- it has a single extended return.
elsif Nkind (N) = N_Extended_Return_Statement then
if No (Return_Statement) then
Return_Statement := N;
return OK;
else
return Abandon;
end if;
else else
return OK; return OK;
end if; end if;
...@@ -3186,11 +3216,18 @@ package body Sem_Ch6 is ...@@ -3186,11 +3216,18 @@ package body Sem_Ch6 is
-- Start of processing for Has_Single_Return -- Start of processing for Has_Single_Return
begin begin
return Check_All_Returns (N) = OK if Check_All_Returns (N) /= OK then
and then Present (Declarations (N)) return False;
and then Present (First (Declarations (N)))
and then Chars (Expression (Return_Statement)) = elsif Nkind (Return_Statement) = N_Extended_Return_Statement then
Chars (Defining_Identifier (First (Declarations (N)))); return True;
else
return Present (Declarations (N))
and then Present (First (Declarations (N)))
and then Chars (Expression (Return_Statement)) =
Chars (Defining_Identifier (First (Declarations (N))));
end if;
end Has_Single_Return; end Has_Single_Return;
-------------------- --------------------
...@@ -4444,10 +4481,10 @@ package body Sem_Ch6 is ...@@ -4444,10 +4481,10 @@ package body Sem_Ch6 is
Error_Msg_Sloc := Sloc (Overridden_Subp); Error_Msg_Sloc := Sloc (Overridden_Subp);
if Ekind (Subp) = E_Entry then if Ekind (Subp) = E_Entry then
Error_Msg_NE Error_Msg_NE -- CODEFIX???
("entry & overrides inherited operation #", Spec, Subp); ("entry & overrides inherited operation #", Spec, Subp);
else else
Error_Msg_NE Error_Msg_NE -- CODEFIX???
("subprogram & overrides inherited operation #", Spec, Subp); ("subprogram & overrides inherited operation #", Spec, Subp);
end if; end if;
...@@ -4498,12 +4535,12 @@ package body Sem_Ch6 is ...@@ -4498,12 +4535,12 @@ package body Sem_Ch6 is
if not Is_Primitive if not Is_Primitive
and then Ekind (Scope (Subp)) /= E_Protected_Type and then Ekind (Scope (Subp)) /= E_Protected_Type
then then
Error_Msg_N Error_Msg_N -- CODEFIX???
("overriding indicator only allowed " ("overriding indicator only allowed "
& "if subprogram is primitive", Subp); & "if subprogram is primitive", Subp);
elsif Can_Override then elsif Can_Override then
Error_Msg_NE Error_Msg_NE -- CODEFIX???
("subprogram & overrides predefined operator ", ("subprogram & overrides predefined operator ",
Spec, Subp); Spec, Subp);
end if; end if;
...@@ -4513,7 +4550,8 @@ package body Sem_Ch6 is ...@@ -4513,7 +4550,8 @@ package body Sem_Ch6 is
Set_Is_Overriding_Operation (Subp); Set_Is_Overriding_Operation (Subp);
elsif not Can_Override then elsif not Can_Override then
Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); Error_Msg_NE -- CODEFIX???
("subprogram & is not overriding", Spec, Subp);
end if; end if;
elsif not Error_Posted (Subp) elsif not Error_Posted (Subp)
...@@ -4542,9 +4580,11 @@ package body Sem_Ch6 is ...@@ -4542,9 +4580,11 @@ package body Sem_Ch6 is
elsif Must_Override (Spec) then elsif Must_Override (Spec) then
if Ekind (Subp) = E_Entry then if Ekind (Subp) = E_Entry then
Error_Msg_NE ("entry & is not overriding", Spec, Subp); Error_Msg_NE -- CODEFIX???
("entry & is not overriding", Spec, Subp);
else else
Error_Msg_NE ("subprogram & is not overriding", Spec, Subp); Error_Msg_NE -- CODEFIX???
("subprogram & is not overriding", Spec, Subp);
end if; end if;
-- If the operation is marked "not overriding" and it's not primitive -- If the operation is marked "not overriding" and it's not primitive
...@@ -4557,7 +4597,7 @@ package body Sem_Ch6 is ...@@ -4557,7 +4597,7 @@ package body Sem_Ch6 is
and then Ekind (Subp) /= E_Entry and then Ekind (Subp) /= E_Entry
and then Ekind (Scope (Subp)) /= E_Protected_Type and then Ekind (Scope (Subp)) /= E_Protected_Type
then then
Error_Msg_N Error_Msg_N -- CODEFIX???
("overriding indicator only allowed if subprogram is primitive", ("overriding indicator only allowed if subprogram is primitive",
Subp); Subp);
return; return;
......
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