+2015-03-02 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch9.adb (Build_Corresponding_Record): Propagate type
+ invariants to the corresponding record type.
+ * exp_disp.ad[sb] (Set_DT_Position_Value): New subprogram
+ which sets the value of the DTC_Entity associated with a given
+ primitive of a tagged type and propagates the value to the
+ wrapped subprogram.
+ (Set_DTC_Entity_Value): Propagate the DTC
+ value to the wrapped entity.
+ * sem_ch13.adb (Build_Invariant_Procedure): Append the code
+ associated with invariants of progenitors.
+ * sem_ch3.adb (Build_Derived_Record_Type): Inherit type invariants
+ of parents and progenitors.
+ (Process_Full_View): Check hidden inheritance of class-wide type
+ invariants.
+ * sem_ch7.adb (Analyze_Package_Specification): Do not generate
+ the invariant procedure for interface types; build the invariant
+ procedure for tagged types inheriting invariants from their
+ progenitors.
+ * sem_prag.adb (Pragma_Invariant) Allow invariants in interface
+ types but do not build their invariant procedure since their
+ invariants will be propagated to the invariant procedure of
+ types covering the interface.
+ * exp_ch6.adb, exp_disp.adb, sem_ch3.adb, sem_ch7.adb,
+ sem_ch8.adb, sem_disp.adb: Replace all calls to Set_DT_Position
+ by calls to Set_DT_Position_Value.
+
2015-03-02 Hristian Kirtchev <kirtchev@adacore.com>
* sem_attr.adb (Analyze_Attribute): Factor out heavily indented
and then Is_Hidden (Par_Op)
and then Type_Conformant (Prim_Op, Subp)
then
- Set_DT_Position (Subp, DT_Position (Prim_Op));
+ Set_DT_Position_Value (Subp, DT_Position (Prim_Op));
end if;
Next_Elmt (Op_Elmt);
Set_Stored_Constraint (Rec_Ent, No_Elist);
Cdecls := New_List;
+ -- Propagate type invariants to the corresponding record type
+
+ Set_Has_Invariants (Rec_Ent, Has_Invariants (Ctyp));
+ Set_Has_Inheritable_Invariants (Rec_Ent,
+ Has_Inheritable_Invariants (Ctyp));
+
-- Use discriminals to create list of discriminants for record, and
-- create new discriminals for use in default expressions, etc. It is
-- worth noting that a task discriminant gives rise to 5 entities;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
with SCIL_LL; use SCIL_LL;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
-with Uintp; use Uintp;
package body Exp_Disp is
-- way we ensure that the final position of all the primitives is
-- established by the following stages of this algorithm.
- Set_DT_Position (Prim, No_Uint);
+ Set_DT_Position_Value (Prim, No_Uint);
Next_Elmt (Prim_Elmt);
end loop;
if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
then
- Set_DT_Position (Prim_Op, DT_Position (Parent_Subp));
- Set_DT_Position (Node (Op_Elmt_2),
+ Set_DT_Position_Value (Prim_Op,
+ DT_Position (Parent_Subp));
+ Set_DT_Position_Value (Node (Op_Elmt_2),
DT_Position (Parent_Subp));
Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op)));
if In_Predef_Prims_DT (Prim) then
if Is_Predefined_Dispatching_Operation (Prim) then
- Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
+ Set_DT_Position_Value (Prim,
+ Default_Prim_Op_Position (Prim));
else pragma Assert (Present (Alias (Prim)));
- Set_DT_Position (Prim,
+ Set_DT_Position_Value (Prim,
Default_Prim_Op_Position (Ultimate_Alias (Prim)));
end if;
and then Present (DTC_Entity (Interface_Alias (Prim))));
E := Interface_Alias (Prim);
- Set_DT_Position (Prim, DT_Position (E));
+ Set_DT_Position_Value (Prim, DT_Position (E));
pragma Assert
(DT_Position (Alias (Prim)) = No_Uint
or else DT_Position (Alias (Prim)) = DT_Position (E));
- Set_DT_Position (Alias (Prim), DT_Position (E));
+ Set_DT_Position_Value (Alias (Prim), DT_Position (E));
Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
-- Overriding primitives must use the same entry as the
and then Present (DTC_Entity (Alias (Prim)))
then
E := Alias (Prim);
- Set_DT_Position (Prim, DT_Position (E));
+ Set_DT_Position_Value (Prim, DT_Position (E));
if not Is_Predefined_Dispatching_Alias (E) then
Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
exit when not Fixed_Prim (Nb_Prim);
end loop;
- Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
+ Set_DT_Position_Value (Prim, UI_From_Int (Nb_Prim));
Set_Fixed_Prim (Nb_Prim);
end if;
Use_Full_View => True)
then
pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
- Set_DT_Position (Prim, DT_Position (Alias (Prim)));
+ Set_DT_Position_Value (Prim, DT_Position (Alias (Prim)));
-- Otherwise it will be placed in the secondary DT
else
pragma Assert
(DT_Position (Interface_Alias (Prim)) /= No_Uint);
- Set_DT_Position (Prim,
+ Set_DT_Position_Value (Prim,
DT_Position (Interface_Alias (Prim)));
end if;
end if;
end if;
end Set_CPP_Constructors;
+ ---------------------------
+ -- Set_DT_Position_Value --
+ ---------------------------
+
+ procedure Set_DT_Position_Value (Prim : Entity_Id; Value : Uint) is
+ begin
+ Set_DT_Position (Prim, Value);
+
+ -- Propagate the value to the wrapped subprogram (if one is present)
+
+ if Ekind_In (Prim, E_Function, E_Procedure)
+ and then Is_Primitive_Wrapper (Prim)
+ and then Present (Wrapped_Entity (Prim))
+ and then Is_Dispatching_Operation (Wrapped_Entity (Prim))
+ then
+ Set_DT_Position (Wrapped_Entity (Prim), Value);
+ end if;
+ end Set_DT_Position_Value;
+
--------------------------
-- Set_DTC_Entity_Value --
--------------------------
Set_DTC_Entity (Prim,
First_Tag_Component (Tagged_Type));
end if;
+
+ -- Propagate the value to the wrapped subprogram (if one is present)
+
+ if Ekind_In (Prim, E_Function, E_Procedure)
+ and then Is_Primitive_Wrapper (Prim)
+ and then Present (Wrapped_Entity (Prim))
+ and then Is_Dispatching_Operation (Wrapped_Entity (Prim))
+ then
+ Set_DTC_Entity (Wrapped_Entity (Prim), DTC_Entity (Prim));
+ end if;
end Set_DTC_Entity_Value;
-----------------
-- --
-- E X P _ D I S P --
-- --
--- S p e c --
+-- GS p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, 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- --
-- dispatching expansion.
with Types; use Types;
+with Uintp; use Uintp;
package Exp_Disp is
-- target object in its first argument; such implicit argument is explicit
-- in the IP procedures built here.
- procedure Set_DTC_Entity_Value
- (Tagged_Type : Entity_Id;
- Prim : Entity_Id);
+ procedure Set_DT_Position_Value (Prim : Entity_Id; Value : Uint);
+ -- Set the position of a dispatching primitive its dispatch table. For
+ -- subprogram wrappers propagate the value to the wrapped subprogram.
+
+ procedure Set_DTC_Entity_Value (Tagged_Type : Entity_Id; Prim : Entity_Id);
-- Set the definite value of the DTC_Entity value associated with a given
- -- primitive of a tagged type.
+ -- primitive of a tagged type. For subprogram wrappers propagat the value
+ -- to the wrapped subprogram.
procedure Write_DT (Typ : Entity_Id);
pragma Export (Ada, Write_DT);
end loop;
end;
+ -- Add invariants of progenitors
+
+ if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then
+ declare
+ Ifaces_List : Elist_Id;
+ AI : Elmt_Id;
+ Iface : Entity_Id;
+
+ begin
+ Collect_Interfaces (Typ, Ifaces_List);
+
+ AI := First_Elmt (Ifaces_List);
+ while Present (AI) loop
+ Iface := Node (AI);
+
+ if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
+ Add_Invariants (Iface, Inherit => True);
+ end if;
+
+ Next_Elmt (AI);
+ end loop;
+ end;
+ end if;
+
-- Build the procedure if we generated at least one Check pragma
if Stmts /= No_List then
end;
end if;
+ -- Propagate inherited invariant information of parents
+ -- and progenitors
+
+ if Ada_Version >= Ada_2012
+ and then not Is_Interface (Derived_Type)
+ then
+ if Has_Inheritable_Invariants (Parent_Type) then
+ Set_Has_Invariants (Derived_Type);
+ Set_Has_Inheritable_Invariants (Derived_Type);
+
+ elsif not Is_Empty_Elmt_List (Ifaces_List) then
+ declare
+ AI : Elmt_Id;
+
+ begin
+ AI := First_Elmt (Ifaces_List);
+ while Present (AI) loop
+ if Has_Inheritable_Invariants (Node (AI)) then
+ Set_Has_Invariants (Derived_Type);
+ Set_Has_Inheritable_Invariants (Derived_Type);
+
+ exit;
+ end if;
+
+ Next_Elmt (AI);
+ end loop;
+ end;
+ end if;
+ end if;
+
-- A type extension is automatically Ghost when one of its
-- progenitors is Ghost (SPARK RM 6.9(9)). This property is
-- also inherited when the parent type is Ghost, but this is
if Present (DTC_Entity (Actual_Subp)) then
Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp));
- Set_DT_Position (New_Subp, DT_Position (Actual_Subp));
+ Set_DT_Position_Value (New_Subp, DT_Position (Actual_Subp));
end if;
end if;
if not Is_Dispatching_Operation (Prim) then
Append_Elmt (Prim, Full_List);
Set_Is_Dispatching_Operation (Prim, True);
- Set_DT_Position (Prim, No_Uint);
+ Set_DT_Position_Value (Prim, No_Uint);
end if;
elsif Is_Dispatching_Operation (Prim)
Set_Has_Inheritable_Invariants (Full_T);
end if;
+ -- Check hidden inheritance of class-wide type invariants
+
+ if Ada_Version >= Ada_2012
+ and then not Has_Inheritable_Invariants (Full_T)
+ and then In_Private_Part (Current_Scope)
+ and then Has_Interfaces (Full_T)
+ then
+ declare
+ Ifaces : Elist_Id;
+ AI : Elmt_Id;
+
+ begin
+ Collect_Interfaces (Full_T, Ifaces, Exclude_Parents => True);
+
+ AI := First_Elmt (Ifaces);
+ while Present (AI) loop
+ if Has_Inheritable_Invariants (Node (AI)) then
+ Error_Msg_N
+ ("hidden inheritance of class-wide type invariants " &
+ "not allowed", N);
+ exit;
+ end if;
+
+ Next_Elmt (AI);
+ end loop;
+ end;
+ end if;
+
-- Propagate predicates to full type, and predicate function if already
-- defined. It is not clear that this can actually happen? the partial
-- view cannot be frozen yet, and the predicate function has not been
end if;
-- If invariants are present, build the invariant procedure for a
- -- private type, but not any of its subtypes.
+ -- private type, but not any of its subtypes or interface types.
if Has_Invariants (E) then
if Ekind (E) = E_Private_Subtype then
if Is_Type (E)
and then Has_Private_Declaration (E)
and then Nkind (Parent (E)) = N_Full_Type_Declaration
- and then Has_Aspects (Parent (E))
then
declare
- ASN : Node_Id;
+ IP_Built : Boolean := False;
begin
- ASN := First (Aspect_Specifications (Parent (E)));
- while Present (ASN) loop
- if Nam_In (Chars (Identifier (ASN)), Name_Invariant,
- Name_Type_Invariant)
- then
- Build_Invariant_Procedure (E, N);
- exit;
- end if;
+ if Has_Aspects (Parent (E)) then
+ declare
+ ASN : Node_Id;
+
+ begin
+ ASN := First (Aspect_Specifications (Parent (E)));
+ while Present (ASN) loop
+ if Nam_In (Chars (Identifier (ASN)),
+ Name_Invariant,
+ Name_Type_Invariant)
+ then
+ Build_Invariant_Procedure (E, N);
+ IP_Built := True;
+ exit;
+ end if;
- Next (ASN);
- end loop;
+ Next (ASN);
+ end loop;
+ end;
+ end if;
+
+ -- Invariants may have been inherited from progenitors
+
+ if not IP_Built
+ and then Has_Interfaces (E)
+ and then Has_Inheritable_Invariants (E)
+ and then not Is_Interface (E)
+ and then not Is_Class_Wide_Type (E)
+ then
+ Build_Invariant_Procedure (E, N);
+ end if;
end;
end if;
and then Present (DTC_Entity (Alias (Prim_Op)))
then
Set_DTC_Entity_Value (E, New_Op);
- Set_DT_Position (New_Op,
+ Set_DT_Position_Value (New_Op,
DT_Position (Alias (Prim_Op)));
end if;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
+with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
if Present (DTC_Entity (Old_S)) then
Set_DTC_Entity (New_S, DTC_Entity (Old_S));
- Set_DT_Position (New_S, DT_Position (Old_S));
+ Set_DT_Position_Value (New_S, DT_Position (Old_S));
end if;
end if;
end;
if Present (DTC_Entity (Old_Subp)) then
Set_DTC_Entity (Subp, DTC_Entity (Old_Subp));
- Set_DT_Position (Subp, DT_Position (Old_Subp));
+ Set_DT_Position_Value (Subp, DT_Position (Old_Subp));
if not Restriction_Active (No_Dispatching_Calls) then
if Building_Static_DT (Tagged_Type) then
end if;
if not Body_Is_Last_Primitive then
- Set_DT_Position (Subp, No_Uint);
+ Set_DT_Position_Value (Subp, No_Uint);
elsif Has_Controlled_Component (Tagged_Type)
and then Nam_In (Chars (Subp), Name_Initialize,
Check_Controlling_Formals (Tagged_Type, Old_Subp);
Set_Is_Dispatching_Operation (Old_Subp, True);
- Set_DT_Position (Old_Subp, No_Uint);
+ Set_DT_Position_Value (Old_Subp, No_Uint);
end if;
-- If the old subprogram is an explicit renaming of some other
if Typ = Any_Type then
return;
+ -- Invariants allowed in interface types (RM 7.3.2(3/3))
+
+ elsif Is_Interface (Typ) then
+ null;
+
-- An invariant must apply to a private type, or appear in the
-- private part of a package spec and apply to a completion.
-- a class-wide invariant can only appear on a private declaration
-- procedure declaration, so that calls to it can be generated
-- before the body is built (e.g. within an expression function).
- Insert_After_And_Analyze
- (N, Build_Invariant_Procedure_Declaration (Typ));
+ -- Interface types have no invariant procedure; their invariants
+ -- are propagated to the build invariant procedure of all the
+ -- types covering the interface type.
+
+ if not Is_Interface (Typ) then
+ Insert_After_And_Analyze
+ (N, Build_Invariant_Procedure_Declaration (Typ));
+ end if;
if Class_Present (N) then
Set_Has_Inheritable_Invariants (Typ);
projects / gcc.git / commitdiff