Skip to content

R
riscv-gcc-1
Commit 0df5ae93 by Arnaud Charlet
Options

[multiple changes] 

2014-05-21  Robert Dewar  <dewar@adacore.com>

	* sem_ch13.adb (Analyze_Aspect_Specifications):
	Insert_Delayed_Pragma is now used for the case of Attach_Handler.
	* sem_prag.adb: Minor comment improvements.

2014-05-21  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch12.adb (Install_Body): When checking whether freezing of
	instantiation must be delayed, verify that the common enclosing
	subprogram to generic and instance is in fact an overloadable
	entity.

2014-05-21  Vincent Celier  <celier@adacore.com>

	* makeutl.adb (Mains.Complete_Mains.Do_Complete): Look for all
	mains with the same name and fail if there is more than one.
	* prj.ads, prj.adb (Find_All_Sources): New function

From-SVN: r210702
parent 9db78a42
Showing with 229 additions and 33 deletions
gcc/ada/ChangeLog
2014-05-21 Robert Dewar <dewar@adacore.com> 2014-05-21 Robert Dewar <dewar@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications):
Insert_Delayed_Pragma is now used for the case of Attach_Handler.
* sem_prag.adb: Minor comment improvements.
2014-05-21 Ed Schonberg <schonberg@adacore.com>
* sem_ch12.adb (Install_Body): When checking whether freezing of
instantiation must be delayed, verify that the common enclosing
subprogram to generic and instance is in fact an overloadable
entity.
2014-05-21 Vincent Celier <celier@adacore.com>
* makeutl.adb (Mains.Complete_Mains.Do_Complete): Look for all
mains with the same name and fail if there is more than one.
* prj.ads, prj.adb (Find_All_Sources): New function
2014-05-21 Robert Dewar <dewar@adacore.com>
* sem_ch13.adb: Minor reformatting. * sem_ch13.adb: Minor reformatting.
* lib-xref-spark_specific.adb, sem_util.adb: Minor reformatting. * lib-xref-spark_specific.adb, sem_util.adb: Minor reformatting.
* sem_prag.adb: Minor error message improvement. * sem_prag.adb: Minor error message improvement.
......
gcc/ada/makeutl.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2014, 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- --
...@@ -1732,7 +1732,7 @@ package body Makeutl is ...@@ -1732,7 +1732,7 @@ package body Makeutl is
-- no need to process them in turn. -- no need to process them in turn.
J := Names.Last; J := Names.Last;
loop Main_Loop : loop
declare declare
File : Main_Info := Names.Table (J); File : Main_Info := Names.Table (J);
Main_Id : File_Name_Type := File.File; Main_Id : File_Name_Type := File.File;
...@@ -1798,16 +1798,53 @@ package body Makeutl is ...@@ -1798,16 +1798,53 @@ package body Makeutl is
-- search for the base name though, and if needed -- search for the base name though, and if needed
-- check later that we found the correct file. -- check later that we found the correct file.
Source := Find_Source declare
(In_Tree => File.Tree, Sources : constant Source_Ids :=
Project => File.Project, Find_All_Sources
Base_Name => Main_Id, (In_Tree => File.Tree,
Index => File.Index, Project => File.Project,
In_Imported_Only => True); Base_Name => Main_Id,
Index => File.Index,
In_Imported_Only => True);
begin
if Is_Absolute then
for J in Sources'Range loop
if File_Name_Type (Sources (J).Path.Name) =
File.File
then
Source := Sources (J);
exit;
end if;
end loop;
elsif Sources'Length > 1 then
-- This is only allowed if the units are from
-- the same multi-unit source file.
Source := Sources (1);
for J in 2 .. Sources'Last loop
if Sources (J).Path /= Source.Path
or else Sources (J).Index = Source.Index
then
Error_Msg_File_1 := Main_Id;
Prj.Err.Error_Msg
(Flags, "several main sources {",
No_Location, File.Project);
exit Main_Loop;
end if;
end loop;
elsif Sources'Length = 1 then
Source := Sources (Sources'First);
end if;
end;
if Source = No_Source then if Source = No_Source then
Source := Find_File_Add_Extension Source := Find_File_Add_Extension
(File.Tree, Get_Name_String (Main_Id)); (File.Tree, Get_Name_String (Main_Id));
end if; end if;
if Is_Absolute if Is_Absolute
...@@ -1883,8 +1920,8 @@ package body Makeutl is ...@@ -1883,8 +1920,8 @@ package body Makeutl is
end; end;
J := J - 1; J := J - 1;
exit when J < Names.First; exit Main_Loop when J < Names.First;
end loop; end loop Main_Loop;
end if; end if;
if Total_Errors_Detected > 0 then if Total_Errors_Detected > 0 then
......
gcc/ada/prj.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- -- Copyright (C) 2001-2014, 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- --
...@@ -889,6 +889,104 @@ package body Prj is ...@@ -889,6 +889,104 @@ package body Prj is
return Result; return Result;
end Find_Source; end Find_Source;
----------------------
-- Find_All_Sources --
----------------------
function Find_All_Sources
(In_Tree : Project_Tree_Ref;
Project : Project_Id;
In_Imported_Only : Boolean := False;
In_Extended_Only : Boolean := False;
Base_Name : File_Name_Type;
Index : Int := 0) return Source_Ids
is
Result : Source_Ids (1 .. 1_000);
Last : Natural := 0;
type Empty_State is null record;
No_State : Empty_State;
procedure Look_For_Sources
(Proj : Project_Id;
Tree : Project_Tree_Ref;
State : in out Empty_State);
-- Look for Base_Name in the sources of Proj
----------------------
-- Look_For_Sources --
----------------------
procedure Look_For_Sources
(Proj : Project_Id;
Tree : Project_Tree_Ref;
State : in out Empty_State)
is
Iterator : Source_Iterator;
Src : Source_Id;
begin
State := No_State;
Iterator := For_Each_Source (In_Tree => Tree, Project => Proj);
while Element (Iterator) /= No_Source loop
if Element (Iterator).File = Base_Name
and then (Index = 0
or else
(Element (Iterator).Unit /= No_Unit_Index
and then
Element (Iterator).Index = Index))
then
Src := Element (Iterator);
-- If the source has been excluded, continue looking. We will
-- get the excluded source only if there is no other source
-- with the same base name that is not locally removed.
if not Element (Iterator).Locally_Removed then
Last := Last + 1;
Result (Last) := Src;
end if;
end if;
Next (Iterator);
end loop;
end Look_For_Sources;
procedure For_Imported_Projects is new For_Every_Project_Imported
(State => Empty_State, Action => Look_For_Sources);
Proj : Project_Id;
-- Start of processing for Find_All_Sources
begin
if In_Extended_Only then
Proj := Project;
while Proj /= No_Project loop
Look_For_Sources (Proj, In_Tree, No_State);
exit when Last > 0;
Proj := Proj.Extends;
end loop;
elsif In_Imported_Only then
Look_For_Sources (Project, In_Tree, No_State);
if Last = 0 then
For_Imported_Projects
(By => Project,
Tree => In_Tree,
Include_Aggregated => False,
With_State => No_State);
end if;
else
Look_For_Sources (No_Project, In_Tree, No_State);
end if;
return Result (1 .. Last);
end Find_All_Sources;
---------- ----------
-- Hash -- -- Hash --
---------- ----------
...@@ -896,6 +994,10 @@ package body Prj is ...@@ -896,6 +994,10 @@ package body Prj is
function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num); function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num);
-- Used in implementation of other functions Hash below -- Used in implementation of other functions Hash below
----------
-- Hash --
----------
function Hash (Name : File_Name_Type) return Header_Num is function Hash (Name : File_Name_Type) return Header_Num is
begin begin
return Hash (Get_Name_String (Name)); return Hash (Get_Name_String (Name));
......
gcc/ada/prj.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- -- Copyright (C) 2001-2014, 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- --
...@@ -1525,6 +1525,24 @@ package Prj is ...@@ -1525,6 +1525,24 @@ package Prj is
-- Else it searches in the whole tree. -- Else it searches in the whole tree.
-- If Index is specified, this only search for a source with that index. -- If Index is specified, this only search for a source with that index.
type Source_Ids is array (Positive range <>) of Source_Id;
No_Sources : constant Source_Ids := (1 .. 0 => No_Source);
function Find_All_Sources
(In_Tree : Project_Tree_Ref;
Project : Project_Id;
In_Imported_Only : Boolean := False;
In_Extended_Only : Boolean := False;
Base_Name : File_Name_Type;
Index : Int := 0) return Source_Ids;
-- Find all source files with the given name.
-- If In_Extended_Only is True, it will search in project and the project
-- it extends, but not in the imported projects.
-- Elsif In_Imported_Only is True, it will search in project and the
-- projects it imports, but not in the others or in aggregated projects.
-- Else it searches in the whole tree.
-- If Index is specified, this only search for sources with that index.
----------------------- -----------------------
-- Project_Tree_Data -- -- Project_Tree_Data --
----------------------- -----------------------
......
gcc/ada/sem_ch12.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2014, 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- --
...@@ -3588,7 +3588,6 @@ package body Sem_Ch12 is ...@@ -3588,7 +3588,6 @@ package body Sem_Ch12 is
Set_Instance_Env (Gen_Unit, Act_Decl_Id); Set_Instance_Env (Gen_Unit, Act_Decl_Id);
Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name); Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name);
Set_Is_Generic_Instance (Act_Decl_Id); Set_Is_Generic_Instance (Act_Decl_Id);
Set_Generic_Parent (Act_Spec, Gen_Unit); Set_Generic_Parent (Act_Spec, Gen_Unit);
-- References to the generic in its own declaration or its body are -- References to the generic in its own declaration or its body are
...@@ -8171,8 +8170,8 @@ package body Sem_Ch12 is ...@@ -8171,8 +8170,8 @@ package body Sem_Ch12 is
Must_Delay : Boolean; Must_Delay : Boolean;
function Enclosing_Subp (Id : Entity_Id) return Entity_Id; function In_Same_Enclosing_Subp return Boolean;
-- Find subprogram (if any) that encloses instance and/or generic body -- Check whether instance and generic body are within same subprogram.
function True_Sloc (N : Node_Id) return Source_Ptr; function True_Sloc (N : Node_Id) return Source_Ptr;
-- If the instance is nested inside a generic unit, the Sloc of the -- If the instance is nested inside a generic unit, the Sloc of the
...@@ -8182,23 +8181,39 @@ package body Sem_Ch12 is ...@@ -8182,23 +8181,39 @@ package body Sem_Ch12 is
-- origin of a node by finding the maximum sloc of any ancestor node. -- origin of a node by finding the maximum sloc of any ancestor node.
-- Why is this not equivalent to Top_Level_Location ??? -- Why is this not equivalent to Top_Level_Location ???
-------------------- ----------------------------
-- Enclosing_Subp -- -- In_Same_Enclosing_Subp --
-------------------- ----------------------------
function Enclosing_Subp (Id : Entity_Id) return Entity_Id is function In_Same_Enclosing_Subp return Boolean is
Scop : Entity_Id; Scop : Entity_Id;
Subp : Entity_Id;
begin begin
Scop := Scope (Id); Scop := Scope (Act_Id);
while Scop /= Standard_Standard while Scop /= Standard_Standard
and then not Is_Overloadable (Scop) and then not Is_Overloadable (Scop)
loop loop
Scop := Scope (Scop); Scop := Scope (Scop);
end loop; end loop;
return Scop; if Scop = Standard_Standard then
end Enclosing_Subp; return False;
else
Subp := Scop;
end if;
Scop := Scope (Gen_Id);
while Scop /= Standard_Standard loop
if Scop = Subp then
return True;
end if;
Scop := Scope (Scop);
end loop;
return False;
end In_Same_Enclosing_Subp;
--------------- ---------------
-- True_Sloc -- -- True_Sloc --
...@@ -8255,8 +8270,7 @@ package body Sem_Ch12 is ...@@ -8255,8 +8270,7 @@ package body Sem_Ch12 is
and then True_Sloc (N) < Sloc (Orig_Body))) and then True_Sloc (N) < Sloc (Orig_Body)))
and then Is_In_Main_Unit (Gen_Unit) and then Is_In_Main_Unit (Gen_Unit)
and then (Scope (Act_Id) = Scope (Gen_Id) and then (Scope (Act_Id) = Scope (Gen_Id)
or else or else In_Same_Enclosing_Subp));
Enclosing_Subp (Act_Id) = Enclosing_Subp (Gen_Id)));
-- If this is an early instantiation, the freeze node is placed after -- If this is an early instantiation, the freeze node is placed after
-- the generic body. Otherwise, if the generic appears in an instance, -- the generic body. Otherwise, if the generic appears in an instance,
......
gcc/ada/sem_ch13.adb
...@@ -1161,7 +1161,8 @@ package body Sem_Ch13 is ...@@ -1161,7 +1161,8 @@ package body Sem_Ch13 is
procedure Insert_Delayed_Pragma (Prag : Node_Id); procedure Insert_Delayed_Pragma (Prag : Node_Id);
-- Insert a postcondition-like pragma into the tree depending on the -- Insert a postcondition-like pragma into the tree depending on the
-- context. Prag must denote one of the following: Pre, Post, Depends, -- context. Prag must denote one of the following: Pre, Post, Depends,
-- Global or Contract_Cases. -- Global or Contract_Cases. This procedure is also used for the case
-- of Attach_Handler which has similar requirements for placement.
-------------------------------- --------------------------------
-- Decorate_Aspect_And_Pragma -- -- Decorate_Aspect_And_Pragma --
...@@ -1463,7 +1464,7 @@ package body Sem_Ch13 is ...@@ -1463,7 +1464,7 @@ package body Sem_Ch13 is
Check_Restriction_No_Specification_Of_Aspect (Aspect); Check_Restriction_No_Specification_Of_Aspect (Aspect);
-- Analyze this aspect (actual analysis is delayed till later) -- Mark aspect analyzed (actual analysis is delayed till later)
Set_Analyzed (Aspect); Set_Analyzed (Aspect);
Set_Entity (Aspect, E); Set_Entity (Aspect, E);
...@@ -1678,6 +1679,12 @@ package body Sem_Ch13 is ...@@ -1678,6 +1679,12 @@ package body Sem_Ch13 is
Expression => Relocate_Node (Expr))), Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Attach_Handler); Pragma_Name => Name_Attach_Handler);
-- We need to insert this pragma into the tree to get proper
-- processing and to look valid from a placement viewpoint.
Insert_Delayed_Pragma (Aitem);
goto Continue;
-- Dynamic_Predicate, Predicate, Static_Predicate -- Dynamic_Predicate, Predicate, Static_Predicate
when Aspect_Dynamic_Predicate | when Aspect_Dynamic_Predicate |
......
gcc/ada/sem_prag.adb
...@@ -4552,7 +4552,7 @@ package body Sem_Prag is ...@@ -4552,7 +4552,7 @@ package body Sem_Prag is
-- For pragma case (as opposed to access case), check placement. -- For pragma case (as opposed to access case), check placement.
-- We don't need to do that for aspects, because we have the -- We don't need to do that for aspects, because we have the
-- check that they are apply an appropriate procedure. -- check that they aspect applies an appropriate procedure.
if not From_Aspect_Specification (N) if not From_Aspect_Specification (N)
and then Parent (N) /= Protected_Definition (Parent (Proc_Scope)) and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
...@@ -6387,12 +6387,11 @@ package body Sem_Prag is ...@@ -6387,12 +6387,11 @@ package body Sem_Prag is
Set_Treat_As_Volatile (E); Set_Treat_As_Volatile (E);
else else
Error_Pragma_Arg Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
("inappropriate entity for pragma%", Arg1);
end if; end if;
-- The following check are only relevant when SPARK_Mode is on as -- The following check is only relevant when SPARK_Mode is on as
-- those are not a standard Ada legality rule. Pragma Volatile can -- this is not a standard Ada legality rule. Pragma Volatile can
-- only apply to a full type declaration or an object declaration -- only apply to a full type declaration or an object declaration
-- (SPARK RM C.6(1)). -- (SPARK RM C.6(1)).
......
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