+2016-10-12 Tristan Gingold <gingold@adacore.com>
+
+ * 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 <schonberg@adacore.com>
+
+ * 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 <duff@adacore.com>
+
+ * spitbol_table.ads, spitbol_table.adb (Adjust, Finalize): Add
+ "overriding".
+
+2016-10-12 Bob Duff <duff@adacore.com>
+
+ * 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 <lambourg@adacore.com>
+
+ * init.c: Fix sigtramp with the x86_64-vx7-vxsim target on
+ Windows host.
+
+2016-10-12 Vadim Godunko <godunko@adacore.com>
+
+ * 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 <schonberg@adacore.com>
* sem_ch12.adb (Check_Formal_Package_Instance): Skip an internal
-- 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
-------------------
function Can_Be_Reused
- (Item : Shared_String_Access;
+ (Item : not null Shared_String_Access;
Length : Natural) return Boolean is
begin
return
--------------
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,
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;
-- --
-- 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 --
-- 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
-- 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);
-- 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;
-- --
-- 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- --
-- Adjust --
------------
- procedure Adjust (Object : in out Table) is
+ overriding procedure Adjust (Object : in out Table) is
Ptr1 : Hash_Element_Ptr;
Ptr2 : Hash_Element_Ptr;
-- Finalize --
--------------
- procedure Finalize (Object : in out Table) is
+ overriding procedure Finalize (Object : in out Table) is
Ptr1 : Hash_Element_Ptr;
Ptr2 : Hash_Element_Ptr;
-- --
-- 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- --
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.
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
-- --
-- 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- --
-- 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
-- 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;
-- --
-- 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- --
System_Pool_Empty,
System_Pool_Local,
System_Pool_Size,
+ System_Relative_Delays,
System_RPC,
System_Scalar_Values,
System_Secondary_Stack,
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
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,
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 --
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 --
-- 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
-- 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
-- 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
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;
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,
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;
projects / gcc.git / commitdiff