OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2017-04-25  Hristian Kirtchev  <kirtchev@adacore.com>

	* elists.ads, elists.adb (Prepend_Unique_Elmt): New routine.
	* exp_ch3.adb (Freeze_Type): Signal the DIC body is created for
	the purposes of freezing.
	* exp_util.adb Update the documentation and structure of the
	type map used in class-wide semantics of assertion expressions.
	(Add_Inherited_Tagged_DIC): There is really no need to preanalyze
	and resolve the triaged expression because all substitutions
	refer to the proper entities.  Update the replacement of
	references.
	(Build_DIC_Procedure_Body): Add formal parameter
	For_Freeze. Add local variable Build_Body. Inherited DIC pragmas
	are now only processed when freezing occurs.  Build a body only
	when one is needed.
	(Entity_Hash): Removed.
	(Map_Types): New routine.
	(Replace_Object_And_Primitive_References): Removed.
	(Replace_References): New routine.
	(Replace_Type_References): Moved to the library level of Exp_Util.
	(Type_Map_Hash): New routine.
	(Update_Primitives_Mapping): Update the mapping call.
	(Update_Primitives_Mapping_Of_Types): Removed.
	* exp_util.ads (Build_DIC_Procedure_Body): Add formal
	parameter For_Freeze and update the comment on usage.
	(Map_Types): New routine.
	(Replace_References): New routine.
	(Replace_Type_References): Moved to the library level of Exp_Util.
	(Update_Primitives_Mapping_Of_Types): Removed.
	* sem_ch7.adb (Preserve_Full_Attributes): Propagate the DIC
	properties of the private type to the full view in case the full
	view derives from a parent type and inherits a DIC pragma.
	* sem_prag.adb (Analyze_Pragma): Guard against a case where a
	DIC pragma is placed at the top of a declarative region.

2017-04-25  Arnaud Charlet  <charlet@adacore.com trojanek>

	* a-tasatt.adb: Complete previous change and use an unsigned
	int to avoid overflow checks.

