+2014-02-20 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch12.adb (Validate_Access_Type_Instance): Add message if
+ mismatching predicates.
+ * sem_ch6.adb (Check_Conformance): Give better messages on
+ predicate mismatch.
+ * sem_eval.adb (Predicates_Match): Move to spec.
+ * sem_eval.ads (Predicates_Match): Moved here from body.
+
+2014-02-20 Ed Schonberg <schonberg@adacore.com>
+
+ * a-cbmutr.adb: Use default value in Insert_Child.
+
2014-02-20 Vincent Celier <celier@adacore.com>
* gnatcmd.adb, make.adb, prj-makr.adb, clean.adb: Call
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2013, 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- --
Nodes : Tree_Node_Array renames Container.Nodes;
Last : Count_Type;
+ Elem : Element_Type;
+ pragma Unmodified (Elem);
+ -- There is no explicit element provided, but in an instance the
+ -- element type may be a scalar with a Default_Value aspect, or a
+ -- composite type with such a scalar component, so we insert the
+ -- specified number of possibly initialized elements at the given
+ -- position. So we are declaring Elem just for this possible default
+ -- initialization, which is why we need the pragma Unmodified.
+
begin
if Parent = No_Element then
raise Constraint_Error with "Parent cursor has no element";
Initialize_Root (Container);
end if;
- Allocate_Node (Container, Position.Node);
+ Allocate_Node (Container, Elem, Position.Node);
Nodes (Position.Node).Parent := Parent.Node;
Last := Position.Node;
if not Subtypes_Match (Desig_Type, Desig_Act) then
Error_Msg_NE
("designated type of actual does not match that of formal &",
- Actual, Gen_T);
+ Actual, Gen_T);
+
+ if not Predicates_Match (Desig_Type, Desig_Act) then
+ Error_Msg_N ("\predicates do not match", Actual);
+ end if;
+
Abandon_Instantiation (Actual);
elsif Is_Access_Type (Designated_Type (Act_T))
and then Is_Constrained (Designated_Type (Designated_Type (Act_T)))
/=
- Is_Constrained (Designated_Type (Desig_Type))
+ Is_Constrained (Designated_Type (Desig_Type))
then
Error_Msg_NE
("designated type of actual does not match that of formal &",
- Actual, Gen_T);
+ Actual, Gen_T);
+
+ if not Predicates_Match (Desig_Type, Desig_Act) then
+ Error_Msg_N ("\predicates do not match", Actual);
+ end if;
+
Abandon_Instantiation (Actual);
end if;
Subtype_Ind : constant Node_Id :=
Object_Definition (Original_Node (Obj_Decl));
- R_Type_Is_Anon_Access :
- constant Boolean :=
- Ekind (R_Type) = E_Anonymous_Access_Subprogram_Type
- or else
- Ekind (R_Type) = E_Anonymous_Access_Protected_Subprogram_Type
- or else
- Ekind (R_Type) = E_Anonymous_Access_Type;
+ R_Type_Is_Anon_Access : constant Boolean :=
+ Ekind_In (R_Type,
+ E_Anonymous_Access_Subprogram_Type,
+ E_Anonymous_Access_Protected_Subprogram_Type,
+ E_Anonymous_Access_Type);
-- True if return type of the function is an anonymous access type
-- Can't we make Is_Anonymous_Access_Type in einfo ???
- R_Stm_Type_Is_Anon_Access :
- constant Boolean :=
- Ekind (R_Stm_Type) = E_Anonymous_Access_Subprogram_Type
- or else
- Ekind (R_Stm_Type) = E_Anonymous_Access_Protected_Subprogram_Type
- or else
- Ekind (R_Stm_Type) = E_Anonymous_Access_Type;
+ R_Stm_Type_Is_Anon_Access : constant Boolean :=
+ Ekind_In (R_Stm_Type,
+ E_Anonymous_Access_Subprogram_Type,
+ E_Anonymous_Access_Protected_Subprogram_Type,
+ E_Anonymous_Access_Type);
-- True if type of the return object is an anonymous access type
+ procedure Error_No_Match (N : Node_Id);
+ -- Output error messages for case where types do not statically
+ -- match. N is the location for the messages.
+
+ --------------------
+ -- Error_No_Match --
+ --------------------
+
+ procedure Error_No_Match (N : Node_Id) is
+ begin
+ Error_Msg_N
+ ("subtype must statically match function result subtype", N);
+
+ if not Predicates_Match (R_Stm_Type, R_Type) then
+ Error_Msg_Node_2 := R_Type;
+ Error_Msg_NE
+ ("\predicate of & does not match predicate of &",
+ N, R_Stm_Type);
+ end if;
+ end Error_No_Match;
+
+ -- Start of processing for Check_Return_Subtype_Indication
+
begin
-- First, avoid cascaded errors
Base_Type (Designated_Type (R_Type))
or else not Subtypes_Statically_Match (R_Stm_Type, R_Type)
then
- Error_Msg_N
- ("subtype must statically match function result subtype",
- Subtype_Mark (Subtype_Ind));
+ Error_No_Match (Subtype_Mark (Subtype_Ind));
end if;
else
if not Conforming_Types
(R_Stm_Type, R_Type, Fully_Conformant)
then
- Error_Msg_N
- ("subtype must statically match function result subtype",
- Subtype_Ind);
+ Error_No_Match (Subtype_Ind);
end if;
end if;
or else Null_Exclusion_Present (Parent (Scope_Id))) /=
Can_Never_Be_Null (R_Stm_Type)
then
- Error_Msg_N
- ("subtype must statically match function result subtype",
- Subtype_Ind);
+ Error_No_Match (Subtype_Ind);
end if;
-- AI05-103: for elementary types, subtypes must statically match
or else Is_Access_Type (R_Type)
then
if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
- Error_Msg_N
- ("subtype must statically match function result subtype",
- Subtype_Ind);
+ Error_No_Match (Subtype_Ind);
end if;
end if;
null;
elsif not Conforming_Types (Old_Type, New_Type, Ctype, Get_Inst) then
- Conformance_Error ("\return type does not match!", New_Id);
+ if Ctype >= Subtype_Conformant
+ and then not Predicates_Match (Old_Type, New_Type)
+ then
+ Conformance_Error
+ ("\predicate of return type does not match!", New_Id);
+ else
+ Conformance_Error
+ ("\return type does not match!", New_Id);
+ end if;
+
return;
end if;
if Errmsg and then Old_Formal_Base = Any_Type then
Conforms := False;
else
- Conformance_Error ("\type of & does not match!", New_Formal);
+ if Ctype >= Subtype_Conformant
+ and then
+ not Predicates_Match (Old_Formal_Base, New_Formal_Base)
+ then
+ Conformance_Error
+ ("\predicate of & does not match!", New_Formal);
+ else
+ Conformance_Error
+ ("\type of & does not match!", New_Formal);
+ end if;
end if;
return;
end if;
end Out_Of_Range;
+ ----------------------
+ -- Predicates_Match --
+ ----------------------
+
+ function Predicates_Match (T1, T2 : Entity_Id) return Boolean is
+ Pred1 : Node_Id;
+ Pred2 : Node_Id;
+
+ begin
+ if Ada_Version < Ada_2012 then
+ return True;
+
+ -- Both types must have predicates or lack them
+
+ elsif Has_Predicates (T1) /= Has_Predicates (T2) then
+ return False;
+
+ -- Check matching predicates
+
+ else
+ Pred1 :=
+ Get_Rep_Item
+ (T1, Name_Static_Predicate, Check_Parents => False);
+ Pred2 :=
+ Get_Rep_Item
+ (T2, Name_Static_Predicate, Check_Parents => False);
+
+ -- Subtypes statically match if the predicate comes from the
+ -- same declaration, which can only happen if one is a subtype
+ -- of the other and has no explicit predicate.
+
+ -- Suppress warnings on order of actuals, which is otherwise
+ -- triggered by one of the two calls below.
+
+ pragma Warnings (Off);
+ return Pred1 = Pred2
+ or else (No (Pred1) and then Is_Subtype_Of (T1, T2))
+ or else (No (Pred2) and then Is_Subtype_Of (T2, T1));
+ pragma Warnings (On);
+ end if;
+ end Predicates_Match;
+
-------------------------
-- Rewrite_In_Raise_CE --
-------------------------
-- false even if the types would otherwise match in the RM sense.
function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is
-
- function Predicates_Match return Boolean;
- -- In Ada 2012, subtypes statically match if their static predicates
- -- match as well.
-
- ----------------------
- -- Predicates_Match --
- ----------------------
-
- function Predicates_Match return Boolean is
- Pred1 : Node_Id;
- Pred2 : Node_Id;
-
- begin
- if Ada_Version < Ada_2012 then
- return True;
-
- -- Both types must have predicates or lack them
-
- elsif Has_Predicates (T1) /= Has_Predicates (T2) then
- return False;
-
- -- Check matching predicates
-
- else
- Pred1 :=
- Get_Rep_Item
- (T1, Name_Static_Predicate, Check_Parents => False);
- Pred2 :=
- Get_Rep_Item
- (T2, Name_Static_Predicate, Check_Parents => False);
-
- -- Subtypes statically match if the predicate comes from the
- -- same declaration, which can only happen if one is a subtype
- -- of the other and has no explicit predicate.
-
- -- Suppress warnings on order of actuals, which is otherwise
- -- triggered by one of the two calls below.
-
- pragma Warnings (Off);
- return Pred1 = Pred2
- or else (No (Pred1) and then Is_Subtype_Of (T1, T2))
- or else (No (Pred2) and then Is_Subtype_Of (T2, T1));
- pragma Warnings (On);
- end if;
- end Predicates_Match;
-
- -- Start of processing for Subtypes_Statically_Match
-
begin
-- A type always statically matches itself
-- No match if predicates do not match
- elsif not Predicates_Match then
+ elsif not Predicates_Match (T1, T2) then
return False;
-- Scalar types
-- it cannot (because the value of Lo or Hi is not known at compile time)
-- then it returns False.
+ function Predicates_Match (T1, T2 : Entity_Id) return Boolean;
+ -- In Ada 2012, subtypes statically match if their static predicates
+ -- match as well. This function performs the required check that
+ -- predicates match. Separated out from Subtypes_Statically_Match so
+ -- that it can be used in specializing error messages.
+
procedure Why_Not_Static (Expr : Node_Id);
-- This procedure may be called after generating an error message that
-- complains that something is non-static. If it finds good reasons,
projects / thirdparty / gcc.git / commitdiff
