mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-19 14:51:13 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2014-07-16  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb (Process_Declarations): Reinstate the check on
	a hook object to ensure that the related transient declaration
	is finalizable.
	* exp_util.adb (Is_Aliased): Do not consider expresison with
	actions as a special context.
	(Requires_Cleanup_Actions): Reinstate the check on a hook object to
	ensure that the related transient declaration is finalizable.

2014-07-16  Robert Dewar  <dewar@adacore.com>

	* checks.ads, checks.adb (Allocation_Checks_Suppressed): New function.
	* snames.ads-tmpl: Add Allocation_Check to list of check names.
	* types.ads: Add Allocation_Check to list of check names.

2014-07-16  Thomas Quinot  <quinot@adacore.com>

	* sem_util.adb (Enter_Name): replace bogus test for presence of
	Corresponding_Remote_Type with correct test on Ekind.
	* sem_res.adb (Valid_Conversion): ditto; also clarify validity
	of calls to Corresponding_ Remote_Type (documentation fix).

2014-07-16  Robert Dewar  <dewar@adacore.com>

	* gnat_rm.texi: Document illegal case of Unrestricted_Access.
	* sem_attr.adb (Analyze_Access_Attribute): Set_Non_Aliased_Prefix
	where it applies.
	(Resolve_Attribute, case Access): Flag illegal Unrestricted_Access use.
	* sinfo.ads, sinfo.adb (Non_Aliased_Prefix): New flag.

From-SVN: r212655
This commit is contained in:
Arnaud Charlet 2014-07-16 16:29:36 +02:00
parent 904aac81db
commit b07b7acecf
13 changed files with 254 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
gcc/ada/ChangeLog
View File

@ -1,3 +1,34 @@
2014-07-16 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb (Process_Declarations): Reinstate the check on
a hook object to ensure that the related transient declaration
is finalizable.
* exp_util.adb (Is_Aliased): Do not consider expresison with
actions as a special context.
(Requires_Cleanup_Actions): Reinstate the check on a hook object to
ensure that the related transient declaration is finalizable.
2014-07-16 Robert Dewar <dewar@adacore.com>
* checks.ads, checks.adb (Allocation_Checks_Suppressed): New function.
* snames.ads-tmpl: Add Allocation_Check to list of check names.
* types.ads: Add Allocation_Check to list of check names.
2014-07-16 Thomas Quinot <quinot@adacore.com>
* sem_util.adb (Enter_Name): replace bogus test for presence of
Corresponding_Remote_Type with correct test on Ekind.
* sem_res.adb (Valid_Conversion): ditto; also clarify validity
of calls to Corresponding_ Remote_Type (documentation fix).
2014-07-16 Robert Dewar <dewar@adacore.com>
* gnat_rm.texi: Document illegal case of Unrestricted_Access.
* sem_attr.adb (Analyze_Access_Attribute): Set_Non_Aliased_Prefix
where it applies.
(Resolve_Attribute, case Access): Flag illegal Unrestricted_Access use.
* sinfo.ads, sinfo.adb (Non_Aliased_Prefix): New flag.
2014-07-16 Robert Dewar <dewar@adacore.com>
* gnat_ugn.texi: Document binder switch -Ra.

13
gcc/ada/checks.adb
View File

@ -419,6 +419,19 @@ package body Checks is
end if;
end Alignment_Checks_Suppressed;
----------------------------------
-- Allocation_Checks_Suppressed --
----------------------------------
function Allocation_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Allocation_Check);
else
return Scope_Suppress.Suppress (Allocation_Check);
end if;
end Allocation_Checks_Suppressed;
-------------------------
-- Append_Range_Checks --
-------------------------

1
gcc/ada/checks.ads
View File

@ -50,6 +50,7 @@ package Checks is
function Access_Checks_Suppressed (E : Entity_Id) return Boolean;
function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean;
function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean;
function Allocation_Checks_Suppressed (E : Entity_Id) return Boolean;
function Atomic_Synchronization_Disabled (E : Entity_Id) return Boolean;
function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean;
function Division_Checks_Suppressed (E : Entity_Id) return Boolean;

2
gcc/ada/exp_ch7.adb
View File

