[multiple changes]

2010-10-08  Robert Dewar  <dewar@adacore.com>

	* sem_ch6.adb: Minor reformatting.

2010-10-08  Robert Dewar  <dewar@adacore.com>

	* gnat1drv.adb: Add call to Validate_Independence.
	* par-prag.adb: Add dummy entries for Independent,
	Independent_Componentsa.
	* sem_ch13.adb (Validate_Independence): New procedure
	(Initialize): Initialize address clause and independence check tables
	* sem_ch13.ads (Independence_Checks): New table
	(Validate_Independence): New procedure
	* sem_prag.adb: Add processing for pragma Independent[_Components]
	* snames.ads-tmpl: Add entries for pragma Independent[_Components]

2010-10-08  Ed Schonberg  <schonberg@adacore.com>

	* sem_aggr.adb (Propagate_Discriminants): When expanding an aggregate
	component with box initialization, if the component is a variant record
	use the values of the discriminants to select the proper variant for
	further box initialization.

From-SVN: r165162
This commit is contained in:
Arnaud Charlet 2010-10-08 12:51:09 +02:00
parent fd02e833d8
commit 105b5e659a
9 changed files with 556 additions and 36 deletions

View File

@ -1,3 +1,26 @@
2010-10-08 Robert Dewar <dewar@adacore.com>
* sem_ch6.adb: Minor reformatting.
2010-10-08 Robert Dewar <dewar@adacore.com>
* gnat1drv.adb: Add call to Validate_Independence.
* par-prag.adb: Add dummy entries for Independent,
Independent_Componentsa.
* sem_ch13.adb (Validate_Independence): New procedure
(Initialize): Initialize address clause and independence check tables
* sem_ch13.ads (Independence_Checks): New table
(Validate_Independence): New procedure
* sem_prag.adb: Add processing for pragma Independent[_Components]
* snames.ads-tmpl: Add entries for pragma Independent[_Components]
2010-10-08 Ed Schonberg <schonberg@adacore.com>
* sem_aggr.adb (Propagate_Discriminants): When expanding an aggregate
component with box initialization, if the component is a variant record
use the values of the discriminants to select the proper variant for
further box initialization.
2010-10-08 Thomas Quinot <quinot@adacore.com>
* xsnames.adb: Remove obsolete file.

View File

