+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
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;
-- 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
-- --
-- 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- --
-- 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
-- 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;
-- 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;
-- --
-- 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- --
-- 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,
-- 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.
-- --
-- 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- --
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
-- --
-- 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- --
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 --
--------------------
-- --
-- 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- --
-- 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;
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)
----------------------------
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.
+
+ -- 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
- -- source type is appended to it.
+ -- The full view of Typ would have to inherit any new rep items added to
+ -- the full view of From_Typ.
- if Present (Last_Item) then
- Set_Next_Rep_Item (Last_Item, From_Item);
+ -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3
+ -- ^
+ -- Typ --------> Item_4 --+
- -- Otherwise the destination type directly inherits the rep item chain
- -- of the source type (if any).
+ -- 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;
projects / gcc.git / commitdiff