2017-04-25  Ed Schonberg  <schonberg@adacore.com>

	* sem_attr.adb (Analyze_Attribute, case 'Access): Specialize
	the error message when the attribute reference is an actual in
	a call to a subprogram inherited from a generic formal type with
	unknown discriminants, which makes the subprogram and its formal
	parameters intrinsic (see RM 6.3.1 (8) and (13)).

From-SVN: r247148
This commit is contained in:
Arnaud Charlet 2017-04-25 10:37:09 +02:00
parent 2bb988bb1c
commit b619c88eba
10 changed files with 1157 additions and 468 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
gcc/ada/ChangeLog
View File

@ -1,3 +1,51 @@
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* elists.ads, elists.adb (Prepend_Unique_Elmt): New routine.
* exp_ch3.adb (Freeze_Type): Signal the DIC body is created for
the purposes of freezing.
* exp_util.adb Update the documentation and structure of the
type map used in class-wide semantics of assertion expressions.
(Add_Inherited_Tagged_DIC): There is really no need to preanalyze
and resolve the triaged expression because all substitutions
refer to the proper entities. Update the replacement of
references.
(Build_DIC_Procedure_Body): Add formal parameter
For_Freeze. Add local variable Build_Body. Inherited DIC pragmas
are now only processed when freezing occurs. Build a body only
when one is needed.
(Entity_Hash): Removed.
(Map_Types): New routine.
(Replace_Object_And_Primitive_References): Removed.
(Replace_References): New routine.
(Replace_Type_References): Moved to the library level of Exp_Util.
(Type_Map_Hash): New routine.
(Update_Primitives_Mapping): Update the mapping call.
(Update_Primitives_Mapping_Of_Types): Removed.
* exp_util.ads (Build_DIC_Procedure_Body): Add formal
parameter For_Freeze and update the comment on usage.
(Map_Types): New routine.
(Replace_References): New routine.
(Replace_Type_References): Moved to the library level of Exp_Util.
(Update_Primitives_Mapping_Of_Types): Removed.
* sem_ch7.adb (Preserve_Full_Attributes): Propagate the DIC
properties of the private type to the full view in case the full
view derives from a parent type and inherits a DIC pragma.
* sem_prag.adb (Analyze_Pragma): Guard against a case where a
DIC pragma is placed at the top of a declarative region.
2017-04-25 Arnaud Charlet <charlet@adacore.com trojanek>
* a-tasatt.adb: Complete previous change and use an unsigned
int to avoid overflow checks.
2017-04-25 Ed Schonberg <schonberg@adacore.com>
* sem_attr.adb (Analyze_Attribute, case 'Access): Specialize
the error message when the attribute reference is an actual in
a call to a subprogram inherited from a generic formal type with
unknown discriminants, which makes the subprogram and its formal
parameters intrinsic (see RM 6.3.1 (8) and (13)).
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* sem_aggr.adb, inline.adb, einfo.adb, einfo.ads, scng.adb,

9
gcc/ada/a-tasatt.adb
View File

@ -93,10 +93,11 @@ package body Ada.Task_Attributes is
function To_Attribute is new
Ada.Unchecked_Conversion (Atomic_Address, Attribute);
type Unsigned is mod 2 ** Integer'Size;
function To_Address is new
Ada.Unchecked_Conversion (Attribute, System.Address);
function To_Int is new
Ada.Unchecked_Conversion (Attribute, Integer);
function To_Unsigned is new
Ada.Unchecked_Conversion (Attribute, Unsigned);
pragma Warnings (On);
@ -121,7 +122,7 @@ package body Ada.Task_Attributes is
Fast_Path : constant Boolean :=
(Attribute'Size = Integer'Size
and then Attribute'Alignment <= Atomic_Address'Alignment
and then To_Int (Initial_Value) = 0)
and then To_Unsigned (Initial_Value) = 0)
or else (Attribute'Size = System.Address'Size
and then Attribute'Alignment <= Atomic_Address'Alignment
and then To_Address (Initial_Value) = System.Null_Address);
@ -303,7 +304,7 @@ package body Ada.Task_Attributes is
-- No finalization needed, simply set to Val
if Attribute'Size = Integer'Size then
TT.Attributes (Index) := Atomic_Address (To_Int (Val));
TT.Attributes (Index) := Atomic_Address (To_Unsigned (Val));
else
TT.Attributes (Index) := To_Address (Val);
end if;

13
gcc/ada/elists.adb
View File

@ -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- --
@ -450,6 +450,17 @@ package body Elists is
Elists.Table (To).First := Elmts.Last;
end Prepend_Elmt;
-------------------------
-- Prepend_Unique_Elmt --
-------------------------
procedure Prepend_Unique_Elmt (N : Node_Or_Entity_Id; To : Elist_Id) is
begin
if not Contains (To, N) then
Prepend_Elmt (N, To);
end if;
end Prepend_Unique_Elmt;
-------------
-- Present --
-------------

6
gcc/ada/elists.ads
View File

@ -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- --
@ -141,6 +141,10 @@ package Elists is
procedure Prepend_Elmt (N : Node_Or_Entity_Id; To : Elist_Id);
-- Appends N at the beginning of To, allocating a new element
procedure Prepend_Unique_Elmt (N : Node_Or_Entity_Id; To : Elist_Id);
-- Like Prepend_Elmt, except that a check is made to see if To already
-- contains N and if so the call has no effect.
procedure Insert_Elmt_After (N : Node_Or_Entity_Id; Elmt : Elmt_Id);
-- Add a new element (N) right after the pre-existing element Elmt
-- It is invalid to call this subprogram with Elmt = No_Elmt.

2
gcc/ada/exp_ch3.adb
View File

@ -7515,7 +7515,7 @@ package body Exp_Ch3 is
-- verification of pragma Default_Initial_Condition's expression.
if Has_DIC (Def_Id) then
Build_DIC_Procedure_Body (Def_Id);
Build_DIC_Procedure_Body (Def_Id, For_Freeze => True);
end if;
-- Generate the [spec and] body of the invariant procedure tasked with

1444
gcc/ada/exp_util.adb
View File

File diff suppressed because it is too large Load Diff

58
gcc/ada/exp_util.ads
View File

@ -278,9 +278,13 @@ package Exp_Util is
-- Build a call to the DIC procedure of type Typ with Obj_Id as the actual
-- parameter.
procedure Build_DIC_Procedure_Body (Typ : Entity_Id);
procedure Build_DIC_Procedure_Body
(Typ : Entity_Id;
For_Freeze : Boolean := False);
-- Create the body of the procedure which verifies the assertion expression
-- of pragma Default_Initial_Condition at run time.
-- of pragma Default_Initial_Condition at run time. Flag For_Freeze should
-- be set when the body is construction as part of the freezing actions for
-- Typ.
procedure Build_DIC_Procedure_Declaration (Typ : Entity_Id);
-- Create the declaration of the procedure which verifies the assertion
@ -870,6 +874,19 @@ package Exp_Util is
-- wide type. Set Related_Id to request an external name for the subtype
-- rather than an internal temporary.
procedure Map_Types (Parent_Type : Entity_Id; Derived_Type : Entity_Id);
-- Establish the following mapping between the attributes of tagged parent
-- type Parent_Type and tagged derived type Derived_Type.
--
-- * Map each discriminant of Parent_Type to ether the corresponding
-- discriminant of Derived_Type or come constraint.
-- * Map each primitive operation of Parent_Type to the corresponding
-- primitive of Derived_Type.
--
-- The mapping Parent_Type -> Derived_Type is also added to the table in
-- order to prevent subsequent attempts of the same mapping.
function Matching_Standard_Type (Typ : Entity_Id) return Entity_Id;
-- Given a scalar subtype Typ, returns a matching type in standard that
-- has the same object size value. For example, a 16 bit signed type will
@ -995,6 +1012,37 @@ package Exp_Util is
-- renaming cannot be elaborated without evaluating the subexpression, so
-- gigi would resort to method 1) or 3) under the hood for them.
procedure Replace_References
(Expr : Node_Id;
Par_Typ : Entity_Id;
Deriv_Typ : Entity_Id;
Par_Obj : Entity_Id := Empty;
Deriv_Obj : Entity_Id := Empty);
-- Expr denotes an arbitrary expression. Par_Typ is a tagged parent type
-- in a type hierarchy. Deriv_Typ is a tagged type derived from Par_Typ
-- with optional ancestors in between. Par_Obj is a formal parameter
-- which emulates the current instance of Par_Typ. Deriv_Obj is a formal
-- parameter which emulates the current instance of Deriv_Typ. Perform the
-- following substitutions in Expr:
--
-- * Replace a reference to Par_Obj with a reference to Deriv_Obj
--
-- * Replace a reference to a discriminant of Par_Typ with a suitable
-- value from the point of view of Deriv_Typ.
--
-- * Replace a call to an overridden primitive of Par_Typ with a call to
-- an overriding primitive of Deriv_Typ.
--
-- * Replace a call to an inherited primitive of Par_Type with a call to
-- the internally-generated inherited primitive of Deriv_Typ.
procedure Replace_Type_References
(Expr : Node_Id;
Typ : Entity_Id;
Obj_Id : Entity_Id);
-- Substitute all references of the current instance of type Typ with
-- references to formal parameter Obj_Id within expression Expr.
function Represented_As_Scalar (T : Entity_Id) return Boolean;
-- Returns True iff the implementation of this type in code generation
-- terms is scalar. This is true for scalars in the Ada sense, and for
@ -1103,12 +1151,6 @@ package Exp_Util is
-- when elaborating a contract for a subprogram, and when freezing a type
-- extension to verify legality rules on inherited conditions.
procedure Update_Primitives_Mapping_Of_Types
(Par_Typ : Entity_Id;
Deriv_Typ : Entity_Id);
-- Map the primitive operations of parent type Par_Typ to the corresponding
-- primitives of derived type Deriv_Typ.
function Within_Case_Or_If_Expression (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N is within a case or an if expression

31
gcc/ada/sem_attr.adb
View File

@ -10532,10 +10532,33 @@ package body Sem_Attr is
if Convention (Designated_Type (Btyp)) /=
Convention (Entity (P))
then
Error_Msg_FE
("subprogram & has wrong convention", P, Entity (P));
Error_Msg_Sloc := Sloc (Btyp);
Error_Msg_FE ("\does not match & declared#", P, Btyp);
-- The rule in 6.3.1 (8) deserves a special error
-- message.
if Convention (Btyp) = Convention_Intrinsic
and then Nkind (Parent (N)) = N_Procedure_Call_Statement
and then Is_Entity_Name (Name (Parent (N)))
and then Inside_A_Generic
then
declare
Subp : constant Entity_Id :=
Entity (Name (Parent (N)));
begin
if Convention (Subp) = Convention_Intrinsic then
Error_Msg_FE ("subprogram and its formal "
& "parameters have convention Intrinsic",
Parent (N), Subp);
Error_Msg_N
("actual cannot be access attribute", N);
end if;
end;
else
Error_Msg_FE
("subprogram & has wrong convention", P, Entity (P));
Error_Msg_Sloc := Sloc (Btyp);
Error_Msg_FE ("\does not match & declared#", P, Btyp);
end if;
if not Is_Itype (Btyp)
and then not Has_Convention_Pragma (Btyp)

5
gcc/ada/sem_ch7.adb
View File

@ -2568,6 +2568,11 @@ package body Sem_Ch7 is
Propagate_DIC_Attributes (Full, From_Typ => Full_Base);
Propagate_DIC_Attributes (Full_Base, From_Typ => Full);
-- Propagate Default_Initial_Condition-related attributes from the
-- full view to the private view.
Propagate_DIC_Attributes (Priv, From_Typ => Full);
-- Propagate invariant-related attributes from the base type of the
-- full view to the full view and vice versa. This may seem strange,
-- but is necessary depending on which type triggered the generation

9
gcc/ada/sem_prag.adb
View File

@ -13839,6 +13839,7 @@ package body Sem_Prag is
Check_No_Identifiers;
Check_At_Most_N_Arguments (1);
Typ := Empty;
Stmt := Prev (N);
while Present (Stmt) loop
@ -13880,6 +13881,14 @@ package body Sem_Prag is
Stmt := Prev (Stmt);
end loop;
-- The pragma does not apply to a legal construct, issue an error
-- and stop the analysis.
if No (Typ) then
Pragma_Misplaced;
return;
end if;
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.