@@ -1854,12 +1854,18 @@ package body Exp_Util is
end if;
-- Once the DIC assertion expression is fully processed, add a check
- -- to the statements of the DIC procedure.
-
- Add_DIC_Check
- (DIC_Prag => DIC_Prag,
- DIC_Expr => Expr,
- Stmts => Stmts);
+ -- to the statements of the DIC procedure (unless the type is an
+ -- abstract type, in which case we don't want the possibility of
+ -- generating a call to an abstract function of the type; such DIC
+ -- procedures can never be called in any case, so not generating the
+ -- check at all is OK).
+
+ if not Is_Abstract_Type (DIC_Typ) then
+ Add_DIC_Check
+ (DIC_Prag => DIC_Prag,
+ DIC_Expr => Expr,
+ Stmts => Stmts);
+ end if;
end Add_Own_DIC;
---------------------
@@ -517,6 +517,12 @@ package body Sem_Disp is
procedure Abstract_Context_Error;
-- Error for abstract call dispatching on result is not dispatching
+ function Has_Controlling_Current_Instance_Actual_In_DIC
+ (Call : Node_Id) return Boolean;
+ -- Return True if the subprogram call Call has a controlling actual
+ -- given directly by a current instance referenced within a DIC
+ -- aspect.
+
----------------------------
-- Abstract_Context_Error --
----------------------------
@@ -536,6 +542,44 @@ package body Sem_Disp is
end if;
end Abstract_Context_Error;
+ ----------------------------------------
+ -- Has_Current_Instance_Actual_In_DIC --
+ ----------------------------------------
+
+ function Has_Controlling_Current_Instance_Actual_In_DIC
+ (Call : Node_Id) return Boolean
+ is
+ A : Node_Id;
+ F : Entity_Id;
+ begin
+ F := First_Formal (Subp_Entity);
+ A := First_Actual (Call);
+
+ while Present (F) loop
+
+ -- Return True if the actual denotes a current instance (which
+ -- will be represented by an in-mode formal of the enclosing
+ -- DIC_Procedure) passed to a controlling formal. We don't have
+ -- to worry about controlling access formals here, because its
+ -- illegal to apply Access (etc.) attributes to a current
+ -- instance within an aspect (by AI12-0068).
+
+ if Is_Controlling_Formal (F)
+ and then Nkind (A) = N_Identifier
+ and then Ekind (Entity (A)) = E_In_Parameter
+ and then Is_Subprogram (Scope (Entity (A)))
+ and then Is_DIC_Procedure (Scope (Entity (A)))
+ then
+ return True;
+ end if;
+
+ Next_Formal (F);
+ Next_Actual (A);
+ end loop;
+
+ return False;
+ end Has_Controlling_Current_Instance_Actual_In_DIC;
+
-- Local variables
Scop : constant Entity_Id := Current_Scope_No_Loops;
@@ -591,6 +635,20 @@ package body Sem_Disp is
then
null;
+ -- Similarly to the dispensation for postconditions, a call to
+ -- an abstract function within a Default_Initial_Condition aspect
+ -- can be legal when passed a current instance of the type. Such
+ -- a call will be effectively mapped to a call to a primitive of
+ -- a descendant type (see AI12-0397, as well as AI12-0170), so
+ -- doesn't need to be dispatching. We test for being within a DIC
+ -- procedure, since that's where the call will be analyzed.
+
+ elsif Is_Subprogram (Scop)
+ and then Is_DIC_Procedure (Scop)
+ and then Has_Controlling_Current_Instance_Actual_In_DIC (Call)
+ then
+ null;
+
elsif Ekind (Current_Scope) = E_Function
and then Nkind (Unit_Declaration_Node (Scop)) =
N_Generic_Subprogram_Declaration
@@ -5036,6 +5036,41 @@ package body Sem_Res is
end if;
end if;
+ -- (AI12-0397): The target of a subprogram call that occurs within
+ -- the expression of an Default_Initial_Condition aspect and has
+ -- an actual that is the current instance of the type must be
+ -- either a primitive of the type or a class-wide subprogram,
+ -- because the type of the current instance in such an aspect is
+ -- considered to be a notional formal derived type whose only
+ -- operations correspond to the primitives of the enclosing type.
+ -- Nonprimitives can be called, but the current instance must be
+ -- converted rather than passed directly. Note that a current
+ -- instance of a type with DIC will occur as a reference to an
+ -- in-mode formal of an enclosing DIC procedure or partial DIC
+ -- procedure. (It seems that this check should perhaps also apply
+ -- to calls within Type_Invariant'Class, but not Type_Invariant,
+ -- aspects???)
+
+ if Nkind (A) = N_Identifier
+ and then Ekind (Entity (A)) = E_In_Parameter
+
+ and then Is_Subprogram (Scope (Entity (A)))
+ and then Is_DIC_Procedure (Scope (Entity (A)))
+
+ -- We check Comes_From_Source to exclude inherited primitives
+ -- from being flagged, because such subprograms turn out to not
+ -- always have the Is_Primitive flag set. ???
+
+ and then Comes_From_Source (Nam)
+
+ and then not Is_Primitive (Nam)
+ and then not Is_Class_Wide_Type (Etype (F))
+ then
+ Error_Msg_NE
+ ("call to nonprimitive & with current instance not allowed " &
+ "for aspect", A, Nam);
+ end if;
+
Next_Actual (A);
-- Case where actual is not present