@ -704,6 +704,7 @@ begin
Treepr.Tree_Dump;
Sem_Ch13.Validate_Unchecked_Conversions;
Sem_Ch13.Validate_Address_Clauses;
Sem_Ch13.Validate_Independence;
Errout.Output_Messages;
Namet.Finalize;
@ -880,6 +881,7 @@ begin
Sem_Ch13.Validate_Unchecked_Conversions;
Sem_Ch13.Validate_Address_Clauses;
Sem_Ch13.Validate_Independence;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Treepr.Tree_Dump;
@ -913,6 +915,7 @@ begin
then
Sem_Ch13.Validate_Unchecked_Conversions;
Sem_Ch13.Validate_Address_Clauses;
Sem_Ch13.Validate_Independence;
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
Write_ALI (Object => False);
@ -980,6 +983,11 @@ begin
Sem_Ch13.Validate_Address_Clauses;
-- Validate independence pragmas (again using values annotated by
-- the back end for component layout etc.)
Sem_Ch13.Validate_Independence;
-- Now we complete output of errors, rep info and the tree info. These
-- are delayed till now, since it is perfectly possible for gigi to
-- generate errors, modify the tree (in particular by setting flags

View File

@ -1131,6 +1131,8 @@ begin
Pragma_Import_Object |
Pragma_Import_Procedure |
Pragma_Import_Valued_Procedure |
Pragma_Independent |
Pragma_Independent_Components |
Pragma_Initialize_Scalars |
Pragma_Inline |
Pragma_Inline_Always |

View File

@ -3570,8 +3570,7 @@ package body Sem_Aggr is
procedure Propagate_Discriminants
(Aggr : Node_Id;
Assoc_List : List_Id;
Comp : Entity_Id);
Assoc_List : List_Id);
-- Nested components may themselves be discriminated
-- types constrained by outer discriminants, whose
-- values must be captured before the aggregate is
@ -3653,42 +3652,95 @@ package body Sem_Aggr is
procedure Propagate_Discriminants
(Aggr : Node_Id;
Assoc_List : List_Id;
Comp : Entity_Id)
Assoc_List : List_Id)
is
Inner_Comp : Entity_Id;
Comp_Type : Entity_Id;
Aggr_Type : constant Entity_Id :=
Base_Type (Etype (Aggr));
Def_Node : constant Node_Id :=
Type_Definition (Declaration_Node (Aggr_Type));
Comp : Node_Id;
Comp_Elmt : Elmt_Id;
Components : constant Elist_Id := New_Elmt_List;
Needs_Box : Boolean := False;
New_Aggr : Node_Id;
Errors : Boolean;
begin
Inner_Comp := First_Component (Etype (Comp));
while Present (Inner_Comp) loop
Comp_Type := Etype (Inner_Comp);
procedure Process_Component (Comp : Entity_Id);
-- Add one component with a box association to the
-- inner aggregate, and recurse if component is
-- itself composite.
if Is_Record_Type (Comp_Type)
and then Has_Discriminants (Comp_Type)
------------------------
-- Process_Component --
------------------------
procedure Process_Component (Comp : Entity_Id) is
T : constant Entity_Id := Etype (Comp);
New_Aggr : Node_Id;
begin
if Is_Record_Type (T)
and then Has_Discriminants (T)
then
New_Aggr :=
Make_Aggregate (Loc, New_List, New_List);
Set_Etype (New_Aggr, Comp_Type);
Set_Etype (New_Aggr, T);
Add_Association
(Inner_Comp, New_Aggr,
Component_Associations (Aggr));
(Comp, New_Aggr,
Component_Associations (Aggr));
-- Collect discriminant values and recurse
Add_Discriminant_Values
(New_Aggr, Assoc_List);
Propagate_Discriminants
(New_Aggr, Assoc_List, Inner_Comp);
(New_Aggr, Assoc_List);
else
Needs_Box := True;
end if;
end Process_Component;
Next_Component (Inner_Comp);
end loop;
begin
-- The component type may be a variant type, so
-- collect the components that are ruled by the
-- known values of the discriminants.
if Nkind (Def_Node) = N_Record_Definition
and then
Present (Component_List (Def_Node))
and then
Present
(Variant_Part (Component_List (Def_Node)))
then
Gather_Components (Aggr_Type,
Component_List (Def_Node),
Governed_By => Assoc_List,
Into => Components,
Report_Errors => Errors);
Comp_Elmt := First_Elmt (Components);
while Present (Comp_Elmt) loop
if
Ekind (Node (Comp_Elmt)) /= E_Discriminant
then
Process_Component (Node (Comp_Elmt));
end if;
Next_Elmt (Comp_Elmt);
end loop;
-- No variant part, iterate over all components
else
Comp := First_Component (Etype (Aggr));
while Present (Comp) loop
Process_Component (Comp);
Next_Component (Comp);
end loop;
end if;
if Needs_Box then
Append
@ -3701,6 +3753,8 @@ package body Sem_Aggr is
end if;
end Propagate_Discriminants;
-- Start of processing for Capture_Discriminants
begin
Expr := Make_Aggregate (Loc, New_List, New_List);
Set_Etype (Expr, Ctyp);
@ -3713,14 +3767,13 @@ package body Sem_Aggr is
if Has_Discriminants (Typ) then
Add_Discriminant_Values (Expr, New_Assoc_List);
Propagate_Discriminants
(Expr, New_Assoc_List, Component);
Propagate_Discriminants (Expr, New_Assoc_List);
elsif Has_Discriminants (Ctyp) then
Add_Discriminant_Values
(Expr, Component_Associations (Expr));
Propagate_Discriminants
(Expr, Component_Associations (Expr), Component);
(Expr, Component_Associations (Expr));
else
declare

