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

[multiple changes] 

2016-04-21  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_aux.ads, sem_aux.adb (Has_Rep_Item): New variant.
	* sem_util.adb (Inherit_Rep_Item_Chain): Reimplemented.

2016-04-21  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch6.adb: Minor reformatting.

2016-04-21  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch13.adb: Minor comment update.

2016-04-21  Ed Schonberg  <schonberg@adacore.com>

	* freeze.ads, freeze.adb (Freeze_Entity, Freeze_Before): Add
	boolean parameter to determine whether freezing an overloadable
	entity freezes its profile as well. This is required by
	AI05-019. The call to Freeze_Profile within Freeze_Entity is
	conditioned by the value of this flag, whose default is True.
	* sem_attr.adb (Resolve_Attribute, case 'Access): The attribute
	reference freezes the prefix, but it the prefix is a subprogram
	it does not freeze its profile.

From-SVN: r235308
This commit is contained in:
Arnaud Charlet 2016-04-21 10:25:21 +02:00
parent a14bbbb4a4
commit 6dc87f5f53
9 changed files with 223 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
gcc/ada/ChangeLog
View File

@ -1,3 +1,27 @@
2016-04-21 Hristian Kirtchev <kirtchev@adacore.com>
* sem_aux.ads, sem_aux.adb (Has_Rep_Item): New variant.
* sem_util.adb (Inherit_Rep_Item_Chain): Reimplemented.
2016-04-21 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch6.adb: Minor reformatting.
2016-04-21 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb: Minor comment update.
2016-04-21 Ed Schonberg <schonberg@adacore.com>
* freeze.ads, freeze.adb (Freeze_Entity, Freeze_Before): Add
boolean parameter to determine whether freezing an overloadable
entity freezes its profile as well. This is required by
AI05-019. The call to Freeze_Profile within Freeze_Entity is
conditioned by the value of this flag, whose default is True.
* sem_attr.adb (Resolve_Attribute, case 'Access): The attribute
reference freezes the prefix, but it the prefix is a subprogram
it does not freeze its profile.
2016-04-21 Javier Miranda <miranda@adacore.com>
* exp_util.adb (Build_Procedure_Form): No action needed for

12
gcc/ada/exp_ch6.adb
View File

@ -706,11 +706,10 @@ package body Exp_Ch6 is
Stmts : List_Id;
begin
-- The extended return may just contain the declaration.
-- The extended return may just contain the declaration
if Present (Handled_Statement_Sequence (Stmt)) then
Stmts := Statements (Handled_Statement_Sequence (Stmt));
Stmts := Statements (Handled_Statement_Sequence (Stmt));
else
Stmts := New_List;
end if;
@ -2697,10 +2696,9 @@ package body Exp_Ch6 is
-- See for example Expand_Boolean_Operator().
if not (Comes_From_Source (Call_Node))
and then Nkind
(Unit_Declaration_Node
(Ultimate_Alias (Entity (Name (Call_Node)))))
= N_Subprogram_Body
and then Nkind (Unit_Declaration_Node
(Ultimate_Alias (Entity (Name (Call_Node))))) =
N_Subprogram_Body
then
Set_Entity (Name (Call_Node),
Rewritten_For_C_Func_Id

25
gcc/ada/freeze.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- --
@ -1908,8 +1908,16 @@ package body Freeze is
-- Freeze_Before --
-------------------
procedure Freeze_Before (N : Node_Id; T : Entity_Id) is
Freeze_Nodes : constant List_Id := Freeze_Entity (T, N);
procedure Freeze_Before
(N : Node_Id;
T : Entity_Id;
F_P : Boolean := True)
is
-- Freeze T, then insert the generated Freeze nodes before the node N.
-- The flag F_P is used when T is an overloadable entity, and indicates
-- whether its profile should be frozen at the same time.
Freeze_Nodes : constant List_Id := Freeze_Entity (T, N, F_P);
begin
if Ekind (T) = E_Function then
@ -1925,7 +1933,11 @@ package body Freeze is
-- Freeze_Entity --
-------------------
function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id is
function Freeze_Entity
(E : Entity_Id;
N : Node_Id;
F_P : Boolean := True) return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
Atype : Entity_Id;
Comp : Entity_Id;
@ -4990,12 +5002,13 @@ package body Freeze is
-- In Ada 2012, freezing a subprogram does not always freeze
-- the corresponding profile (see AI05-019). An attribute
-- reference is not a freezing point of the profile.
-- reference is not a freezing point of the profile. The boolean
-- Flag F_P indicates whether the profile should be frozen now.
-- Other constructs that should not freeze ???
-- This processing doesn't apply to internal entities (see below)
if not Is_Internal (E) then
if not Is_Internal (E) and then F_P then
if not Freeze_Profile (E) then
Ghost_Mode := Save_Ghost_Mode;
return Result;

17
gcc/ada/freeze.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- --
@ -187,13 +187,19 @@ package Freeze is
-- If Initialization_Statements (E) is an N_Compound_Statement, insert its
-- actions in the enclosing list and reset the attribute.
function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id;
function Freeze_Entity
(E : Entity_Id;
N : Node_Id;
F_P : Boolean := True) return List_Id;
-- Freeze an entity, and return Freeze nodes, to be inserted at the point
-- of call. N is a node whose source location corresponds to the freeze
-- point. This is used in placing warning messages in the situation where
-- it appears that a type has been frozen too early, e.g. when a primitive
-- operation is declared after the freezing point of its tagged type.
-- Returns No_List if no freeze nodes needed.
-- The defaulted parameter F_P is used when E is a subprogram, and
-- determines whether the profile of the subprogram should be frozen as
-- well.
procedure Freeze_All (From : Entity_Id; After : in out Node_Id);
-- Before a non-instance body, or at the end of a declarative part,
@ -209,8 +215,13 @@ package Freeze is
-- in the scope. It is used to prevent a quadratic traversal over already
-- frozen entities.
procedure Freeze_Before (N : Node_Id; T : Entity_Id);
procedure Freeze_Before
(N : Node_Id;
T : Entity_Id;
F_P : Boolean := True);
-- Freeze T then Insert the generated Freeze nodes before the node N
-- The flag F_P is used when T is an overloadable entity, and indicates
-- whether its profile should be frozen at the same time.
procedure Freeze_Expression (N : Node_Id);
-- Freezes the required entities when the Expression N causes freezing.

14
gcc/ada/sem_attr.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- --
@ -10161,18 +10161,20 @@ package body Sem_Attr is
end loop;
-- If Prefix is a subprogram name, this reference freezes,
-- but not if within spec expression mode
-- but not if within spec expression mode. The profile of
-- the subprogram is not frozen at this point.
if not In_Spec_Expression then
Freeze_Before (N, Entity (P));
Freeze_Before (N, Entity (P), False);
end if;
-- If it is a type, there is nothing to resolve. If it is an
-- object, complete its resolution.
-- If it is a type, there is nothing to resolve.
-- If it is a subprogram, do not freeze its profile.
-- If it is an object, complete its resolution.
elsif Is_Overloadable (Entity (P)) then
if not In_Spec_Expression then
Freeze_Before (N, Entity (P));
Freeze_Before (N, Entity (P), False);
end if;
-- Nothing to do if prefix is a type name

25
gcc/ada/sem_aux.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- --
@ -708,6 +708,29 @@ package body Sem_Aux is
return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents));
end Has_Rep_Item;
function Has_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is
Item : Node_Id;
begin
pragma Assert
(Nkind_In (N, N_Aspect_Specification,
N_Attribute_Definition_Clause,
N_Enumeration_Representation_Clause,
N_Pragma,
N_Record_Representation_Clause));
Item := First_Rep_Item (E);
while Present (Item) loop
if Item = N then
return True;
end if;
Item := Next_Rep_Item (Item);
end loop;
return False;
end Has_Rep_Item;
--------------------
-- Has_Rep_Pragma --
--------------------

6
gcc/ada/sem_aux.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- --
@ -246,6 +246,10 @@ package Sem_Aux is
-- not inherited from its parents, if any). If found then True is returned,
-- otherwise False indicates that no matching entry was found.
function Has_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean;
-- Determine whether the Rep_Item chain of arbitrary entity E contains item
-- N. N must denote a valid rep item.
function Has_Rep_Pragma
(E : Entity_Id;
Nam : Name_Id;

3
gcc/ada/sem_ch13.adb
View File

@ -3926,7 +3926,8 @@ package body Sem_Ch13 is
return;
-- A stream subprogram for an interface type must be a null
-- procedure (RM 13.13.2 (38/3)).
-- procedure (RM 13.13.2 (38/3)). Note that the class-wide type
-- of an interface is not an interface type (3.9.4 (6.b/2)).
elsif Is_Interface (U_Ent)
and then not Is_Class_Wide_Type (U_Ent)

158
gcc/ada/sem_util.adb
View File

@ -10733,57 +10733,143 @@ package body Sem_Util is
----------------------------
procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is
From_Item : constant Node_Id := First_Rep_Item (From_Typ);
Item : Node_Id := Empty;
Last_Item : Node_Id := Empty;
Item : Node_Id;
Next_Item : Node_Id;
begin
-- Reach the end of the destination type's chain (if any) and capture
-- the last item.
-- There are several inheritance scenarios to consider depending on
-- whether both types have rep item chains and whether the destination
-- type already inherits part of the source type's rep item chain.
Item := First_Rep_Item (Typ);
while Present (Item) loop
-- 1) The source type lacks a rep item chain
-- From_Typ ---> Empty
--
-- Typ --------> Item (or Empty)
-- Do not inherit a chain that has been inherited already
-- In this case inheritance cannot take place because there are no items
-- to inherit.
if Item = From_Item then
return;
end if;
-- 2) The destination type lacks a rep item chain
-- From_Typ ---> Item ---> ...
--
-- Typ --------> Empty
Last_Item := Item;
Item := Next_Rep_Item (Item);
end loop;
-- Inheritance takes place by setting the First_Rep_Item of the
-- destination type to the First_Rep_Item of the source type.
-- From_Typ ---> Item ---> ...
-- ^
-- Typ -----------+
Item := First_Rep_Item (From_Typ);
-- 3.1) Both source and destination types have at least one rep item.
-- The destination type does NOT inherit a rep item from the source
-- type.
-- From_Typ ---> Item ---> Item
--
-- Typ --------> Item ---> Item
-- Additional check when both parent and current type have rep.
-- items, to prevent circularities when the derivation completes
-- a private declaration and inherits from both views of the parent.
-- There may be a remaining problem with the proper ordering of
-- attribute specifications and aspects on the chains of the four
-- entities involved. ???
-- Inheritance takes place by setting the Next_Rep_Item of the last item
-- of the destination type to the First_Rep_Item of the source type.
-- From_Typ -------------------> Item ---> Item
-- ^
-- Typ --------> Item ---> Item --+
if Present (Item) and then Present (From_Item) then
while Present (Item) loop
if Item = First_Rep_Item (Typ) then
return;
end if;
-- 3.2) Both source and destination types have at least one rep item.
-- The destination type DOES inherit part of the rep item chain of the
-- source type.
-- From_Typ ---> Item ---> Item ---> Item
-- ^
-- Typ --------> Item ------+
Item := Next_Rep_Item (Item);
end loop;
end if;
-- This rare case arises when the full view of a private extension must
-- inherit the rep item chain from the full view of its parent type and
-- the full view of the parent type contains extra rep items. Currently
-- only invariants may lead to such form of inheritance.
-- When the destination type has a rep item chain, the chain of the
-- source type is appended to it.
-- type From_Typ is tagged private
-- with Type_Invariant'Class => Item_2;
if Present (Last_Item) then
Set_Next_Rep_Item (Last_Item, From_Item);
-- type Typ is new From_Typ with private
-- with Type_Invariant => Item_4;
-- Otherwise the destination type directly inherits the rep item chain
-- of the source type (if any).
-- At this point the rep item chains contain the following items
-- From_Typ -----------> Item_2 ---> Item_3
-- ^
-- Typ --------> Item_4 --+
-- The full views of both types may introduce extra invariants
-- type From_Typ is tagged null record
-- with Type_Invariant => Item_1;
-- type Typ is new From_Typ with null record;
-- The full view of Typ would have to inherit any new rep items added to
-- the full view of From_Typ.
-- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3
-- ^
-- Typ --------> Item_4 --+
-- To achieve this form of inheritance, the destination type must first
-- sever the link between its own rep chain and that of the source type,
-- then inheritance 3.1 takes place.
-- Case 1: The source type lacks a rep item chain
if No (First_Rep_Item (From_Typ)) then
return;
-- Case 2: The destination type lacks a rep item chain
elsif No (First_Rep_Item (Typ)) then
Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ));
-- Case 3: Both the source and destination types have at least one rep
-- item. Traverse the rep item chain of the destination type to find the
-- last rep item.
else
Set_First_Rep_Item (Typ, From_Item);
Item := Empty;
Next_Item := First_Rep_Item (Typ);
while Present (Next_Item) loop
-- Detect a link between the destination type's rep chain and that
-- of the source type. There are two possibilities:
-- Variant 1
-- Next_Item
-- V
-- From_Typ ---> Item_1 --->
-- ^
-- Typ -----------+
--
-- Item is Empty
-- Variant 2
-- Next_Item
-- V
-- From_Typ ---> Item_1 ---> Item_2 --->
-- ^
-- Typ --------> Item_3 ------+
-- ^
-- Item
if Has_Rep_Item (From_Typ, Next_Item) then
exit;
end if;
Item := Next_Item;
Next_Item := Next_Rep_Item (Next_Item);
end loop;
-- Inherit the source type's rep item chain
if Present (Item) then
Set_Next_Rep_Item (Item, First_Rep_Item (From_Typ));
else
Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ));
end if;
end if;
end Inherit_Rep_Item_Chain;