@@ -11339,9 +11339,8 @@ package body Sem_Ch12 is
-- access type.
if Ada_Version < Ada_2005
- or else Ekind (Base_Type (Ftyp)) not in Anonymous_Access_Kind
- or else Ekind (Base_Type (Etype (Actual)))
- not in Anonymous_Access_Kind
+ or else not Is_Anonymous_Access_Type (Base_Type (Ftyp))
+ or else not Is_Anonymous_Access_Type (Base_Type (Etype (Actual)))
then
Error_Msg_NE
("type of actual does not match type of&", Actual, Gen_Obj);
@@ -5668,7 +5668,6 @@ package body Sem_Ch6 is
New_Type : constant Entity_Id := Etype (New_Id);
Old_Formal : Entity_Id;
New_Formal : Entity_Id;
- Access_Types_Match : Boolean;
Old_Formal_Base : Entity_Id;
New_Formal_Base : Entity_Id;
@@ -5869,57 +5868,6 @@ package body Sem_Ch6 is
New_Formal_Base := Get_Instance_Of (New_Formal_Base);
end if;
- Access_Types_Match := Ada_Version >= Ada_2005
-
- -- Ensure that this rule is only applied when New_Id is a
- -- renaming of Old_Id.
-
- and then Nkind (Parent (Parent (New_Id))) =
- N_Subprogram_Renaming_Declaration
- and then Nkind (Name (Parent (Parent (New_Id)))) in N_Has_Entity
- and then Present (Entity (Name (Parent (Parent (New_Id)))))
- and then Entity (Name (Parent (Parent (New_Id)))) = Old_Id
-
- -- Now handle the allowed access-type case
-
- and then Is_Access_Type (Old_Formal_Base)
- and then Is_Access_Type (New_Formal_Base)
-
- -- The type kinds must match. The only exception occurs with
- -- multiple generics of the form:
-
- -- generic generic
- -- type F is private; type A is private;
- -- type F_Ptr is access F; type A_Ptr is access A;
- -- with proc F_P (X : F_Ptr); with proc A_P (X : A_Ptr);
- -- package F_Pack is ... package A_Pack is
- -- package F_Inst is
- -- new F_Pack (A, A_Ptr, A_P);
-
- -- When checking for conformance between the parameters of A_P
- -- and F_P, the type kinds of F_Ptr and A_Ptr will not match
- -- because the compiler has transformed A_Ptr into a subtype of
- -- F_Ptr. We catch this case in the code below.
-
- and then (Ekind (Old_Formal_Base) = Ekind (New_Formal_Base)
- or else
- (Is_Generic_Type (Old_Formal_Base)
- and then Is_Generic_Type (New_Formal_Base)
- and then Is_Internal (New_Formal_Base)
- and then Etype (Etype (New_Formal_Base)) =
- Old_Formal_Base))
- and then Directly_Designated_Type (Old_Formal_Base) =
- Directly_Designated_Type (New_Formal_Base)
- and then ((Is_Itype (Old_Formal_Base)
- and then (Can_Never_Be_Null (Old_Formal_Base)
- or else Is_Access_Constant
- (Old_Formal_Base)))
- or else
- (Is_Itype (New_Formal_Base)
- and then (Can_Never_Be_Null (New_Formal_Base)
- or else Is_Access_Constant
- (New_Formal_Base))));
-
-- Types must always match. In the visible part of an instance,
-- usual overloading rules for dispatching operations apply, and
-- we check base types (not the actual subtypes).
@@ -5932,7 +5880,6 @@ package body Sem_Ch6 is
T2 => Base_Type (Etype (New_Formal)),
Ctype => Ctype,
Get_Inst => Get_Inst)
- and then not Access_Types_Match
then
Conformance_Error ("\type of & does not match!", New_Formal);
return;
@@ -5943,7 +5890,6 @@ package body Sem_Ch6 is
T2 => New_Formal_Base,
Ctype => Ctype,
Get_Inst => Get_Inst)
- and then not Access_Types_Match
then
-- Don't give error message if old type is Any_Type. This test
-- avoids some cascaded errors, e.g. in case of a bad spec.
@@ -5996,10 +5942,8 @@ package body Sem_Ch6 is
return;
- -- Part of mode conformance for access types is having the same
- -- constant modifier.
-
- elsif Access_Types_Match
+ elsif Is_Access_Type (Old_Formal_Base)
+ and then Is_Access_Type (New_Formal_Base)
and then Is_Access_Constant (Old_Formal_Base) /=
Is_Access_Constant (New_Formal_Base)
then
@@ -6021,8 +5965,8 @@ package body Sem_Ch6 is
-- (access formals in the bodies aren't marked Can_Never_Be_Null).
if Ada_Version >= Ada_2005
- and then Ekind (Etype (Old_Formal)) = E_Anonymous_Access_Type
- and then Ekind (Etype (New_Formal)) = E_Anonymous_Access_Type
+ and then Is_Anonymous_Access_Type (Etype (Old_Formal))
+ and then Is_Anonymous_Access_Type (Etype (New_Formal))
and then
((Can_Never_Be_Null (Etype (Old_Formal)) /=
Can_Never_Be_Null (Etype (New_Formal))
@@ -1040,8 +1040,8 @@ package body Sem_Ch8 is
if Nkind (Nam) = N_Type_Conversion
and then not Comes_From_Source (Nam)
- and then Ekind (Etype (Expression (Nam))) in Anonymous_Access_Kind
- and then Ekind (T) not in Anonymous_Access_Kind
+ and then Is_Anonymous_Access_Type (Etype (Expression (Nam)))
+ and then not Is_Anonymous_Access_Type (T)
then
Wrong_Type (Expression (Nam), T); -- Should we give better error???
end if;
@@ -2004,15 +2004,14 @@ package body Sem_Ch8 is
-- Ada 2005 (AI-423): Given renaming Ren of subprogram Sub, check the
-- following AI rules:
--
- -- If Ren is a renaming of a formal subprogram and one of its
- -- parameters has a null exclusion, then the corresponding formal
- -- in Sub must also have one. Otherwise the subtype of the Sub's
- -- formal parameter must exclude null.
+ -- If Ren denotes a generic formal object of a generic unit G, and the
+ -- renaming (or instantiation containing the actual) occurs within the
+ -- body of G or within the body of a generic unit declared within the
+ -- declarative region of G, then the corresponding parameter of G
+ -- shall have a null_exclusion; Otherwise the subtype of the Sub's
+ -- formal parameter shall exclude null.
--
- -- If Ren is a renaming of a formal function and its return
- -- profile has a null exclusion, then Sub's return profile must
- -- have one. Otherwise the subtype of Sub's return profile must
- -- exclude null.
+ -- Similarly for its return profile.
procedure Check_SPARK_Primitive_Operation (Subp_Id : Entity_Id);
-- Ensure that a SPARK renaming denoted by its entity Subp_Id does not
@@ -2579,20 +2578,38 @@ package body Sem_Ch8 is
Ren_Formal : Entity_Id;
Sub_Formal : Entity_Id;
+ function Null_Exclusion_Mismatch
+ (Renaming : Entity_Id; Renamed : Entity_Id) return Boolean;
+ -- Return True if there is a null exclusion mismatch between
+ -- Renaming and Renamed, False otherwise.
+
+ -----------------------------
+ -- Null_Exclusion_Mismatch --
+ -----------------------------
+
+ function Null_Exclusion_Mismatch
+ (Renaming : Entity_Id; Renamed : Entity_Id) return Boolean is
+ begin
+ return Has_Null_Exclusion (Parent (Renaming))
+ and then
+ not (Has_Null_Exclusion (Parent (Renamed))
+ or else (Can_Never_Be_Null (Etype (Renamed))
+ and then not
+ (Is_Formal_Subprogram (Sub)
+ and then In_Generic_Body (Current_Scope))));
+ end Null_Exclusion_Mismatch;
+
begin
-- Parameter check
Ren_Formal := First_Formal (Ren);
Sub_Formal := First_Formal (Sub);
while Present (Ren_Formal) and then Present (Sub_Formal) loop
- if Has_Null_Exclusion (Parent (Ren_Formal))
- and then
- not (Has_Null_Exclusion (Parent (Sub_Formal))
- or else Can_Never_Be_Null (Etype (Sub_Formal)))
- then
+ if Null_Exclusion_Mismatch (Ren_Formal, Sub_Formal) then
+ Error_Msg_Sloc := Sloc (Sub_Formal);
Error_Msg_NE
- ("`NOT NULL` required for parameter &",
- Parent (Sub_Formal), Sub_Formal);
+ ("`NOT NULL` required for parameter &#",
+ Ren_Formal, Sub_Formal);
end if;
Next_Formal (Ren_Formal);
@@ -2603,13 +2620,10 @@ package body Sem_Ch8 is
if Nkind (Parent (Ren)) = N_Function_Specification
and then Nkind (Parent (Sub)) = N_Function_Specification
- and then Has_Null_Exclusion (Parent (Ren))
- and then not (Has_Null_Exclusion (Parent (Sub))
- or else Can_Never_Be_Null (Etype (Sub)))
+ and then Null_Exclusion_Mismatch (Ren, Sub)
then
- Error_Msg_N
- ("return must specify `NOT NULL`",
- Result_Definition (Parent (Sub)));
+ Error_Msg_Sloc := Sloc (Sub);
+ Error_Msg_N ("return must specify `NOT NULL`#", Ren);
end if;
end Check_Null_Exclusion;
@@ -3454,10 +3468,6 @@ package body Sem_Ch8 is
then
Check_Mode_Conformant (New_S, Old_S);
end if;
-
- if Is_Actual and then Error_Posted (New_S) then
- Error_Msg_NE ("invalid actual subprogram: & #!", N, Old_S);
- end if;
end if;
if No (Rename_Spec) then
@@ -12066,7 +12066,8 @@ package body Sem_Util is
when N_Parameter_Specification =>
if Nkind (Parameter_Type (N)) = N_Access_Definition then
- return Null_Exclusion_Present (Parameter_Type (N));
+ return Null_Exclusion_Present (Parameter_Type (N))
+ or else Null_Exclusion_Present (N);
else
return Null_Exclusion_Present (N);
end if;