View File

@ -52,7 +52,6 @@ with Sem_Warn; use Sem_Warn;
with Snames; use Snames;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Table;
with Targparm; use Targparm;
with Ttypes; use Ttypes;
with Tbuild; use Tbuild;
@ -4174,6 +4173,8 @@ package body Sem_Ch13 is
procedure Initialize is
begin
Address_Clause_Checks.Init;
Independence_Checks.Init;
Unchecked_Conversions.Init;
end Initialize;
@ -5069,6 +5070,292 @@ package body Sem_Ch13 is
end loop;
end Validate_Address_Clauses;
---------------------------
-- Validate_Independence --
---------------------------
procedure Validate_Independence is
SU : constant Uint := UI_From_Int (System_Storage_Unit);
N : Node_Id;
E : Entity_Id;
IC : Boolean;
Comp : Entity_Id;
Addr : Node_Id;
P : Node_Id;
procedure Check_Array_Type (Atyp : Entity_Id);
-- Checks if the array type Atyp has independent components, and
-- if not, outputs an appropriate set of error messages.
procedure No_Independence;
-- Output message that independence cannot be guaranteed
function OK_Component (C : Entity_Id) return Boolean;
-- Checks one component to see if it is independently accessible, and
-- if so yields True, otherwise yields False if independent access
-- cannot be guaranteed. This is a conservative routine, it only
-- returns True if it knows for sure, it returns False if it knows
-- there is a problem, or it cannot be sure there is no problem.
procedure Reason_Bad_Component (C : Entity_Id);
-- Outputs continuation message if a reason can be determined for
-- the component C being bad.
----------------------
-- Check_Array_Type --
----------------------
procedure Check_Array_Type (Atyp : Entity_Id) is
Ctyp : constant Entity_Id := Component_Type (Atyp);
begin
-- OK if no alignment clause, no pack, and no component size
if not Has_Component_Size_Clause (Atyp)
and then not Has_Alignment_Clause (Atyp)
and then not Is_Packed (Atyp)
then
return;
end if;
-- Check actual component size
if not Known_Component_Size (Atyp)
or else not (Addressable (Component_Size (Atyp))
and then Component_Size (Atyp) < 64)
or else Component_Size (Atyp) mod Esize (Ctyp) /= 0
then
No_Independence;
-- Bad component size, check reason
if Has_Component_Size_Clause (Atyp) then
P :=
Get_Attribute_Definition_Clause
(Atyp, Attribute_Component_Size);
if Present (P) then
Error_Msg_Sloc := Sloc (P);
Error_Msg_N ("\because of Component_Size clause#", N);
return;
end if;
end if;
if Is_Packed (Atyp) then
P := Get_Rep_Pragma (Atyp, Name_Pack);
if Present (P) then
Error_Msg_Sloc := Sloc (P);
Error_Msg_N ("\because of pragma Pack#", N);
return;
end if;
end if;
-- No reason found, just return
return;
end if;
-- Array type is OK independence-wise
return;
end Check_Array_Type;
---------------------
-- No_Independence --
---------------------
procedure No_Independence is
begin
if Pragma_Name (N) = Name_Independent then
Error_Msg_NE
("independence cannot be guaranteed for&", N, E);
else
Error_Msg_NE
("independent components cannot be guaranteed for&", N, E);
end if;
end No_Independence;
------------------
-- OK_Component --
------------------
function OK_Component (C : Entity_Id) return Boolean is
Rec : constant Entity_Id := Scope (C);
Ctyp : constant Entity_Id := Etype (C);
begin
-- OK if no component clause, no Pack, and no alignment clause
if No (Component_Clause (C))
and then not Is_Packed (Rec)
and then not Has_Alignment_Clause (Rec)
then
return True;
end if;
-- Here we look at the actual component layout. A component is
-- addressable if its size is a multiple of the Esize of the
-- component type, and its starting position in the record has
-- appropriate alignment, and the record itself has appropriate
-- alignment to guarantee the component alignment.
-- Make sure sizes are static, always assume the worst for any
-- cases where we cannot check static values.
if not (Known_Static_Esize (C)
and then Known_Static_Esize (Ctyp))
then
return False;
end if;
-- Size of component must be addressable or greater than 64 bits
-- and a multiple of bytes.
if not Addressable (Esize (C))
and then Esize (C) < Uint_64
then
return False;
end if;
-- Check size is proper multiple
if Esize (C) mod Esize (Ctyp) /= 0 then
return False;
end if;
-- Check alignment of component is OK
if not Known_Component_Bit_Offset (C)
or else Component_Bit_Offset (C) < Uint_0
or else Component_Bit_Offset (C) mod Esize (Ctyp) /= 0
then
return False;
end if;
-- Check alignment of record type is OK
if not Known_Alignment (Rec)
or else (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0
then
return False;
end if;
-- All tests passed, component is addressable
return True;
end OK_Component;
--------------------------
-- Reason_Bad_Component --
--------------------------
procedure Reason_Bad_Component (C : Entity_Id) is
Rec : constant Entity_Id := Scope (C);
Ctyp : constant Entity_Id := Etype (C);
begin
-- If component clause present assume that's the problem
if Present (Component_Clause (C)) then
Error_Msg_Sloc := Sloc (Component_Clause (C));
Error_Msg_N ("\because of Component_Clause#", N);
return;
end if;
-- If pragma Pack clause present, assume that's the problem
if Is_Packed (Rec) then
P := Get_Rep_Pragma (Rec, Name_Pack);
if Present (P) then
Error_Msg_Sloc := Sloc (P);
Error_Msg_N ("\because of pragma Pack#", N);
return;
end if;
end if;
-- See if record has bad alignment clause
if Has_Alignment_Clause (Rec)
and then Known_Alignment (Rec)
and then (Alignment (Rec) * SU) mod Esize (Ctyp) /= 0
then
P := Get_Attribute_Definition_Clause (Rec, Attribute_Alignment);
if Present (P) then
Error_Msg_Sloc := Sloc (P);
Error_Msg_N ("\because of Alignment clause#", N);
end if;
end if;
-- Couldn't find a reason, so return without a message
return;
end Reason_Bad_Component;
-- Start of processing for Validate_Independence
begin
for J in Independence_Checks.First .. Independence_Checks.Last loop
N := Independence_Checks.Table (J).N;
E := Independence_Checks.Table (J).E;
IC := Pragma_Name (N) = Name_Independent_Components;
-- Deal with component case
if Ekind (E) = E_Discriminant or else Ekind (E) = E_Component then
if not OK_Component (E) then
No_Independence;
Reason_Bad_Component (E);
goto Continue;
end if;
end if;
-- Deal with record with Independent_Components
if IC and then Is_Record_Type (E) then
Comp := First_Component_Or_Discriminant (E);
while Present (Comp) loop
if not OK_Component (Comp) then
No_Independence;
Reason_Bad_Component (Comp);
goto Continue;
end if;
Next_Component_Or_Discriminant (Comp);
end loop;
end if;
-- Deal with address clause case
if Is_Object (E) then
Addr := Address_Clause (E);
if Present (Addr) then
No_Independence;
Error_Msg_Sloc := Sloc (Addr);
Error_Msg_N ("\because of Address clause#", N);
goto Continue;
end if;
end if;
-- Deal with independent components for array type
if IC and then Is_Array_Type (E) then
Check_Array_Type (E);
end if;
-- Deal with independent components for array object
if IC and then Is_Object (E) and then Is_Array_Type (Etype (E)) then
Check_Array_Type (Etype (E));
end if;
<<Continue>> null;
end loop;
end Validate_Independence;
-----------------------------------
-- Validate_Unchecked_Conversion --
-----------------------------------

View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Table;
with Types; use Types;
with Uintp; use Uintp;
@ -167,10 +168,10 @@ package Sem_Ch13 is
-- back end as required.
procedure Validate_Unchecked_Conversions;
-- This routine is called after calling the backend to validate
-- unchecked conversions for size and alignment appropriateness.
-- The reason it is called that late is to take advantage of any
-- back-annotation of size and alignment performed by the backend.
-- This routine is called after calling the backend to validate unchecked
-- conversions for size and alignment appropriateness. The reason it is
-- called that late is to take advantage of any back-annotation of size
-- and alignment performed by the backend.
procedure Validate_Address_Clauses;
-- This is called after the back end has been called (and thus after the
@ -178,4 +179,34 @@ package Sem_Ch13 is
-- table of saved address clauses checking for suspicious alignments and
-- if necessary issuing warnings.
procedure Validate_Independence;
-- This is called after the back end has been called (and thus after the
-- layout of components has been back annotated). It goes through the
-- table of saved pragma Independent[_Component] entries, checking that
-- independence can be achieved, and if necessary issuing error mssags.
-------------------------------------
-- Table for Validate_Independence --
-------------------------------------
-- If a legal pragma Independent or Independent_Components is given for
-- an entity, then an entry is made in this table, to be checked by a
-- call to Validate_Independence after back annotation of layout is done.
type Independence_Check_Record is record
N : Node_Id;
-- The pragma Independent or Independent_Components
E : Entity_Id;
-- The entity to which it applies
end record;
package Independence_Checks is new Table.Table (
Table_Component_Type => Independence_Check_Record,
Table_Index_Type => Int,
Table_Low_Bound => 1,
Table_Initial => 20,
Table_Increment => 200,
Table_Name => "Independence_Checks");
end Sem_Ch13;

View File

@ -620,8 +620,7 @@ package body Sem_Ch6 is
Subtype_Ind);
end if;
-- AI05-103 : for elementary types, subtypes must statically
-- match.
-- AI05-103: for elementary types, subtypes must statically match
if Is_Constrained (R_Type)
or else Is_Access_Type (R_Type)

View File

@ -8378,6 +8378,113 @@ package body Sem_Prag is
Arg_First_Optional_Parameter => First_Optional_Parameter);
end Import_Valued_Procedure;
-----------------
-- Independent --
-----------------
-- pragma Independent (LOCAL_NAME);
when Pragma_Independent => Independent : declare
E_Id : Node_Id;
E : Entity_Id;
D : Node_Id;
K : Node_Kind;
begin
Check_Ada_83_Warning;
Ada_2012_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
E_Id := Expression (Arg1);
if Etype (E_Id) = Any_Type then
return;
end if;
E := Entity (E_Id);
D := Declaration_Node (E);
K := Nkind (D);
if Is_Type (E) then
if Rep_Item_Too_Early (E, N)
or else
Rep_Item_Too_Late (E, N)
then
return;
else
Check_First_Subtype (Arg1);
end if;
elsif K = N_Object_Declaration
or else (K = N_Component_Declaration
and then Original_Record_Component (E) = E)
then
if Rep_Item_Too_Late (E, N) then
return;
end if;
else
Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1);
end if;
Independence_Checks.Append ((N, E));
end Independent;
----------------------------
-- Independent_Components --
----------------------------
-- pragma Atomic_Components (array_LOCAL_NAME);
-- This processing is shared by Volatile_Components
when Pragma_Independent_Components => Independent_Components : declare
E_Id : Node_Id;
E : Entity_Id;
D : Node_Id;
K : Node_Kind;
begin
Check_Ada_83_Warning;
Ada_2012_Pragma;
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
E_Id := Expression (Arg1);
if Etype (E_Id) = Any_Type then
return;
end if;
E := Entity (E_Id);
if Rep_Item_Too_Early (E, N)
or else
Rep_Item_Too_Late (E, N)
then
return;
end if;
D := Declaration_Node (E);
K := Nkind (D);
if (K = N_Full_Type_Declaration
and then (Is_Array_Type (E) or else Is_Record_Type (E)))
or else
((Ekind (E) = E_Constant or else Ekind (E) = E_Variable)
and then Nkind (D) = N_Object_Declaration
and then Nkind (Object_Definition (D)) =
N_Constrained_Array_Definition)
then
Independence_Checks.Append ((N, E));
else
Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
end if;
end Independent_Components;
------------------------
-- Initialize_Scalars --
------------------------
@ -12971,6 +13078,8 @@ package body Sem_Prag is
Pragma_Import_Object => 0,
Pragma_Import_Procedure => 0,
Pragma_Import_Valued_Procedure => 0,
Pragma_Independent => 0,
Pragma_Independent_Components => 0,
Pragma_Initialize_Scalars => -1,
Pragma_Inline => 0,
Pragma_Inline_Always => 0,

