From: Arnaud Charlet Date: Tue, 25 Apr 2017 12:05:53 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=904a2ae4e30147cebb7eedad48d76f8bda9e3080;p=gcc.git [multiple changes] 2017-04-25 Ed Schonberg * sem_ch3.adb (Derive_Subprogram): Implement rule in RM 6.1.1 (10-15): if derived type T with progenitors is abstract, and primitive P of this type inherits non-trivial classwide preconditions from both a parent operation and from an interface operation, then the inherited operation is abstract if the parent operation is not null. * sem_disp.ads, sem_disp.adb: replace function Covers_Some_Interface with Covered_Interface_Op to yield the actual interface operation that is implemented by a given inherited operation. 2017-04-25 Javier Miranda * exp_ch4.adb (Expand_N_Op_Expon): Relocate left and right operands after performing the validity checks. Required because validity checks may remove side effects from the operands. 2017-04-25 Javier Miranda * exp_attr.adb (Attribute_Unrestricted_Access): Do not disable implicit type conversion. Required to generate code that displaces the pointer to reference the secondary dispatch table. 2017-04-25 Pascal Obry * prj-attr.adb, snames.ads-tmpl: Add package Install's Required_Artifacts attribute. From-SVN: r247202 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e5f69a10e85..e1cc3fc8ceb 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,33 @@ +2017-04-25 Ed Schonberg + + * sem_ch3.adb (Derive_Subprogram): Implement rule in RM 6.1.1 + (10-15): if derived type T with progenitors is abstract, + and primitive P of this type inherits non-trivial classwide + preconditions from both a parent operation and from an interface + operation, then the inherited operation is abstract if the parent + operation is not null. + * sem_disp.ads, sem_disp.adb: replace function Covers_Some_Interface + with Covered_Interface_Op to yield the actual interface operation + that is implemented by a given inherited operation. + +2017-04-25 Javier Miranda + + * exp_ch4.adb (Expand_N_Op_Expon): Relocate left + and right operands after performing the validity checks. Required + because validity checks may remove side effects from the operands. + +2017-04-25 Javier Miranda + + * exp_attr.adb (Attribute_Unrestricted_Access): + Do not disable implicit type conversion. Required to generate + code that displaces the pointer to reference the secondary + dispatch table. + +2017-04-25 Pascal Obry + + * prj-attr.adb, snames.ads-tmpl: Add package Install's + Required_Artifacts attribute. + 2017-04-25 Ed Schonberg * sem_util.adb (Same_Value): String literals are compile-time diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index c1bda8f0442..ac252cdbf69 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -2114,10 +2114,9 @@ package body Exp_Attr is (Etype (Prefix (Ref_Object)))); begin -- No implicit conversion required if designated types - -- match, or if we have an unrestricted access. + -- match. if Obj_DDT /= Btyp_DDT - and then Id /= Attribute_Unrestricted_Access and then not (Is_Class_Wide_Type (Obj_DDT) and then Etype (Obj_DDT) = Btyp_DDT) then diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index ec2251121bb..a6e1785991b 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7619,10 +7619,10 @@ package body Exp_Ch4 is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); Rtyp : constant Entity_Id := Root_Type (Typ); - Base : constant Node_Id := Relocate_Node (Left_Opnd (N)); - Bastyp : constant Node_Id := Etype (Base); - Exp : constant Node_Id := Relocate_Node (Right_Opnd (N)); - Exptyp : constant Entity_Id := Etype (Exp); + Base : Node_Id; + Bastyp : Node_Id; + Exp : Node_Id; + Exptyp : Entity_Id; Ovflo : constant Boolean := Do_Overflow_Check (N); Expv : Uint; Temp : Node_Id; @@ -7656,7 +7656,7 @@ package body Exp_Ch4 is end if; end Wrap_MA; - -- Start of processing for Expand_N_Op + -- Start of processing for Expand_N_Op_Expon begin Binary_Op_Validity_Checks (N); @@ -7667,6 +7667,15 @@ package body Exp_Ch4 is return; end if; + -- Relocation of left and right operands must be done after performing + -- the validity checks since the generation of validation checks may + -- remove side effects. + + Base := Relocate_Node (Left_Opnd (N)); + Bastyp := Etype (Base); + Exp := Relocate_Node (Right_Opnd (N)); + Exptyp := Etype (Exp); + -- If either operand is of a private type, then we have the use of an -- intrinsic operator, and we get rid of the privateness, by using root -- types of underlying types for the actual operation. Otherwise the @@ -10765,13 +10774,28 @@ package body Exp_Ch4 is if Is_Access_Type (Target_Type) then + -- If this type conversion was internally generated by the frontend + -- to displace the pointer to the object to reference an interface + -- type and the original node was an 'Unrestricted_Access reference + -- then skip applying accessibility checks (because, according to the + -- GNAT Reference Manual, this attribute is similar to 'Access except + -- that all accessibility and aliased view checks are omitted). + + if not Comes_From_Source (N) + and then Is_Interface (Designated_Type (Target_Type)) + and then Nkind (Original_Node (N)) = N_Attribute_Reference + and then + Attribute_Name (Original_Node (N)) = Name_Unrestricted_Access + then + null; + -- Apply an accessibility check when the conversion operand is an -- access parameter (or a renaming thereof), unless conversion was -- expanded from an Unchecked_ or Unrestricted_Access attribute. -- Note that other checks may still need to be applied below (such -- as tagged type checks). - if Is_Entity_Name (Operand) + elsif Is_Entity_Name (Operand) and then Has_Extra_Accessibility (Entity (Operand)) and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type and then (Nkind (Original_Node (N)) /= N_Attribute_Reference diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb index 791fe2113f9..767fdb9a384 100644 --- a/gcc/ada/prj-attr.adb +++ b/gcc/ada/prj-attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 2001-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- -- @@ -363,6 +363,7 @@ package body Prj.Attr is "SVproject_subdir#" & "SVactive#" & "LAartifacts#" & + "LArequired_artifacts#" & "SVmode#" & "SVinstall_name#" & diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 464900f015e..38c6b20108a 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -15079,7 +15079,7 @@ package body Sem_Ch3 is elsif Ada_Version >= Ada_2005 and then Is_Dispatching_Operation (Parent_Subp) - and then Covers_Some_Interface (Parent_Subp) + and then Present (Covered_Interface_Op (Parent_Subp)) then Set_Derived_Name; @@ -15315,6 +15315,29 @@ package body Sem_Ch3 is New_Overloaded_Entity (New_Subp, Derived_Type); + -- Implement rule in 6.1.1 (15) : if subprogram inherits non-conforming + -- classwide preconditions and the derived type is abstract, the + -- derived operation is abstract as well if parent subprogram is not + -- abstract or null. + + if Is_Abstract_Type (Derived_Type) + and then Has_Non_Trivial_Precondition (Parent_Subp) + and then Present (Interfaces (Derived_Type)) + then + Set_Is_Dispatching_Operation (New_Subp); + + declare + Iface_Prim : constant Entity_Id := Covered_Interface_Op (New_Subp); + + begin + if Present (Iface_Prim) + and then Has_Non_Trivial_Precondition (Iface_Prim) + then + Set_Is_Abstract_Subprogram (New_Subp); + end if; + end; + end if; + -- Check for case of a derived subprogram for the instantiation of a -- formal derived tagged type, if so mark the subprogram as dispatching -- and inherit the dispatching attributes of the actual subprogram. The diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 68e3e1e3356..a2eb9ce5908 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -109,11 +109,11 @@ package body Sem_Disp is Append_Unique_Elmt (New_Op, List); end Add_Dispatching_Operation; - --------------------------- - -- Covers_Some_Interface -- - --------------------------- + -------------------------- + -- Covered_Interface_Op -- + -------------------------- - function Covers_Some_Interface (Prim : Entity_Id) return Boolean is + function Covered_Interface_Op (Prim : Entity_Id) return Entity_Id is Tagged_Type : constant Entity_Id := Find_Dispatching_Type (Prim); Elmt : Elmt_Id; E : Entity_Id; @@ -139,14 +139,14 @@ package body Sem_Disp is if Present (Interface_Alias (E)) and then Alias (E) = Prim then - return True; + return Interface_Alias (E); end if; Next_Elmt (Elmt); end loop; -- Otherwise we must collect all the interface primitives and check - -- if the Prim will override some interface primitive. + -- if the Prim overrides (implements) some interface primitive. else declare @@ -165,11 +165,11 @@ package body Sem_Disp is while Present (Elmt) loop Iface_Prim := Node (Elmt); - if Chars (Iface) = Chars (Prim) + if Chars (Iface_Prim) = Chars (Prim) and then Is_Interface_Conformant (Tagged_Type, Iface_Prim, Prim) then - return True; + return Iface_Prim; end if; Next_Elmt (Elmt); @@ -181,8 +181,8 @@ package body Sem_Disp is end if; end if; - return False; - end Covers_Some_Interface; + return Empty; + end Covered_Interface_Op; ------------------------------- -- Check_Controlling_Formals -- diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads index 6100afcf5eb..7e1709803d0 100644 --- a/gcc/ada/sem_disp.ads +++ b/gcc/ada/sem_disp.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- -- @@ -70,10 +70,9 @@ package Sem_Disp is -- full view because it is always this one which has to be called. -- What is Subp used for??? - function Covers_Some_Interface (Prim : Entity_Id) return Boolean; - -- Returns true if Prim covers some interface primitive of its associated - -- tagged type. The tagged type of Prim must be frozen when this function - -- is invoked. + function Covered_Interface_Op (Prim : Entity_Id) return Entity_Id; + -- Returns the interface primitive that Prim covers, when its controlling + -- type has progenitors. function Find_Controlling_Arg (N : Node_Id) return Node_Id; -- Returns the actual controlling argument if N is dynamically tagged, and diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index bfa5e30311d..fe58505b66c 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -1403,6 +1403,7 @@ package Snames is Name_Project_Path : constant Name_Id := N + $; Name_Project_Subdir : constant Name_Id := N + $; Name_Remote : constant Name_Id := N + $; + Name_Required_Artifacts : constant Name_Id := N + $; Name_Response_File_Format : constant Name_Id := N + $; Name_Response_File_Switches : constant Name_Id := N + $; Name_Root_Dir : constant Name_Id := N + $;