Skip to content

R
riscv-gcc-1
Commit 6dc87f5f by Arnaud Charlet
Options

[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
parent a14bbbb4
Showing with 223 additions and 61 deletions
gcc/ada/ChangeLog
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> 2016-04-21 Javier Miranda <miranda@adacore.com>
* exp_util.adb (Build_Procedure_Form): No action needed for * exp_util.adb (Build_Procedure_Form): No action needed for
......
gcc/ada/exp_ch6.adb
...@@ -706,11 +706,10 @@ package body Exp_Ch6 is ...@@ -706,11 +706,10 @@ package body Exp_Ch6 is
Stmts : List_Id; Stmts : List_Id;
begin begin
-- The extended return may just contain the declaration. -- The extended return may just contain the declaration
if Present (Handled_Statement_Sequence (Stmt)) then if Present (Handled_Statement_Sequence (Stmt)) then
Stmts := Statements (Handled_Statement_Sequence (Stmt)); Stmts := Statements (Handled_Statement_Sequence (Stmt));
else else
Stmts := New_List; Stmts := New_List;
end if; end if;
...@@ -2697,10 +2696,9 @@ package body Exp_Ch6 is ...@@ -2697,10 +2696,9 @@ package body Exp_Ch6 is
-- See for example Expand_Boolean_Operator(). -- See for example Expand_Boolean_Operator().
if not (Comes_From_Source (Call_Node)) if not (Comes_From_Source (Call_Node))
and then Nkind and then Nkind (Unit_Declaration_Node
(Unit_Declaration_Node (Ultimate_Alias (Entity (Name (Call_Node))))) =
(Ultimate_Alias (Entity (Name (Call_Node))))) N_Subprogram_Body
= N_Subprogram_Body
then then
Set_Entity (Name (Call_Node), Set_Entity (Name (Call_Node),
Rewritten_For_C_Func_Id Rewritten_For_C_Func_Id
......
gcc/ada/freeze.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1908,8 +1908,16 @@ package body Freeze is ...@@ -1908,8 +1908,16 @@ package body Freeze is
-- Freeze_Before -- -- Freeze_Before --
------------------- -------------------
procedure Freeze_Before (N : Node_Id; T : Entity_Id) is procedure Freeze_Before
Freeze_Nodes : constant List_Id := Freeze_Entity (T, N); (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 begin
if Ekind (T) = E_Function then if Ekind (T) = E_Function then
...@@ -1925,7 +1933,11 @@ package body Freeze is ...@@ -1925,7 +1933,11 @@ package body Freeze is
-- Freeze_Entity -- -- 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); Loc : constant Source_Ptr := Sloc (N);
Atype : Entity_Id; Atype : Entity_Id;
Comp : Entity_Id; Comp : Entity_Id;
...@@ -4990,12 +5002,13 @@ package body Freeze is ...@@ -4990,12 +5002,13 @@ package body Freeze is
-- In Ada 2012, freezing a subprogram does not always freeze -- In Ada 2012, freezing a subprogram does not always freeze
-- the corresponding profile (see AI05-019). An attribute -- 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 ??? -- Other constructs that should not freeze ???
-- This processing doesn't apply to internal entities (see below) -- 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 if not Freeze_Profile (E) then
Ghost_Mode := Save_Ghost_Mode; Ghost_Mode := Save_Ghost_Mode;
return Result; return Result;
......
gcc/ada/freeze.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -187,13 +187,19 @@ package Freeze is ...@@ -187,13 +187,19 @@ package Freeze is
-- If Initialization_Statements (E) is an N_Compound_Statement, insert its -- If Initialization_Statements (E) is an N_Compound_Statement, insert its
-- actions in the enclosing list and reset the attribute. -- 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 -- 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 -- 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 -- 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 -- 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. -- operation is declared after the freezing point of its tagged type.
-- Returns No_List if no freeze nodes needed. -- 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); procedure Freeze_All (From : Entity_Id; After : in out Node_Id);
-- Before a non-instance body, or at the end of a declarative part, -- Before a non-instance body, or at the end of a declarative part,
...@@ -209,8 +215,13 @@ package Freeze is ...@@ -209,8 +215,13 @@ package Freeze is
-- in the scope. It is used to prevent a quadratic traversal over already -- in the scope. It is used to prevent a quadratic traversal over already
-- frozen entities. -- 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 -- 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); procedure Freeze_Expression (N : Node_Id);
-- Freezes the required entities when the Expression N causes freezing. -- Freezes the required entities when the Expression N causes freezing.
......
gcc/ada/sem_attr.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -10161,18 +10161,20 @@ package body Sem_Attr is ...@@ -10161,18 +10161,20 @@ package body Sem_Attr is
end loop; end loop;
-- If Prefix is a subprogram name, this reference freezes, -- 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 if not In_Spec_Expression then
Freeze_Before (N, Entity (P)); Freeze_Before (N, Entity (P), False);
end if; end if;
-- If it is a type, there is nothing to resolve. If it is an -- If it is a type, there is nothing to resolve.
-- object, complete its resolution. -- If it is a subprogram, do not freeze its profile.
-- If it is an object, complete its resolution.
elsif Is_Overloadable (Entity (P)) then elsif Is_Overloadable (Entity (P)) then
if not In_Spec_Expression then if not In_Spec_Expression then
Freeze_Before (N, Entity (P)); Freeze_Before (N, Entity (P), False);
end if; end if;
-- Nothing to do if prefix is a type name -- Nothing to do if prefix is a type name
......
gcc/ada/sem_aux.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -708,6 +708,29 @@ package body Sem_Aux is ...@@ -708,6 +708,29 @@ package body Sem_Aux is
return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents)); return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents));
end Has_Rep_Item; 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 -- -- Has_Rep_Pragma --
-------------------- --------------------
......
gcc/ada/sem_aux.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -246,6 +246,10 @@ package Sem_Aux is ...@@ -246,6 +246,10 @@ package Sem_Aux is
-- not inherited from its parents, if any). If found then True is returned, -- not inherited from its parents, if any). If found then True is returned,
-- otherwise False indicates that no matching entry was found. -- 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 function Has_Rep_Pragma
(E : Entity_Id; (E : Entity_Id;
Nam : Name_Id; Nam : Name_Id;
......
gcc/ada/sem_ch13.adb
...@@ -3926,7 +3926,8 @@ package body Sem_Ch13 is ...@@ -3926,7 +3926,8 @@ package body Sem_Ch13 is
return; return;
-- A stream subprogram for an interface type must be a null -- 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) elsif Is_Interface (U_Ent)
and then not Is_Class_Wide_Type (U_Ent) and then not Is_Class_Wide_Type (U_Ent)
......
gcc/ada/sem_util.adb
...@@ -10733,57 +10733,143 @@ package body Sem_Util is ...@@ -10733,57 +10733,143 @@ package body Sem_Util is
---------------------------- ----------------------------
procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) 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;
Item : Node_Id := Empty; Next_Item : Node_Id;
Last_Item : Node_Id := Empty;
begin begin
-- Reach the end of the destination type's chain (if any) and capture -- There are several inheritance scenarios to consider depending on
-- the last item. -- 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); -- 1) The source type lacks a rep item chain
while Present (Item) loop -- 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 -- 2) The destination type lacks a rep item chain
return; -- From_Typ ---> Item ---> ...
end if; --
-- Typ --------> Empty
Last_Item := Item; -- Inheritance takes place by setting the First_Rep_Item of the
Item := Next_Rep_Item (Item); -- destination type to the First_Rep_Item of the source type.
end loop; -- 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. -- Inheritance takes place by setting the Next_Rep_Item of the last item
-- items, to prevent circularities when the derivation completes -- of the destination type to the First_Rep_Item of the source type.
-- a private declaration and inherits from both views of the parent. -- From_Typ -------------------> Item ---> Item
-- There may be a remaining problem with the proper ordering of -- ^
-- attribute specifications and aspects on the chains of the four -- Typ --------> Item ---> Item --+
-- entities involved. ???
if Present (Item) and then Present (From_Item) then -- 3.2) Both source and destination types have at least one rep item.
while Present (Item) loop -- The destination type DOES inherit part of the rep item chain of the
if Item = First_Rep_Item (Typ) then -- source type.
return; -- From_Typ ---> Item ---> Item ---> Item
end if; -- ^
-- Typ --------> Item ------+
Item := Next_Rep_Item (Item); -- This rare case arises when the full view of a private extension must
end loop; -- inherit the rep item chain from the full view of its parent type and
end if; -- the full view of the parent type contains extra rep items. Currently
-- only invariants may lead to such form of inheritance.
-- type From_Typ is tagged private
-- with Type_Invariant'Class => Item_2;
-- type Typ is new From_Typ with private
-- with Type_Invariant => Item_4;
-- 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;
-- When the destination type has a rep item chain, the chain of the -- The full view of Typ would have to inherit any new rep items added to
-- source type is appended to it. -- the full view of From_Typ.
if Present (Last_Item) then -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3
Set_Next_Rep_Item (Last_Item, From_Item); -- ^
-- Typ --------> Item_4 --+
-- Otherwise the destination type directly inherits the rep item chain -- To achieve this form of inheritance, the destination type must first
-- of the source type (if any). -- 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 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 if;
end Inherit_Rep_Item_Chain; end Inherit_Rep_Item_Chain;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment