+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
(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
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;
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);
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
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
-- --
-- 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- --
"SVproject_subdir#" &
"SVactive#" &
"LAartifacts#" &
+ "LArequired_artifacts#" &
"SVmode#" &
"SVinstall_name#" &
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;
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
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;
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
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);
end if;
end if;
- return False;
- end Covers_Some_Interface;
+ return Empty;
+ end Covered_Interface_Op;
-------------------------------
-- Check_Controlling_Formals --
-- --
-- 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- --
-- 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
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 + $;
projects / gcc.git / commitdiff