mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 10:40:50 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2009-04-08  Robert Dewar  <dewar@adacore.com>

	* checks.adb (Enable_Overflow_Check): Do not enable if overflow checks
	suppressed.
	
	* exp_ch4.adb (Expand_Concatenate): Make sure checks are off for all
	resolution steps.

2009-04-08  Robert Dewar  <dewar@adacore.com>

	* sem_ch12.adb (Analyze_Package_Instantiation): Remove test for
	No_Local_Allocators restriction preventing local instantiation.

2009-04-08  Thomas Quinot  <quinot@adacore.com>

	* sem_eval.adb: Minor comment fix

2009-04-08  Thomas Quinot  <quinot@adacore.com>

	* g-socket.adb, g-socket.ads (GNAT.Sockets.Sockets_Library_Controller):
	New limited controlled type used to automate the initialization and
	finalization of the sockets implementation.
	(GNAT.Sockets.Initialize, Finalize): Make these no-ops

2009-04-08  Vincent Celier  <celier@adacore.com>

	* prj-attr.adb: New read-only project-level attribute Project_Dir

	* prj-proc.adb (Add_Attributes): New parameter Project_Dir, value of
	read-only attribute of the same name.
	(Process_Declarative_Items): Call Add_Attributes with Project_Dir
	(Recursive_Process): Ditto

	* snames.adb: Add new standard name Project_Dir

	* snames.ads: Add new standard name Project_Dir

From-SVN: r145766
This commit is contained in:
Arnaud Charlet 2009-04-08 20:03:10 +02:00
parent f4a5580200
commit 3d5952be50
11 changed files with 172 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
gcc/ada/ChangeLog
View File

@ -1,3 +1,40 @@
2009-04-08 Robert Dewar <dewar@adacore.com>
* checks.adb (Enable_Overflow_Check): Do not enable if overflow checks
suppressed.
* exp_ch4.adb (Expand_Concatenate): Make sure checks are off for all
resolution steps.
2009-04-08 Robert Dewar <dewar@adacore.com>
* sem_ch12.adb (Analyze_Package_Instantiation): Remove test for
No_Local_Allocators restriction preventing local instantiation.
2009-04-08 Thomas Quinot <quinot@adacore.com>
* sem_eval.adb: Minor comment fix
2009-04-08 Thomas Quinot <quinot@adacore.com>
* g-socket.adb, g-socket.ads (GNAT.Sockets.Sockets_Library_Controller):
New limited controlled type used to automate the initialization and
finalization of the sockets implementation.
(GNAT.Sockets.Initialize, Finalize): Make these no-ops
2009-04-08 Vincent Celier <celier@adacore.com>
* prj-attr.adb: New read-only project-level attribute Project_Dir
* prj-proc.adb (Add_Attributes): New parameter Project_Dir, value of
read-only attribute of the same name.
(Process_Declarative_Items): Call Add_Attributes with Project_Dir
(Recursive_Process): Ditto
* snames.adb: Add new standard name Project_Dir
* snames.ads: Add new standard name Project_Dir
2009-04-08 Thomas Quinot <quinot@adacore.com>
* checks.adb: Minor reformatting

9
gcc/ada/checks.adb
View File

@ -3560,12 +3560,19 @@ package body Checks is
pg (Union_Id (N));
end if;
-- No check if overflow checks suppressed for type of node
if Present (Etype (N))
and then Overflow_Checks_Suppressed (Etype (N))
then
return;
-- Nothing to do if the range of the result is known OK. We skip this
-- for conversions, since the caller already did the check, and in any
-- case the condition for deleting the check for a type conversion is
-- different.
if Nkind (N) /= N_Type_Conversion then
elsif Nkind (N) /= N_Type_Conversion then
Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
-- Note in the test below that we assume that the range is not OK

2
gcc/ada/exp_ch4.adb
View File

@ -2287,7 +2287,7 @@ package body Exp_Ch4 is
-- we analyzed and resolved the expression.
Set_Parent (X, Cnode);
Analyze_And_Resolve (X, Artyp);
Analyze_And_Resolve (X, Artyp, Suppress => All_Checks);
if Compile_Time_Compare
(X, Type_High_Bound (Istyp), Assume_Valid => False) = GT

74
gcc/ada/g-socket.adb
View File