@ -1825,6 +1825,8 @@ package body Exp_Ch7 is
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
N_Object_Declaration
and then Is_Finalizable_Transient
(Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
then
Processing_Actions (Has_No_Init => True);

15
gcc/ada/exp_util.adb
View File

@ -4562,18 +4562,7 @@ package body Exp_Util is
elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
Ren_Obj := Find_Renamed_Object (Stmt);
if Present (Ren_Obj)
and then Ren_Obj = Trans_Id
-- When the related context is an expression with actions,
-- both the transient controlled object and its renaming are
-- bound by the "scope" of the expression with actions. In
-- other words, the two cannot be visible outside the scope,
-- therefore the lifetime of the transient object is not
-- really extended by the renaming.
and then Nkind (Rel_Node) /= N_Expression_With_Actions
then
if Present (Ren_Obj) and then Ren_Obj = Trans_Id then
return True;
end if;
end if;
@ -7344,6 +7333,8 @@ package body Exp_Util is
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
N_Object_Declaration
and then Is_Finalizable_Transient
(Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
then
return True;

72
gcc/ada/gnat_rm.texi
View File

@ -9551,22 +9551,65 @@ is in scope (normal Ada accessibility rules restrict this usage).
It is possible to use @code{Unrestricted_Access} for any type, but care
must be exercised if it is used to create pointers to unconstrained array
objects. In this case, the resulting pointer has the same scope as the
objects. In this case, the resulting pointer has the same scope as the
context of the attribute, and may not be returned to some enclosing
scope. For instance, a function cannot use @code{Unrestricted_Access}
scope. For instance, a function cannot use @code{Unrestricted_Access}
to create a unconstrained pointer and then return that value to the
caller. In addition, it is only valid to create pointers to unconstrained
caller. In addition, it is only valid to create pointers to unconstrained
arrays using this attribute if the pointer has the normal default ``fat''
representation where a pointer has two components, one points to the array
and one points to the bounds. If a size clause is used to force ``thin''
and one points to the bounds. If a size clause is used to force ``thin''
representation for a pointer to unconstrained where there is only space for
a single pointer, then any use of @code{Unrestricted_Access}
to create a value of such a type (e.g. by conversion from fat to
thin pointers) is erroneous. Consider the following example:
a single pointer, then the resulting pointer is not usable.
In the simple case where a direct use of Unrestricted_Access attempts
to make a thin pointer for a non-aliased object, the compiler will
reject the use as illegal, as shown in the following example:
@smallexample @c ada
with System; use System;
procedure SliceUA2 is
type A is access all String;
for A'Size use Standard'Address_Size;
procedure P (Arg : A) is
begin
null;
end P;
X : String := "hello world!";
X2 : aliased String := "hello world!";
AV : A := X'Unrestricted_Access; -- ERROR
|
>>> illegal use of Unrestricted_Access attribute
>>> attempt to generate thin pointer to unaliased object
begin
P (X'Unrestricted_Access); -- ERROR
|
>>> illegal use of Unrestricted_Access attribute
>>> attempt to generate thin pointer to unaliased object
P (X(7 .. 12)'Unrestricted_Access); -- ERROR
|
>>> illegal use of Unrestricted_Access attribute
>>> attempt to generate thin pointer to unaliased object
P (X2'Unrestricted_Access); -- OK
end;
@end smallexample
@noindent
but other cases cannot be detected by the compiler, and are
considered to be erroneous. Consider the following example:
@smallexample @c ada
with System; use System;
with System; use System;
procedure SliceUA is
type AF is access all String;
type A is access all String;
for A'Size use Standard'Address_Size;
@ -9578,28 +9621,29 @@ procedure SliceUA is
end P;
X : String := "hello world!";
Y : AF := X (7 .. 12)'Unrestricted_Access;
begin
P (X(7 .. 12)'Unrestricted_Access);
P (A (Y));
end;
@end smallexample
@noindent
This inevitably raises @code{Program_Error}.
A normal unconstrained array value
or a constrained array object marked as aliased has the bounds in memory
just before the array, so a thin pointer can retrieve both the data and
the bounds. But in this case, the non-aliased object @code{X} does not have the
bounds before the string. If the size clause for type @code{A}
the bounds. But in this case, the non-aliased object @code{X} does not have the
bounds before the string. If the size clause for type @code{A}
were not present, then the pointer
would be a fat pointer, where one component is a pointer to the bounds,
and all would be well. But with the size clause present, the conversion from
fat pointer to think pointer in the call looses the bounds.
and all would be well. But with the size clause present, the conversion from
fat pointer to thin pointer in the call looses the bounds, and so this
program raises a @code{Program_Error} exception if executed.
In general, it is advisable to completely
avoid mixing the use of thin pointers and the use of
@code{Unrestricted_Access} where the designated type is an
unconstrained array. The use of thin pointers should be restricted to
unconstrained array. The use of thin pointers should be restricted to
cases of porting legacy code which implicitly assumes the size of pointers,
and such code should not in any case be using this attribute.

99
gcc/ada/sem_attr.adb
View File

@ -764,9 +764,7 @@ package body Sem_Attr is
-- Case of access to subprogram
if Is_Entity_Name (P)
and then Is_Overloadable (Entity (P))
then
if Is_Entity_Name (P) and then Is_Overloadable (Entity (P)) then
if Has_Pragma_Inline_Always (Entity (P)) then
Error_Attr_P
("prefix of % attribute cannot be Inline_Always subprogram");
@ -961,15 +959,17 @@ package body Sem_Attr is
end if;
end if;
-- If we fall through, we have a normal access to object case.
-- Unrestricted_Access is legal wherever an allocator would be
-- legal, so its Etype is set to E_Allocator. The expected type
-- If we fall through, we have a normal access to object case
-- Unrestricted_Access is (for now) legal wherever an allocator would
-- be legal, so its Etype is set to E_Allocator. The expected type
-- of the other attributes is a general access type, and therefore
-- we label them with E_Access_Attribute_Type.
if not Is_Overloaded (P) then
Acc_Type := Build_Access_Object_Type (P_Type);
Set_Etype (N, Acc_Type);
else
declare
Index : Interp_Index;
@ -1022,21 +1022,42 @@ package body Sem_Attr is
end loop;
end;
-- Check for aliased view unless unrestricted case. We allow a
-- nonaliased prefix when within an instance because the prefix may
-- have been a tagged formal object, which is defined to be aliased
-- even when the actual might not be (other instance cases will have
-- been caught in the generic). Similarly, within an inlined body we
-- know that the attribute is legal in the original subprogram, and
-- therefore legal in the expansion.
-- Check for aliased view.. We allow a nonaliased prefix when within
-- an instance because the prefix may have been a tagged formal
-- object, which is defined to be aliased even when the actual
-- might not be (other instance cases will have been caught in the
-- generic). Similarly, within an inlined body we know that the
-- attribute is legal in the original subprogram, and therefore
-- legal in the expansion.
if Aname /= Name_Unrestricted_Access
and then not Is_Aliased_View (P)
if not Is_Aliased_View (P)
and then not In_Instance
and then not In_Inlined_Body
then
Error_Attr_P ("prefix of % attribute must be aliased");
Check_No_Implicit_Aliasing (P);
-- Here we have a non-aliased view. This is illegal unless we
-- have the case of Unrestricted_Access, where for now we allow
-- this (we will reject later if expected type is access to an
-- unconstrained array with a thin pointer).
if Aname /= Name_Unrestricted_Access then
Error_Attr_P ("prefix of % attribute must be aliased");
Check_No_Implicit_Aliasing (P);
-- For Unrestricted_Access, record that prefix is not aliased
-- to simplify legality check later on.
else
Set_Non_Aliased_Prefix (N);
end if;
-- If we have an aliased view, and we have Unrestricted_Access, then
-- output a warning that Unchecked_Access would have been fine, and
-- change the node to be Unchecked_Access.
else
-- For now, hold off on this change ???
null;
end if;
end Analyze_Access_Attribute;
@ -9726,10 +9747,10 @@ package body Sem_Attr is
Note_Possible_Modification (P, Sure => False);
end if;
-- The following comes from a query by Adam Beneschan, concerning
-- improper use of universal_access in equality tests involving
-- anonymous access types. Another good reason for 'Ref, but
-- for now disable the test, which breaks several filed tests.
-- The following comes from a query concerning improper use of
-- universal_access in equality tests involving anonymous access
-- types. Another good reason for 'Ref, but for now disable the
-- test, which breaks several filed tests???
if Ekind (Typ) = E_Anonymous_Access_Type
and then Nkind_In (Parent (N), N_Op_Eq, N_Op_Ne)
@ -9739,7 +9760,12 @@ package body Sem_Attr is
Error_Msg_N ("\qualify attribute with some access type", N);
end if;
-- Case where prefix is an entity name
if Is_Entity_Name (P) then
-- Deal with case where prefix itself is overloaded
if Is_Overloaded (P) then
Get_First_Interp (P, Index, It);
while Present (It.Nam) loop
@ -9772,12 +9798,19 @@ package body Sem_Attr is
Freeze_Before (N, Entity (P));
end if;
-- Nothing to do if prefix is a type name
elsif Is_Type (Entity (P)) then
null;
-- Otherwise non-overloaded other case, resolve the prefix
else
Resolve (P);
end if;
-- Some further error checks
Error_Msg_Name_1 := Aname;
if not Is_Entity_Name (P) then
@ -10109,7 +10142,7 @@ package body Sem_Attr is
or else
Attr_Id = Attribute_Unchecked_Access)
and then (Ekind (Btyp) = E_General_Access_Type
or else Ekind (Btyp) = E_Anonymous_Access_Type)
or else Ekind (Btyp) = E_Anonymous_Access_Type)
then
-- Ada 2005 (AI-230): Check the accessibility of anonymous
-- access types for stand-alone objects, record and array
@ -10358,6 +10391,28 @@ package body Sem_Attr is
end if;
end if;
-- Check for unrestricted access where expected type is a thin
-- pointer to an unconstrained array.
if Non_Aliased_Prefix (N)
and then Has_Size_Clause (Typ)
and then RM_Size (Typ) = System_Address_Size
then
declare
DT : constant Entity_Id := Designated_Type (Typ);
begin
if Is_Array_Type (DT) and then not Is_Constrained (DT) then
Error_Msg_N
("illegal use of Unrestricted_Access attribute", P);
Error_Msg_N
("\attempt to generate thin pointer to unaliased "
& "object", P);
end if;
end;
end if;
-- Mark that address of entity is taken
if Is_Entity_Name (P) then
Set_Address_Taken (Entity (P));
end if;

18
gcc/ada/sem_res.adb
View File

@ -11799,7 +11799,12 @@ package body Sem_Res is
-- after the return.
elsif Is_Access_Subprogram_Type (Target_Type)
and then No (Corresponding_Remote_Type (Opnd_Type))
-- Note: this test of Ekind (Opnd_Type) is there to prevent entering
-- this branch in the case of a remote access to subprogram type,
-- which is internally represented as an E_Record_Type.
and then Ekind (Opnd_Type) in Access_Kind
then
if Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type
and then Is_Entity_Name (Operand)
@ -11864,7 +11869,7 @@ package body Sem_Res is
return True;
-- Remote subprogram access types
-- Remote access to subprogram types
elsif Is_Remote_Access_To_Subprogram_Type (Target_Type)
and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type)
@ -11872,6 +11877,15 @@ package body Sem_Res is
-- It is valid to convert from one RAS type to another provided
-- that their specification statically match.
-- Note: at this point, remote access to subprogram types have been
-- expanded to their E_Record_Type representation, and we need to
-- go back to the original access type definition using the
-- Corresponding_Remote_Type attribute in order to check that the
-- designated profiles match.
pragma Assert (Ekind (Target_Type) = E_Record_Type);
pragma Assert (Ekind (Opnd_Type) = E_Record_Type);
Check_Subtype_Conformant
(New_Id =>
Designated_Type (Corresponding_Remote_Type (Target_Type)),

1
gcc/ada/sem_util.adb
View File

@ -5045,6 +5045,7 @@ package body Sem_Util is
-- visibility list (see below).
elsif Nkind (Parent (Def_Id)) = N_Full_Type_Declaration
and then Ekind (Def_Id) = E_Record_Type
and then Present (Corresponding_Remote_Type (Def_Id))
then
null;

16
gcc/ada/sinfo.adb
View File

@ -2338,6 +2338,14 @@ package body Sinfo is
return Flag17 (N);
end No_Truncation;
function Non_Aliased_Prefix
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Attribute_Reference);
return Flag18 (N);
end Non_Aliased_Prefix;
function Null_Present
(N : Node_Id) return Boolean is
begin
@ -5487,6 +5495,14 @@ package body Sinfo is
Set_Flag17 (N, Val);
end Set_No_Truncation;
procedure Set_Non_Aliased_Prefix
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Attribute_Reference);
Set_Flag18 (N, Val);
end Set_Non_Aliased_Prefix;
procedure Set_Null_Present
(N : Node_Id; Val : Boolean := True) is
begin

19
gcc/ada/sinfo.ads
View File

@ -1809,6 +1809,13 @@ package Sinfo is
-- is used for properly setting out of range values for use by pragmas
-- Initialize_Scalars and Normalize_Scalars.
-- Non_Aliased_Prefix (Flag18-Sem)
-- Present in N_Attribute_Reference nodes. Set only for the case of an
-- Unrestricted_Access reference whose prefix is non-aliased, which is
-- the case that is permitted for Unrestricted_Access except when the
-- expected type is a thin pointer to unconstrained array. This flag is
-- to assist in detecting this illegal use of Unrestricted_Access.
-- Original_Discriminant (Node2-Sem)
-- Present in identifiers. Used in references to discriminants that
-- appear in generic units. Because the names of the discriminants may be
@ -3621,8 +3628,10 @@ package Sinfo is
-- Associated_Node (Node4-Sem)
-- Do_Overflow_Check (Flag17-Sem)
-- Header_Size_Added (Flag11-Sem)
-- Must_Be_Byte_Aligned (Flag14-Sem)
-- Non_Aliased_Prefix (Flag18-Sem)
-- Redundant_Use (Flag13-Sem)
-- Must_Be_Byte_Aligned (Flag14)
-- plus fields for expression
-- Note: in Modify_Tree_For_C mode, Max and Min attributes are expanded
@ -9242,6 +9251,9 @@ package Sinfo is
function No_Truncation
(N : Node_Id) return Boolean; -- Flag17
function Non_Aliased_Prefix
(N : Node_Id) return Boolean; -- Flag18
function Null_Present
(N : Node_Id) return Boolean; -- Flag13
@ -10244,6 +10256,9 @@ package Sinfo is
procedure Set_No_Truncation
(N : Node_Id; Val : Boolean := True); -- Flag17
procedure Set_Non_Aliased_Prefix
(N : Node_Id; Val : Boolean := True); -- Flag18
procedure Set_Null_Present
(N : Node_Id; Val : Boolean := True); -- Flag13
@ -12510,6 +12525,7 @@ package Sinfo is
pragma Inline (No_Initialization);
pragma Inline (No_Minimize_Eliminate);
pragma Inline (No_Truncation);
pragma Inline (Non_Aliased_Prefix);
pragma Inline (Null_Present);
pragma Inline (Null_Exclusion_Present);
pragma Inline (Null_Exclusion_In_Return_Present);
@ -12840,6 +12856,7 @@ package Sinfo is
pragma Inline (Set_No_Initialization);
pragma Inline (Set_No_Minimize_Eliminate);
pragma Inline (Set_No_Truncation);
pragma Inline (Set_Non_Aliased_Prefix);
pragma Inline (Set_Null_Exclusion_Present);
pragma Inline (Set_Null_Exclusion_In_Return_Present);
pragma Inline (Set_Null_Present);

3
gcc/ada/snames.ads-tmpl
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -1096,6 +1096,7 @@ package Snames is
Name_Access_Check : constant Name_Id := N + $;
Name_Accessibility_Check : constant Name_Id := N + $;
Name_Alignment_Check : constant Name_Id := N + $; -- GNAT
Name_Allocation_Check : constant Name_Id := N + $;
Name_Atomic_Synchronization : constant Name_Id := N + $; -- GNAT
Name_Discriminant_Check : constant Name_Id := N + $;
Name_Division_Check : constant Name_Id := N + $;

31
gcc/ada/types.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, 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- --
@ -665,23 +665,24 @@ package Types is
Access_Check : constant := 1;
Accessibility_Check : constant := 2;
Alignment_Check : constant := 3;
Atomic_Synchronization : constant := 4;
Discriminant_Check : constant := 5;
Division_Check : constant := 6;
Elaboration_Check : constant := 7;
Index_Check : constant := 8;
Length_Check : constant := 9;
Overflow_Check : constant := 10;
Predicate_Check : constant := 11;
Range_Check : constant := 12;
Storage_Check : constant := 13;
Tag_Check : constant := 14;
Validity_Check : constant := 15;
Allocation_Check : constant := 4;
Atomic_Synchronization : constant := 5;
Discriminant_Check : constant := 6;
Division_Check : constant := 7;
Elaboration_Check : constant := 8;
Index_Check : constant := 9;
Length_Check : constant := 10;
Overflow_Check : constant := 11;
Predicate_Check : constant := 12;
Range_Check : constant := 13;
Storage_Check : constant := 14;
Tag_Check : constant := 15;
Validity_Check : constant := 16;
-- Values used to represent individual predefined checks (including the
-- setting of Atomic_Synchronization, which is implemented internally using
-- a "check" whose name is Atomic_Synchronization).
All_Checks : constant := 16;
All_Checks : constant := 17;
-- Value used to represent All_Checks value
subtype Predefined_Check_Id is Check_Id range 1 .. All_Checks;
@ -704,7 +705,7 @@ package Types is
-- To add a new check type to GNAT, the following steps are required:
-- 1. Add an entry to Snames spec and body for the new name
-- 1. Add an entry to Snames spec for the new name
-- 2. Add an entry to the definition of Check_Id above
-- 3. Add a new function to Checks to handle the new check test
-- 4. Add a new Do_xxx_Check flag to Sinfo (if required)