Skip to content

R
riscv-gcc-1
Commit 904a2ae4 by Arnaud Charlet
Options

[multiple changes] 

2017-04-25  Ed Schonberg  <schonberg@adacore.com>

	* 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  <miranda@adacore.com>

	* 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  <miranda@adacore.com>

	* 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  <obry@adacore.com>

	* prj-attr.adb, snames.ads-tmpl: Add package Install's
	Required_Artifacts attribute.

From-SVN: r247202
parent ac2e1a51
Showing with 102 additions and 25 deletions
gcc/ada/ChangeLog
2017-04-25 Ed Schonberg <schonberg@adacore.com>
* 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 <miranda@adacore.com>
* 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 <miranda@adacore.com>
* 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 <obry@adacore.com>
* prj-attr.adb, snames.ads-tmpl: Add package Install's
Required_Artifacts attribute.
2017-04-25 Ed Schonberg <schonberg@adacore.com>
* sem_util.adb (Same_Value): String literals are compile-time
values, and comparing them must use Expr_Value_S.
......
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
......
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
......
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#" &
......
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
......
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 --
......
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
......
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 + $;
......
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