diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 37 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/g-socket.adb | 74 | ||||
| -rw-r--r-- | gcc/ada/g-socket.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/prj-attr.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/prj-proc.adb | 24 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/sem_eval.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/snames.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/snames.ads | 63 |
11 files changed, 173 insertions, 64 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3a6edf9..baa8423 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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 diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 549d1b6..cb32cc2 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -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 diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 190baa6..78c4285 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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 diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index e586a2d..55629d2 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -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; diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index 7dddd3d..9ea9ecc 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -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, diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index 250a412..1096743 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -68,6 +68,7 @@ package body Prj.Attr is -- General "SVRname#" & + "SVRproject_dir#" & "lVmain#" & "LVlanguages#" & "SVmain_language#" & diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 03e7327..5cd2fa2 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -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, diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 63e810d..acacec5 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -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. - - 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; + -- 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 Inline_Now then Inline_Instance_Body (N, Gen_Unit, Act_Decl); diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index dece544..b294171 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -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. diff --git a/gcc/ada/snames.adb b/gcc/ada/snames.adb index 7d9f04f..29a6b0d 100644 --- a/gcc/ada/snames.adb +++ b/gcc/ada/snames.adb @@ -790,6 +790,7 @@ package body Snames is "pretty_printer#" & "prefix#" & "project#" & + "project_dir#" & "roots#" & "required_switches#" & "run_path_option#" & diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index 0b7f9b7..8c44e8a 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -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 -- |