Commit 72348e26 by Arnaud Charlet

[multiple changes]

2012-01-10  Bob Duff  <duff@adacore.com>

	* sem_intr.adb (Check_Shift): Use RM_Size instead of Esize, when
	checking that the 'Size is correct. If the type is "mod 2**12",
	for example, it's illegal, but Esize is the 'Object_Size, which
	will be something like 16 or 32, so the error ('Size = 12) was
	not detected.
	* gnat_rm.texi: Improve documentation of shift
	and rotate intrinsics.

2012-01-10  Pascal Obry  <obry@adacore.com>

	* prj.adb (For_Every_Project_Imported): Fix
	implementation to make sure we return each project only once
	for aggragte libraries. It is fine to return a project twice for
	aggregate projects, this was the case as a Project_Id is different
	in each project tree. The new implementation use a table based on
	the project name to ensure proper detection of duplicate project
	in aggregate library. A new context is then created to continue
	retrurning duplicate project for aggregate libraries.

From-SVN: r183059
parent cba300dd
2012-01-10 Bob Duff <duff@adacore.com>
* sem_intr.adb (Check_Shift): Use RM_Size instead of Esize, when
checking that the 'Size is correct. If the type is "mod 2**12",
for example, it's illegal, but Esize is the 'Object_Size, which
will be something like 16 or 32, so the error ('Size = 12) was
not detected.
* gnat_rm.texi: Improve documentation of shift
and rotate intrinsics.
2012-01-10 Pascal Obry <obry@adacore.com>
* prj.adb (For_Every_Project_Imported): Fix
implementation to make sure we return each project only once
for aggragte libraries. It is fine to return a project twice for
aggregate projects, this was the case as a Project_Id is different
in each project tree. The new implementation use a table based on
the project name to ensure proper detection of duplicate project
in aggregate library. A new context is then created to continue
retrurning duplicate project for aggregate libraries.
2012-01-09 Eric Botcazou <ebotcazou@adacore.com> 2012-01-09 Eric Botcazou <ebotcazou@adacore.com>
* gcc-interface/trans.c (call_to_gnu): Create the temporary for the * gcc-interface/trans.c (call_to_gnu): Create the temporary for the
......
...@@ -10385,11 +10385,7 @@ There are no restrictions on pragma @code{Restrictions}. ...@@ -10385,11 +10385,7 @@ There are no restrictions on pragma @code{Restrictions}.
* Exception_Name:: * Exception_Name::
* File:: * File::
* Line:: * Line::
* Rotate_Left:: * Shifts and Rotates::
* Rotate_Right::
* Shift_Left::
* Shift_Right::
* Shift_Right_Arithmetic::
* Source_Location:: * Source_Location::
@end menu @end menu
...@@ -10506,61 +10502,35 @@ application program should simply call the function ...@@ -10506,61 +10502,35 @@ application program should simply call the function
@code{GNAT.Source_Info.Line} to obtain the number of the current @code{GNAT.Source_Info.Line} to obtain the number of the current
source line. source line.
@node Rotate_Left @node Shifts and Rotates
@section Rotate_Left @section Shifts and Rotates
@cindex Shift_Left
@cindex Shift_Right
@cindex Shift_Right_Arithmetic
@cindex Rotate_Left @cindex Rotate_Left
@cindex Rotate_Right
@noindent @noindent
In standard Ada, the @code{Rotate_Left} function is available only In standard Ada, the shift and rotate functions are available only
for the predefined modular types in package @code{Interfaces}. However, in for the predefined modular types in package @code{Interfaces}. However, in
GNAT it is possible to define a Rotate_Left function for a user GNAT it is possible to define these functions for any integer
defined modular type or any signed integer type as in this example: type (signed or modular), as in this example:
@smallexample @c ada @smallexample @c ada
function Shift_Left function Shift_Left
(Value : My_Modular_Type; (Value : T;
Amount : Natural) Amount : Natural)
return My_Modular_Type; return T;
@end smallexample @end smallexample
@noindent @noindent
The requirements are that the profile be exactly as in the example The function name must be one of
above. The only modifications allowed are in the formal parameter Shift_Left, Shift_Right, Shift_Right_Arithmetic, Rotate_Left, or
names, and in the type of @code{Value} and the return type, which Rotate_Right. T must be an integer type. T'Size must be
must be the same, and must be either a signed integer type, or 8, 16, 32 or 64 bits; if T is modular, the modulus
a modular integer type with a binary modulus, and the size must must be 2**8, 2**16, 2**32 or 2**64.
be 8. 16, 32 or 64 bits. The result type must be the same as the type of @code{Value}.
The shift amount must be Natural.
@node Rotate_Right The formal parameter names can be anything.
@section Rotate_Right
@cindex Rotate_Right
@noindent
A @code{Rotate_Right} function can be defined for any user defined
binary modular integer type, or signed integer type, as described
above for @code{Rotate_Left}.
@node Shift_Left
@section Shift_Left
@cindex Shift_Left
@noindent
A @code{Shift_Left} function can be defined for any user defined
binary modular integer type, or signed integer type, as described
above for @code{Rotate_Left}.
@node Shift_Right
@section Shift_Right
@cindex Shift_Right
@noindent
A @code{Shift_Right} function can be defined for any user defined
binary modular integer type, or signed integer type, as described
above for @code{Rotate_Left}.
@node Shift_Right_Arithmetic
@section Shift_Right_Arithmetic
@cindex Shift_Right_Arithmetic
@noindent
A @code{Shift_Right_Arithmetic} function can be defined for any user
defined binary modular integer type, or signed integer type, as described
above for @code{Rotate_Left}.
@node Source_Location @node Source_Location
@section Source_Location @section Source_Location
......
...@@ -34,6 +34,7 @@ with Snames; use Snames; ...@@ -34,6 +34,7 @@ with Snames; use Snames;
with Uintp; use Uintp; with Uintp; use Uintp;
with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Containers.Ordered_Sets;
with Ada.Unchecked_Deallocation; with Ada.Unchecked_Deallocation;
with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Case_Util; use GNAT.Case_Util;
...@@ -523,101 +524,128 @@ package body Prj is ...@@ -523,101 +524,128 @@ package body Prj is
Include_Aggregated : Boolean := True; Include_Aggregated : Boolean := True;
Imported_First : Boolean := False) Imported_First : Boolean := False)
is is
use Project_Boolean_Htable; use Project_Boolean_Htable;
Seen : Project_Boolean_Htable.Instance := Project_Boolean_Htable.Nil;
procedure Recursive_Check procedure Recursive_Check_Context
(Project : Project_Id; (Project : Project_Id;
Tree : Project_Tree_Ref; Tree : Project_Tree_Ref;
In_Aggregate_Lib : Boolean); In_Aggregate_Lib : Boolean);
-- Check if a project has already been seen. If not seen, mark it -- Recursively handle the project tree creating a new context for
-- as Seen, Call Action, and check all its imported and aggregated -- keeping track about already handled projects.
-- projects.
--------------------- -----------------------------
-- Recursive_Check -- -- Recursive_Check_Context --
--------------------- -----------------------------
procedure Recursive_Check procedure Recursive_Check_Context
(Project : Project_Id; (Project : Project_Id;
Tree : Project_Tree_Ref; Tree : Project_Tree_Ref;
In_Aggregate_Lib : Boolean) In_Aggregate_Lib : Boolean)
is is
List : Project_List; package Name_Id_Set is
T : Project_Tree_Ref; new Ada.Containers.Ordered_Sets (Element_Type => Name_Id);
begin Seen_Name : Name_Id_Set.Set;
if not Get (Seen, Project) then -- This set is needed to ensure that we do not haandle the same
-- project twice in the context of aggregate libraries.
-- Even if a project is aggregated multiple times, we will only procedure Recursive_Check
-- return it once. (Project : Project_Id;
Tree : Project_Tree_Ref;
In_Aggregate_Lib : Boolean);
-- Check if project has already been seen. If not, mark it as Seen,
-- Call Action, and check all its imported and aggregated projects.
Set (Seen, Project, True); ---------------------
-- Recursive_Check --
---------------------
if not Imported_First then procedure Recursive_Check
Action (Project, Tree, In_Aggregate_Lib, With_State); (Project : Project_Id;
end if; Tree : Project_Tree_Ref;
In_Aggregate_Lib : Boolean)
is
List : Project_List;
T : Project_Tree_Ref;
begin
if not Seen_Name.Contains (Project.Name) then
-- Visit all extended projects -- Even if a project is aggregated multiple times in an
-- aggregated library, we will only return it once.
if Project.Extends /= No_Project then Seen_Name.Include (Project.Name);
Recursive_Check (Project.Extends, Tree, In_Aggregate_Lib);
end if;
-- Visit all imported projects if needed. This is not needed if not Imported_First then
-- for an aggregate library as imported libraries are just Action (Project, Tree, In_Aggregate_Lib, With_State);
-- there for dependency support. end if;
-- Visit all extended projects
if Project.Extends /= No_Project then
Recursive_Check (Project.Extends, Tree, In_Aggregate_Lib);
end if;
-- Visit all imported projects
if Project.Qualifier /= Aggregate_Library
or else not Include_Aggregated
then
List := Project.Imported_Projects; List := Project.Imported_Projects;
while List /= null loop while List /= null loop
Recursive_Check (List.Project, Tree, In_Aggregate_Lib); Recursive_Check (List.Project, Tree, In_Aggregate_Lib);
List := List.Next; List := List.Next;
end loop; end loop;
end if;
-- Visit all aggregated projects -- Visit all aggregated projects
if Include_Aggregated if Include_Aggregated
and then Project.Qualifier in Aggregate_Project and then Project.Qualifier in Aggregate_Project
then then
declare declare
Agg : Aggregated_Project_List; Agg : Aggregated_Project_List;
begin
Agg := Project.Aggregated_Projects; begin
while Agg /= null loop Agg := Project.Aggregated_Projects;
pragma Assert (Agg.Project /= No_Project); while Agg /= null loop
pragma Assert (Agg.Project /= No_Project);
-- For aggregated libraries, the tree must be the one
-- of the aggregate library. -- For aggregated libraries, the tree must be the one
-- of the aggregate library.
if Project.Qualifier = Aggregate_Library then
T := Tree; if Project.Qualifier = Aggregate_Library then
else T := Tree;
T := Agg.Tree; Recursive_Check (Agg.Project, T, True);
end if;
else
Recursive_Check T := Agg.Tree;
(Agg.Project, T, Project.Qualifier = Aggregate_Library);
Agg := Agg.Next; -- Use a new context as we want to returns the same
end loop; -- project in different project tree for aggregated
end; -- projects.
end if;
if Imported_First then Recursive_Check_Context (Agg.Project, T, False);
Action (Project, Tree, In_Aggregate_Lib, With_State); end if;
Agg := Agg.Next;
end loop;
end;
end if;
if Imported_First then
Action (Project, Tree, In_Aggregate_Lib, With_State);
end if;
end if; end if;
end if; end Recursive_Check;
end Recursive_Check;
-- Start of processing for Recursive_Check_Context
begin
Recursive_Check (Project, Tree, In_Aggregate_Lib);
end Recursive_Check_Context;
-- Start of processing for For_Every_Project_Imported -- Start of processing for For_Every_Project_Imported
begin begin
Recursive_Check (Project => By, Tree => Tree, In_Aggregate_Lib => False); Recursive_Check_Context
Reset (Seen); (Project => By, Tree => Tree, In_Aggregate_Lib => False);
end For_Every_Project_Imported; end For_Every_Project_Imported;
----------------- -----------------
......
...@@ -455,12 +455,14 @@ package body Sem_Intr is ...@@ -455,12 +455,14 @@ package body Sem_Intr is
return; return;
end if; end if;
Size := UI_To_Int (Esize (Typ1)); -- type'Size (not 'Object_Size!) must be one of the allowed values
if Size /= 8 Size := UI_To_Int (RM_Size (Typ1));
and then Size /= 16
and then Size /= 32 if Size /= 8 and then
and then Size /= 64 Size /= 16 and then
Size /= 32 and then
Size /= 64
then then
Errint Errint
("first argument for shift must have size 8, 16, 32 or 64", ("first argument for shift must have size 8, 16, 32 or 64",
...@@ -469,8 +471,7 @@ package body Sem_Intr is ...@@ -469,8 +471,7 @@ package body Sem_Intr is
elsif Non_Binary_Modulus (Typ1) then elsif Non_Binary_Modulus (Typ1) then
Errint Errint
("shifts not allowed for non-binary modular types", ("shifts not allowed for non-binary modular types", Ptyp1, N);
Ptyp1, N);
elsif Etype (Arg1) /= Etype (E) then elsif Etype (Arg1) /= Etype (E) then
Errint Errint
......
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