From 7504523eca9e01f30629b7bc22da57546ccd488d Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 12 Oct 2016 14:27:25 +0200 Subject: [PATCH] [multiple changes] 2016-10-12 Tristan Gingold * exp_ch9.adb (Expand_N_Delay_Relative_Statement): Add support for a secondary procedure in case of missing Ada.Calendar.Delays * rtsfind.ads (RTU_Id): Add System_Relative_Delays. (RE_Id): Add RO_RD_Delay_For. * rtsfind.adb (Output_Entity_Name): Handle correctly units RO_XX. * s-rident.ads: Remove No_Relative_Delays restriction for GNAT_Extended_Ravenscar. 2016-10-12 Ed Schonberg * sem_elab.adb (Within_Initial_Condition): When deternining the context of the expression, use the original node if it is a pragma, because Check pragmas are rewritten as conditionals when assertions are not enabled. 2016-10-12 Bob Duff * spitbol_table.ads, spitbol_table.adb (Adjust, Finalize): Add "overriding". 2016-10-12 Bob Duff * a-strunb-shared.ads, a-strunb-shared.adb (Finalize): Make sure Finalize is idempotent. (Unreference): Check for Empty_Shared_String, in case the reference count of the empty string wraps around. Also add "not null" in various places that can't be null. 2016-10-12 Jerome Lambourg * init.c: Fix sigtramp with the x86_64-vx7-vxsim target on Windows host. 2016-10-12 Vadim Godunko * s-os_lib.ads (Is_Owner_Readable_File): Renamed from Is_Readable_File. (Is_Owner_Writable_File): Renamed from Is_Writable_File. (Is_Readable_File): Renames Is_Read_Accessible_File. (Is_Writable_File): Renames Is_Write_Accessible_File. From-SVN: r241035 --- gcc/ada/ChangeLog | 44 +++++++++++++++++++++++++++++++++++++ gcc/ada/a-strunb-shared.adb | 20 +++++++++-------- gcc/ada/a-strunb-shared.ads | 9 ++++---- gcc/ada/exp_ch9.adb | 16 ++++++++++++-- gcc/ada/g-spitbo.adb | 6 ++--- gcc/ada/g-spitbo.ads | 6 ++--- gcc/ada/init.c | 2 +- gcc/ada/rtsfind.adb | 16 +++++++++++--- gcc/ada/rtsfind.ads | 7 +++++- gcc/ada/s-os_lib.adb | 32 +++++++++++++-------------- gcc/ada/s-os_lib.ads | 16 ++++++++++---- gcc/ada/s-rident.ads | 1 - gcc/ada/sem_elab.adb | 8 +++++++ 13 files changed, 136 insertions(+), 47 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 87a5447d79a..37ab195c5bb 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,47 @@ +2016-10-12 Tristan Gingold + + * exp_ch9.adb (Expand_N_Delay_Relative_Statement): Add support + for a secondary procedure in case of missing Ada.Calendar.Delays + * rtsfind.ads (RTU_Id): Add System_Relative_Delays. + (RE_Id): Add RO_RD_Delay_For. + * rtsfind.adb (Output_Entity_Name): Handle correctly units RO_XX. + * s-rident.ads: Remove No_Relative_Delays + restriction for GNAT_Extended_Ravenscar. + +2016-10-12 Ed Schonberg + + * sem_elab.adb (Within_Initial_Condition): When deternining + the context of the expression, use the original node if it is + a pragma, because Check pragmas are rewritten as conditionals + when assertions are not enabled. + +2016-10-12 Bob Duff + + * spitbol_table.ads, spitbol_table.adb (Adjust, Finalize): Add + "overriding". + +2016-10-12 Bob Duff + + * a-strunb-shared.ads, a-strunb-shared.adb (Finalize): + Make sure Finalize is idempotent. + (Unreference): Check for + Empty_Shared_String, in case the reference count of the empty + string wraps around. + Also add "not null" in various places that can't be null. + +2016-10-12 Jerome Lambourg + + * init.c: Fix sigtramp with the x86_64-vx7-vxsim target on + Windows host. + +2016-10-12 Vadim Godunko + + * s-os_lib.ads (Is_Owner_Readable_File): Renamed from + Is_Readable_File. + (Is_Owner_Writable_File): Renamed from Is_Writable_File. + (Is_Readable_File): Renames Is_Read_Accessible_File. + (Is_Writable_File): Renames Is_Write_Accessible_File. + 2016-10-12 Ed Schonberg * sem_ch12.adb (Check_Formal_Package_Instance): Skip an internal diff --git a/gcc/ada/a-strunb-shared.adb b/gcc/ada/a-strunb-shared.adb index 88698b0c892..ba308f5cdc4 100644 --- a/gcc/ada/a-strunb-shared.adb +++ b/gcc/ada/a-strunb-shared.adb @@ -499,7 +499,9 @@ package body Ada.Strings.Unbounded is -- Allocate -- -------------- - function Allocate (Max_Length : Natural) return Shared_String_Access is + function Allocate + (Max_Length : Natural) return not null Shared_String_Access + is begin -- Empty string requested, return shared empty string @@ -622,7 +624,7 @@ package body Ada.Strings.Unbounded is ------------------- function Can_Be_Reused - (Item : Shared_String_Access; + (Item : not null Shared_String_Access; Length : Natural) return Boolean is begin return @@ -785,10 +787,9 @@ package body Ada.Strings.Unbounded is -------------- procedure Finalize (Object : in out Unbounded_String) is - SR : constant Shared_String_Access := Object.Reference; - + SR : constant not null Shared_String_Access := Object.Reference; begin - if SR /= null then + if SR /= Null_Unbounded_String.Reference then -- The same controlled object can be finalized several times for -- some reason. As per 7.6.1(24) this should have no ill effect, @@ -2101,11 +2102,12 @@ package body Ada.Strings.Unbounded is begin if System.Atomic_Counters.Decrement (Aux.Counter) then - -- Reference counter of Empty_Shared_String must never reach zero + -- Reference counter of Empty_Shared_String should never reach + -- zero. We check here in case it wraps around. - pragma Assert (Aux /= Empty_Shared_String'Access); - - Free (Aux); + if Aux /= Empty_Shared_String'Access then + Free (Aux); + end if; end if; end Unreference; diff --git a/gcc/ada/a-strunb-shared.ads b/gcc/ada/a-strunb-shared.ads index 1a00780fad7..c5f96b38f17 100644 --- a/gcc/ada/a-strunb-shared.ads +++ b/gcc/ada/a-strunb-shared.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -449,14 +449,15 @@ private -- Decrement reference counter, deallocate Item when counter goes to zero function Can_Be_Reused - (Item : Shared_String_Access; + (Item : not null Shared_String_Access; Length : Natural) return Boolean; -- Returns True if Shared_String can be reused. There are two criteria when -- Shared_String can be reused: its reference counter must be one (thus -- Shared_String is owned exclusively) and its size is sufficient to -- store string with specified length effectively. - function Allocate (Max_Length : Natural) return Shared_String_Access; + function Allocate + (Max_Length : Natural) return not null Shared_String_Access; -- Allocates new Shared_String with at least specified maximum length. -- Actual maximum length of the allocated Shared_String can be slightly -- greater. Returns reference to Empty_Shared_String when requested length @@ -469,7 +470,7 @@ private -- This renames are here only to be used in the pragma Stream_Convert type Unbounded_String is new AF.Controlled with record - Reference : Shared_String_Access := Empty_Shared_String'Access; + Reference : not null Shared_String_Access := Empty_Shared_String'Access; end record; pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String); diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 22373ddaa57..9467303e2fc 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -8388,11 +8388,23 @@ package body Exp_Ch9 is -- simple delays imposed by the use of Protected Objects. procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); + Loc : constant Source_Ptr := Sloc (N); + Proc : Entity_Id; begin + if RTE_Available (RO_RD_Delay_For) then + -- Try to use System.Relative_Delays.Delay_For only if available. + -- This is the implementation used on restricted platforms when + -- Ada.Calendar is not available. + Proc := RTE (RO_RD_Delay_For); + else + -- Otherwise, use Ada.Calendar.Delays.Delay_For and emit an error + -- message if not available. + Proc := RTE (RO_CA_Delay_For); + end if; + Rewrite (N, Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (RTE (RO_CA_Delay_For), Loc), + Name => New_Occurrence_Of (Proc, Loc), Parameter_Associations => New_List (Expression (N)))); Analyze (N); end Expand_N_Delay_Relative_Statement; diff --git a/gcc/ada/g-spitbo.adb b/gcc/ada/g-spitbo.adb index 22677149ee1..26753bd0b11 100644 --- a/gcc/ada/g-spitbo.adb +++ b/gcc/ada/g-spitbo.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2012, AdaCore -- +-- Copyright (C) 1998-2016, AdaCore -- -- -- -- 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- -- @@ -333,7 +333,7 @@ package body GNAT.Spitbol is -- Adjust -- ------------ - procedure Adjust (Object : in out Table) is + overriding procedure Adjust (Object : in out Table) is Ptr1 : Hash_Element_Ptr; Ptr2 : Hash_Element_Ptr; @@ -555,7 +555,7 @@ package body GNAT.Spitbol is -- Finalize -- -------------- - procedure Finalize (Object : in out Table) is + overriding procedure Finalize (Object : in out Table) is Ptr1 : Hash_Element_Ptr; Ptr2 : Hash_Element_Ptr; diff --git a/gcc/ada/g-spitbo.ads b/gcc/ada/g-spitbo.ads index e97bb62d033..b07a21451fc 100644 --- a/gcc/ada/g-spitbo.ads +++ b/gcc/ada/g-spitbo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2012, AdaCore -- +-- Copyright (C) 1997-2016, AdaCore -- -- -- -- 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- -- @@ -379,12 +379,12 @@ package GNAT.Spitbol is pragma Finalize_Storage_Only (Table); - procedure Adjust (Object : in out Table); + overriding procedure Adjust (Object : in out Table); -- The Adjust procedure does a deep copy of the table structure -- so that the effect of assignment is, like other assignments -- in Ada, value-oriented. - procedure Finalize (Object : in out Table); + overriding procedure Finalize (Object : in out Table); -- This is the finalization routine that ensures that all storage -- associated with a table is properly released when a table object -- is abandoned and finalized. diff --git a/gcc/ada/init.c b/gcc/ada/init.c index cec968b9ae7..114310dd5a0 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -2109,7 +2109,7 @@ __gnat_install_handler (void) if ((strncmp (model, "Linux", 5) == 0) || (strncmp (model, "Windows", 7) == 0) || (strncmp (model, "SIMLINUX", 8) == 0) /* vx7 */ - || (strncmp (model, "SIMWINDOWS", 10) == 0)) /* ditto */ + || (strncmp (model, "SIMNT", 5) == 0)) /* ditto */ __gnat_set_is_vxsim (TRUE); } #endif diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb index e2d9cb53018..5745b00cfd8 100644 --- a/gcc/ada/rtsfind.adb +++ b/gcc/ada/rtsfind.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -1144,6 +1144,9 @@ package body Rtsfind is -- M (1 .. P) is current message to be output RE_Image : constant String := RE_Id'Image (Id); + S : Natural; + -- RE_Image (S .. RE_Image'Last) is the name of the entity without the + -- "RE_" or "RO_XX_" prefix. begin if Id = RE_Null then @@ -1168,8 +1171,15 @@ package body Rtsfind is -- Add entity name and closing quote to message - Name_Len := RE_Image'Length - 3; - Name_Buffer (1 .. Name_Len) := RE_Image (4 .. RE_Image'Length); + if RE_Image (2) = 'E' then + -- Strip "RE" + S := 4; + else + -- Strip "RO_XX" + S := 7; + end if; + Name_Len := RE_Image'Length - S + 1; + Name_Buffer (1 .. Name_Len) := RE_Image (S .. RE_Image'Last); Set_Casing (Mixed_Case); M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len); P := P + Name_Len; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 842c65bc761..6163f0bf27c 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -349,6 +349,7 @@ package Rtsfind is System_Pool_Empty, System_Pool_Local, System_Pool_Size, + System_Relative_Delays, System_RPC, System_Scalar_Values, System_Secondary_Stack, @@ -1403,6 +1404,8 @@ package Rtsfind is RE_Tk_Objref, -- System.Partition_Interface RE_Tk_Union, -- System.Partition_Interface + RO_RD_Delay_For, -- System.Relative_Delays + RE_IS_Is1, -- System.Scalar_Values RE_IS_Is2, -- System.Scalar_Values RE_IS_Is4, -- System.Scalar_Values @@ -2635,6 +2638,8 @@ package Rtsfind is RE_Stack_Bounded_Pool => System_Pool_Size, + RO_RD_Delay_For => System_Relative_Delays, + RE_Do_Apc => System_RPC, RE_Do_Rpc => System_RPC, RE_Params_Stream_Type => System_RPC, diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb index 31b2f08cab9..5da95112340 100644 --- a/gcc/ada/s-os_lib.adb +++ b/gcc/ada/s-os_lib.adb @@ -1510,24 +1510,24 @@ package body System.OS_Lib is return Is_Read_Accessible_File (F_Name'Address) /= 0; end Is_Read_Accessible_File; - ---------------------- - -- Is_Readable_File -- - ---------------------- + ---------------------------- + -- Is_Owner_Readable_File -- + ---------------------------- - function Is_Readable_File (Name : C_File_Name) return Boolean is + function Is_Owner_Readable_File (Name : C_File_Name) return Boolean is function Is_Readable_File (Name : Address) return Integer; pragma Import (C, Is_Readable_File, "__gnat_is_readable_file"); begin return Is_Readable_File (Name) /= 0; - end Is_Readable_File; + end Is_Owner_Readable_File; - function Is_Readable_File (Name : String) return Boolean is + function Is_Owner_Readable_File (Name : String) return Boolean is F_Name : String (1 .. Name'Length + 1); begin F_Name (1 .. Name'Length) := Name; F_Name (F_Name'Last) := ASCII.NUL; - return Is_Readable_File (F_Name'Address); - end Is_Readable_File; + return Is_Owner_Readable_File (F_Name'Address); + end Is_Owner_Readable_File; ------------------------ -- Is_Executable_File -- @@ -1601,24 +1601,24 @@ package body System.OS_Lib is return Is_Write_Accessible_File (F_Name'Address) /= 0; end Is_Write_Accessible_File; - ---------------------- - -- Is_Writable_File -- - ---------------------- + ---------------------------- + -- Is_Owner_Writable_File -- + ---------------------------- - function Is_Writable_File (Name : C_File_Name) return Boolean is + function Is_Owner_Writable_File (Name : C_File_Name) return Boolean is function Is_Writable_File (Name : Address) return Integer; pragma Import (C, Is_Writable_File, "__gnat_is_writable_file"); begin return Is_Writable_File (Name) /= 0; - end Is_Writable_File; + end Is_Owner_Writable_File; - function Is_Writable_File (Name : String) return Boolean is + function Is_Owner_Writable_File (Name : String) return Boolean is F_Name : String (1 .. Name'Length + 1); begin F_Name (1 .. Name'Length) := Name; F_Name (F_Name'Last) := ASCII.NUL; - return Is_Writable_File (F_Name'Address); - end Is_Writable_File; + return Is_Owner_Writable_File (F_Name'Address); + end Is_Owner_Writable_File; ---------- -- Kill -- diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index 90048749082..e4a2624ea7b 100644 --- a/gcc/ada/s-os_lib.ads +++ b/gcc/ada/s-os_lib.ads @@ -425,7 +425,7 @@ package System.OS_Lib is -- not actually be readable due to some other process having exclusive -- access. - function Is_Readable_File (Name : String) return Boolean; + function Is_Owner_Readable_File (Name : String) return Boolean; -- Determines if the given string, Name, is the name of an existing file -- that is readable. Returns True if so, False otherwise. Note that this -- function simply interrogates the file attributes (e.g. using the C @@ -449,7 +449,7 @@ package System.OS_Lib is -- contains the name of the file to which it is linked. Symbolic links may -- span file systems and may refer to directories. - function Is_Writable_File (Name : String) return Boolean; + function Is_Owner_Writable_File (Name : String) return Boolean; -- Determines if the given string, Name, is the name of an existing file -- that is writable. Returns True if so, False otherwise. Note that this -- function simply interrogates the file attributes (e.g. using the C @@ -465,6 +465,14 @@ package System.OS_Lib is -- Determines if the given string, Name, is the name of an existing file -- that is writable. Returns True if so, False otherwise. + function Is_Readable_File (Name : String) return Boolean + renames Is_Read_Accessible_File; + function Is_Writable_File (Name : String) return Boolean + renames Is_Write_Accessible_File; + -- These subprograms provided for backward compatibility and should not be + -- used. Use Is_Owner_Readable_File/Is_Owner_Writable_File or + -- Is_Read_Accessible_File/Is_Write_Accessible_File instead. + function Locate_Exec_On_Path (Exec_Name : String) return String_Access; -- Try to locate an executable whose name is given by Exec_Name in the -- directories listed in the environment Path. If the Exec_Name does not @@ -683,10 +691,10 @@ package System.OS_Lib is function Is_Directory (Name : C_File_Name) return Boolean; function Is_Executable_File (Name : C_File_Name) return Boolean; - function Is_Readable_File (Name : C_File_Name) return Boolean; + function Is_Owner_Readable_File (Name : C_File_Name) return Boolean; function Is_Regular_File (Name : C_File_Name) return Boolean; function Is_Symbolic_Link (Name : C_File_Name) return Boolean; - function Is_Writable_File (Name : C_File_Name) return Boolean; + function Is_Owner_Writable_File (Name : C_File_Name) return Boolean; function Locate_Regular_File (File_Name : C_File_Name; diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads index 9b23b5b763f..ab234c304fe 100644 --- a/gcc/ada/s-rident.ads +++ b/gcc/ada/s-rident.ads @@ -574,7 +574,6 @@ package System.Rident is No_Implicit_Protected_Object_Allocations => True, No_Local_Timing_Events => True, - No_Relative_Delay => True, No_Select_Statements => True, No_Specific_Termination_Handlers => True, No_Task_Termination => True, diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 8e82d281795..66eaca70e27 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -2126,6 +2126,14 @@ package body Sem_Elab is end if; Par := Parent (Par); + + -- If assertions are not enabled, the check pragma is rewritten + -- as an if_statement in sem_prag, to generate various warnings + -- on boolean expressions. Retrieve the original pragma. + + if Nkind (Original_Node (Par)) = N_Pragma then + Par := Original_Node (Par); + end if; end loop; return False;