View File

@ -312,9 +312,13 @@ package Snames is
-- may be found in the appropriate section in unit Sem_Prag in file
-- sem-prag.adb, and they are documented in the GNAT reference manual.
-- The entries marked Ada05 are Ada 2005 pragmas. They are implemented in
-- Ada 83 and Ada 95 mode as well, where they are technically considered to
-- be implementation dependent pragmas.
-- The entries marked Ada 05 are Ada 2005 pragmas. They are implemented
-- in Ada 83 and Ada 95 mode as well, where they are technically considered
-- to be implementation dependent pragmas.
-- The entries marked Ada 12 are Ada 2012 pragmas. They are implemented
-- in Ada 83, Ada 95, and Ada 2005 mode as well, where they are technically
-- considered to be implementation dependent pragmas.
-- The entries marked VMS are VMS specific pragmas that are recognized
-- only in OpenVMS versions of GNAT. They are ignored in other versions
@ -407,7 +411,7 @@ package Snames is
Name_All_Calls_Remote : constant Name_Id := N + $;
Name_Annotate : constant Name_Id := N + $; -- GNAT
-- Note: AST_Entry is not in this list because its name matches -- VMS
-- Note: AST_Entry is not in this list because its name matches -- VMS
-- the name of the corresponding attribute. However, it is
-- included in the definition of the type Pragma_Id, and the
-- functions Get_Pragma_Id and Is_Pragma_Id correctly recognize
@ -452,13 +456,15 @@ package Snames is
Name_Import_Object : constant Name_Id := N + $; -- GNAT
Name_Import_Procedure : constant Name_Id := N + $; -- GNAT
Name_Import_Valued_Procedure : constant Name_Id := N + $; -- GNAT
Name_Independent : constant Name_Id := N + $; -- Ada 12
Name_Independent_Components : constant Name_Id := N + $; -- Ada 12
Name_Inline : constant Name_Id := N + $;
Name_Inline_Always : constant Name_Id := N + $; -- GNAT
Name_Inline_Generic : constant Name_Id := N + $; -- GNAT
Name_Inspection_Point : constant Name_Id := N + $;
-- Note: Interface is not in this list because its name -- GNAT
-- matches an Ada 2005 keyword. However it is included in
-- matches an Ada 05 keyword. However it is included in
-- the definition of the type Attribute_Id, and the functions
-- Get_Pragma_Id and Is_Pragma_Id correctly recognize and
-- process Name_Storage_Size.
@ -1172,7 +1178,7 @@ package Snames is
Name_Unaligned_Valid : constant Name_Id := N + $;
-- Ada 2005 reserved words
-- Ada 05 reserved words
First_2005_Reserved_Word : constant Name_Id := N + $;
Name_Interface : constant Name_Id := N + $;
@ -1531,6 +1537,8 @@ package Snames is
Pragma_Import_Object,
Pragma_Import_Procedure,
Pragma_Import_Valued_Procedure,
Pragma_Independent,
Pragma_Independent_Components,
Pragma_Inline,
Pragma_Inline_Always,
Pragma_Inline_Generic,