@ -33,6 +33,7 @@
with Ada.Streams; use Ada.Streams;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Finalization;
with Ada.Unchecked_Conversion;
with Interfaces.C.Strings;
@ -53,9 +54,6 @@ package body GNAT.Sockets is
use type C.int;
Finalized : Boolean := False;
Initialized : Boolean := False;
ENOERROR : constant := 0;
Empty_Socket_Set : Socket_Set_Type;
@ -242,6 +240,15 @@ package body GNAT.Sockets is
-- it is added to the write set. If no selector is provided, a local one is
-- created for this call and destroyed prior to returning.
type Sockets_Library_Controller is new Ada.Finalization.Limited_Controlled
with null record;
-- This type is used to generate automatic calls to Initialize and Finalize
-- during the elaboration and finalization of this package. A single object
-- of this type must exist at library level.
procedure Initialize (X : in out Sockets_Library_Controller);
procedure Finalize (X : in out Sockets_Library_Controller);
---------
-- "+" --
---------
@ -793,14 +800,24 @@ package body GNAT.Sockets is
-- Finalize --
--------------
procedure Finalize (X : in out Sockets_Library_Controller) is
pragma Unreferenced (X);
begin
-- Finalization operation for the GNAT.Sockets package
Thin.Finalize;
end Finalize;
--------------
-- Finalize --
--------------
procedure Finalize is
begin
if not Finalized
and then Initialized
then
Finalized := True;
Thin.Finalize;
end if;
-- This is a dummy placeholder for an obsolete API.
-- The real finalization actions are in Initialize primitive operation
-- of Sockets_Library_Controller.
null;
end Finalize;
---------
@ -1218,6 +1235,7 @@ package body GNAT.Sockets is
function Image (Item : Socket_Set_Type) return String is
Socket_Set : Socket_Set_Type := Item;
begin
declare
Last_Img : constant String := Socket_Set.Last'Img;
@ -1225,9 +1243,11 @@ package body GNAT.Sockets is
(1 .. (Integer (Socket_Set.Last) + 1) * Last_Img'Length);
Index : Positive := 1;
Socket : Socket_Type;
begin
while not Is_Empty (Socket_Set) loop
Get (Socket_Set, Socket);
declare
Socket_Img : constant String := Socket'Img;
begin
@ -1235,6 +1255,7 @@ package body GNAT.Sockets is
Index := Index + Socket_Img'Length;
end;
end loop;
return "[" & Last_Img & "]" & Buffer (1 .. Index - 1);
end;
end Image;
@ -1281,6 +1302,20 @@ package body GNAT.Sockets is
-- Initialize --
----------------
procedure Initialize (X : in out Sockets_Library_Controller) is
pragma Unreferenced (X);
begin
-- Initialization operation for the GNAT.Sockets package
Empty_Socket_Set.Last := No_Socket;
Reset_Socket_Set (Empty_Socket_Set.Set'Access);
Thin.Initialize;
end Initialize;
----------------
-- Initialize --
----------------
procedure Initialize (Process_Blocking_IO : Boolean) is
Expected : constant Boolean := not SOSC.Thread_Blocking_IO;
@ -1290,7 +1325,11 @@ package body GNAT.Sockets is
"incorrect Process_Blocking_IO setting, expected " & Expected'Img;
end if;
Initialize;
-- This is a dummy placeholder for an obsolete API.
-- Real initialization actions are in Initialize primitive operation
-- of Sockets_Library_Controller.
null;
end Initialize;
----------------
@ -1299,12 +1338,10 @@ package body GNAT.Sockets is
procedure Initialize is
begin
if not Initialized then
Initialized := True;
Empty_Socket_Set.Last := No_Socket;
Reset_Socket_Set (Empty_Socket_Set.Set'Access);
Thin.Initialize;
end if;
-- This is a dummy placeholder for an obsolete API.
-- Real initialization actions are in Initialize primitive operation
-- of Sockets_Library_Controller.
null;
end Initialize;
--------------
@ -2330,4 +2367,9 @@ package body GNAT.Sockets is
end if;
end Write;
Sockets_Library_Controller_Object : Sockets_Library_Controller;
pragma Unreferenced (Sockets_Library_Controller_Object);
-- The elaboration and finalization of this object perform the required
-- initialization and cleanup actions for the sockets library.
end GNAT.Sockets;

6
gcc/ada/g-socket.ads
View File

@ -383,6 +383,8 @@ package GNAT.Sockets is
-- Note that this operation is a no-op on UNIX platforms, but applications
-- should make sure to call it if portability is expected: some platforms
-- (such as Windows) require initialization before any socket operation.
-- This is now a no-op (initialization and finalization are done
-- automatically).
procedure Initialize (Process_Blocking_IO : Boolean);
pragma Obsolescent
@ -394,10 +396,14 @@ package GNAT.Sockets is
-- is built. The old version of Initialize, taking a parameter, is kept
-- for compatibility reasons, but this interface is obsolete (and if the
-- value given is wrong, an exception will be raised at run time).
-- This is now a no-op (initialization and finalization are done
-- automatically).
procedure Finalize;
-- After Finalize is called it is not possible to use any routines
-- exported in by this package. This procedure is idempotent.
-- This is now a no-op (initialization and finalization are done
-- automatically).
type Socket_Type is private;
-- Sockets are used to implement a reliable bi-directional point-to-point,

1
gcc/ada/prj-attr.adb
View File

@ -68,6 +68,7 @@ package body Prj.Attr is
-- General
"SVRname#" &
"SVRproject_dir#" &
"lVmain#" &
"LVlanguages#" &
"SVmain_language#" &

24
gcc/ada/prj-proc.adb
View File

@ -66,6 +66,7 @@ package body Prj.Proc is
procedure Add_Attributes
(Project : Project_Id;
Project_Name : Name_Id;
Project_Dir : Name_Id;
In_Tree : Project_Tree_Ref;
Decl : in out Declarations;
First : Attribute_Node_Id;
@ -183,6 +184,7 @@ package body Prj.Proc is
procedure Add_Attributes
(Project : Project_Id;
Project_Name : Name_Id;
Project_Dir : Name_Id;
In_Tree : Project_Tree_Ref;
Decl : in out Declarations;
First : Attribute_Node_Id;
@ -217,13 +219,20 @@ package body Prj.Proc is
Value => Empty_String,
Index => 0);
-- Special case of <project>'Name
-- Special cases of <project>'Name and
-- <project>'Project_Dir.
if Project_Level
and then Attribute_Name_Of (The_Attribute) =
Snames.Name_Name
then
New_Attribute.Value := Project_Name;
if Project_Level then
if Attribute_Name_Of (The_Attribute) =
Snames.Name_Name
then
New_Attribute.Value := Project_Name;
elsif Attribute_Name_Of (The_Attribute) =
Snames.Name_Project_Dir
then
New_Attribute.Value := Project_Dir;
end if;
end if;
-- List attributes have a default value of nil list
@ -1372,6 +1381,8 @@ package body Prj.Proc is
Add_Attributes
(Project,
In_Tree.Projects.Table (Project).Name,
Name_Id
(In_Tree.Projects.Table (Project).Directory.Name),
In_Tree,
In_Tree.Packages.Table (New_Pkg).Decl,
First_Attribute_Of
@ -2607,6 +2618,7 @@ package body Prj.Proc is
Add_Attributes
(Project,
Name,
Name_Id (Processed_Data.Directory.Name),
In_Tree,
Processed_Data.Decl,
Prj.Attr.Attribute_First,

16
gcc/ada/sem_ch12.adb
View File

@ -3435,14 +3435,16 @@ package body Sem_Ch12 is
Validate_Categorization_Dependency (N, Act_Decl_Id);
-- Check restriction, but skip this if something went wrong in the above
-- analysis, indicated by Act_Decl_Id being void.
-- There used to be a check here to prevent instantiations in local
-- contexts if the No_Local_Allocators restriction was active. This
-- check was removed by a binding interpretation in AI-95-00130/07,
-- but we retain the code for documentation purposes.
if Ekind (Act_Decl_Id) /= E_Void
and then not Is_Library_Level_Entity (Act_Decl_Id)
then
Check_Restriction (No_Local_Allocators, N);
end if;
-- if Ekind (Act_Decl_Id) /= E_Void
-- and then not Is_Library_Level_Entity (Act_Decl_Id)
-- then
-- Check_Restriction (No_Local_Allocators, N);
-- end if;
if Inline_Now then
Inline_Instance_Body (N, Gen_Unit, Act_Decl);

2
gcc/ada/sem_eval.adb
View File

@ -189,7 +189,7 @@ package body Sem_Eval is
-- it is not technically static (e.g. the static lower bound of a range
-- whose upper bound is non-static).
--
-- If Stat is set False on return, then Expression_Is_Foldable makes a
-- If Stat is set False on return, then Test_Expression_Is_Foldable makes a
-- call to Check_Non_Static_Context on the operand. If Fold is False on
-- return, then all processing is complete, and the caller should
-- return, since there is nothing else to do.

1
gcc/ada/snames.adb
View File

@ -790,6 +790,7 @@ package body Snames is
"pretty_printer#" &
"prefix#" &
"project#" &
"project_dir#" &
"roots#" &
"required_switches#" &
"run_path_option#" &

63
gcc/ada/snames.ads
View File

@ -1114,49 +1114,50 @@ package Snames is
Name_Pretty_Printer : constant Name_Id := N + 729;
Name_Prefix : constant Name_Id := N + 730;
Name_Project : constant Name_Id := N + 731;
Name_Roots : constant Name_Id := N + 732;
Name_Required_Switches : constant Name_Id := N + 733;
Name_Run_Path_Option : constant Name_Id := N + 734;
Name_Runtime_Project : constant Name_Id := N + 735;
Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 736;
Name_Shared_Library_Prefix : constant Name_Id := N + 737;
Name_Shared_Library_Suffix : constant Name_Id := N + 738;
Name_Separate_Suffix : constant Name_Id := N + 739;
Name_Source_Dirs : constant Name_Id := N + 740;
Name_Source_Files : constant Name_Id := N + 741;
Name_Source_List_File : constant Name_Id := N + 742;
Name_Spec : constant Name_Id := N + 743;
Name_Spec_Suffix : constant Name_Id := N + 744;
Name_Specification : constant Name_Id := N + 745;
Name_Specification_Exceptions : constant Name_Id := N + 746;
Name_Specification_Suffix : constant Name_Id := N + 747;
Name_Stack : constant Name_Id := N + 748;
Name_Switches : constant Name_Id := N + 749;
Name_Symbolic_Link_Supported : constant Name_Id := N + 750;
Name_Sync : constant Name_Id := N + 751;
Name_Synchronize : constant Name_Id := N + 752;
Name_Toolchain_Description : constant Name_Id := N + 753;
Name_Toolchain_Version : constant Name_Id := N + 754;
Name_Runtime_Library_Dir : constant Name_Id := N + 755;
Name_Project_Dir : constant Name_Id := N + 732;
Name_Roots : constant Name_Id := N + 733;
Name_Required_Switches : constant Name_Id := N + 734;
Name_Run_Path_Option : constant Name_Id := N + 735;
Name_Runtime_Project : constant Name_Id := N + 736;
Name_Shared_Library_Minimum_Switches : constant Name_Id := N + 737;
Name_Shared_Library_Prefix : constant Name_Id := N + 738;
Name_Shared_Library_Suffix : constant Name_Id := N + 739;
Name_Separate_Suffix : constant Name_Id := N + 740;
Name_Source_Dirs : constant Name_Id := N + 741;
Name_Source_Files : constant Name_Id := N + 742;
Name_Source_List_File : constant Name_Id := N + 743;
Name_Spec : constant Name_Id := N + 744;
Name_Spec_Suffix : constant Name_Id := N + 745;
Name_Specification : constant Name_Id := N + 746;
Name_Specification_Exceptions : constant Name_Id := N + 747;
Name_Specification_Suffix : constant Name_Id := N + 748;
Name_Stack : constant Name_Id := N + 749;
Name_Switches : constant Name_Id := N + 750;
Name_Symbolic_Link_Supported : constant Name_Id := N + 751;
Name_Sync : constant Name_Id := N + 752;
Name_Synchronize : constant Name_Id := N + 753;
Name_Toolchain_Description : constant Name_Id := N + 754;
Name_Toolchain_Version : constant Name_Id := N + 755;
Name_Runtime_Library_Dir : constant Name_Id := N + 756;
-- Other miscellaneous names used in front end
Name_Unaligned_Valid : constant Name_Id := N + 756;
Name_Unaligned_Valid : constant Name_Id := N + 757;
-- Ada 2005 reserved words
First_2005_Reserved_Word : constant Name_Id := N + 757;
Name_Interface : constant Name_Id := N + 757;
Name_Overriding : constant Name_Id := N + 758;
Name_Synchronized : constant Name_Id := N + 759;
Last_2005_Reserved_Word : constant Name_Id := N + 759;
First_2005_Reserved_Word : constant Name_Id := N + 758;
Name_Interface : constant Name_Id := N + 758;
Name_Overriding : constant Name_Id := N + 759;
Name_Synchronized : constant Name_Id := N + 760;
Last_2005_Reserved_Word : constant Name_Id := N + 760;
subtype Ada_2005_Reserved_Words is
Name_Id range First_2005_Reserved_Word .. Last_2005_Reserved_Word;
-- Mark last defined name for consistency check in Snames body
Last_Predefined_Name : constant Name_Id := N + 759;
Last_Predefined_Name : constant Name_Id := N + 760;
---------------------------------------
-- Subtypes Defining Name Categories --