Skip to content

R
riscv-gcc-1
Commit 7f568bfa by Arnaud Charlet
Options

[multiple changes] 

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.

From-SVN: r207949
parent 308aab0b
Showing with 143 additions and 83 deletions
gcc/ada/ChangeLog
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
......
gcc/ada/a-cbmutr.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -1585,6 +1585,15 @@ package body Ada.Containers.Bounded_Multiway_Trees is
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";
......@@ -1623,7 +1632,7 @@ package body Ada.Containers.Bounded_Multiway_Trees is
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;
......
gcc/ada/sem_ch12.adb
......@@ -10662,17 +10662,27 @@ package body Sem_Ch12 is
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;
......
gcc/ada/sem_ch6.adb
......@@ -669,25 +669,44 @@ package body Sem_Ch6 is
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
......@@ -708,9 +727,7 @@ package body Sem_Ch6 is
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
......@@ -720,9 +737,7 @@ package body Sem_Ch6 is
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;
......@@ -763,9 +778,7 @@ package body Sem_Ch6 is
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
......@@ -774,9 +787,7 @@ package body Sem_Ch6 is
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;
......@@ -5931,7 +5942,16 @@ package body Sem_Ch6 is
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;
......@@ -6168,7 +6188,16 @@ package body Sem_Ch6 is
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;
......
gcc/ada/sem_eval.adb
......@@ -4686,6 +4686,48 @@ package body Sem_Eval is
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 --
-------------------------
......@@ -4839,55 +4881,6 @@ package body Sem_Eval is
-- 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
......@@ -4903,7 +4896,7 @@ package body Sem_Eval is
-- No match if predicates do not match
elsif not Predicates_Match then
elsif not Predicates_Match (T1, T2) then
return False;
-- Scalar types
......
gcc/ada/sem_eval.ads
......@@ -454,6 +454,12 @@ package Sem_Eval is
-- 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,
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment