diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 24 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 25 | ||||
| -rw-r--r-- | gcc/ada/freeze.ads | 17 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/sem_aux.adb | 25 | ||||
| -rw-r--r-- | gcc/ada/sem_aux.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 158 |
9 files changed, 223 insertions, 61 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c349a060dea..c44e72cd2f4 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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 diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index d084c379123..ff9530b931f 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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 diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 572b194e687..f5e114a0cab 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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; diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads index f11347d5ed0..d95038152fc 100644 --- a/gcc/ada/freeze.ads +++ b/gcc/ada/freeze.ads @@ -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. diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index e8483b9eebd..099a1b84bc3 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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 diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 79a3b9996a0..b9aa2df04a0 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -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 -- -------------------- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index ba60284daac..97a4f142d0f 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -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; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 352742aeae3..0fe36354644 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0702cc71970..a10671144bf 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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. + + -- 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; |