Skip to content

R
riscv-gcc-1
Commit ed00f472 by Robert Dewar Committed by Arnaud Charlet
Options

sem_case.adb, [...] (Bad_Predicated_Subtype_Use): Change order of parameters. 

2010-10-22  Robert Dewar  <dewar@adacore.com>

	* sem_case.adb, sem_attr.adb (Bad_Predicated_Subtype_Use): Change order
	of parameters.
	* sem_ch13.adb (Build_Predicate_Function): Don't give inheritance
	messages for generic actual subtypes.
	* sem_ch9.adb, sem_res.adb, sem_util.adb, sem_util.ads, sem_ch3.adb
	(Bad_Predicated_Subtype_Use): Use this procedure.

2010-10-22  Robert Dewar  <dewar@adacore.com>

	* sem_ch5.adb: Minor reformatting.

From-SVN: r165829
parent 86200f66
Showing with 73 additions and 56 deletions
gcc/ada/ChangeLog
2010-10-22 Robert Dewar <dewar@adacore.com>
* sem_case.adb, sem_attr.adb (Bad_Predicated_Subtype_Use): Change order
of parameters.
* sem_ch13.adb (Build_Predicate_Function): Don't give inheritance
messages for generic actual subtypes.
* sem_ch9.adb, sem_res.adb, sem_util.adb, sem_util.ads, sem_ch3.adb
(Bad_Predicated_Subtype_Use): Use this procedure.
2010-10-22 Robert Dewar <dewar@adacore.com>
* sem_ch5.adb: Minor reformatting.
2010-10-22 Robert Dewar <dewar@adacore.com>
* a-except-2005.adb (Rmsg_18): New message text.
* a-except.adb (Rmsg_18): New message text.
* atree.adb (List25): New function
......
gcc/ada/sem_attr.adb
......@@ -842,7 +842,7 @@ package body Sem_Attr is
if Comes_From_Source (N) then
Error_Msg_Name_1 := Aname;
Bad_Predicated_Subtype_Use
(P_Type, N, "type& has predicates, attribute % not allowed");
("type& has predicates, attribute % not allowed", N, P_Type);
end if;
end Bad_Attribute_For_Predicate;
......
gcc/ada/sem_case.adb
......@@ -866,9 +866,8 @@ package body Sem_Case is
or else No (Static_Predicate (E))
then
Bad_Predicated_Subtype_Use
(E, N,
"cannot use subtype& with non-static "
& "predicate as case alternative");
("cannot use subtype& with non-static "
& "predicate as case alternative", N, E);
-- Static predicate case
......
gcc/ada/sem_ch13.adb
......@@ -3888,9 +3888,13 @@ package body Sem_Ch13 is
Right_Opnd => Exp);
end if;
-- Output info message on inheritance if required
-- Output info message on inheritance if required. Note we do not
-- give this information for generic actual types, since it is
-- unwelcome noise in that case in instantiations.
if Opt.List_Inherited_Aspects then
if Opt.List_Inherited_Aspects
and then not Is_Generic_Actual_Type (Typ)
then
Error_Msg_Sloc := Sloc (Predicate_Function (T));
Error_Msg_Node_2 := T;
Error_Msg_N ("?info: & inherits predicate from & #", Typ);
......@@ -4087,9 +4091,10 @@ package body Sem_Ch13 is
function Hi_Val (N : Node_Id) return Uint is
begin
if Nkind (N) = N_Identifier then
if Is_Static_Expression (N) then
return Expr_Value (N);
else
pragma Assert (Nkind (N) = N_Range);
return Expr_Value (High_Bound (N));
end if;
end Hi_Val;
......@@ -4100,9 +4105,10 @@ package body Sem_Ch13 is
function Lo_Val (N : Node_Id) return Uint is
begin
if Nkind (N) = N_Identifier then
if Is_Static_Expression (N) then
return Expr_Value (N);
else
pragma Assert (Nkind (N) = N_Range);
return Expr_Value (Low_Bound (N));
end if;
end Lo_Val;
......@@ -4124,19 +4130,19 @@ package body Sem_Ch13 is
SHi := Hi_Val (N);
end if;
-- Identifier case
else pragma Assert (Nkind (N) = N_Identifier);
-- Static expression case
if Is_Static_Expression (N) then
elsif Is_Static_Expression (N) then
SLo := Lo_Val (N);
SHi := Hi_Val (N);
-- Identifier (other than static expression) case
else pragma Assert (Nkind (N) = N_Identifier);
-- Type case
elsif Is_Type (Entity (N)) then
if Is_Type (Entity (N)) then
-- If type has static predicates, process them recursively
......
gcc/ada/sem_ch3.adb
......@@ -4429,11 +4429,9 @@ package body Sem_Ch3 is
-- Check error of subtype with predicate for index type
if Has_Predicates (Etype (Index)) then
Error_Msg_NE
Bad_Predicated_Subtype_Use
("subtype& has predicate, not allowed as index subtype",
Index, Etype (Index));
end if;
-- Move to next index
......@@ -11402,9 +11400,9 @@ package body Sem_Ch3 is
-- Check error of subtype with predicate in index constraint
elsif Has_Predicates (Entity (S)) then
Error_Msg_NE
("subtype& has predicate, not allowed in index consraint",
else
Bad_Predicated_Subtype_Use
("subtype& has predicate, not allowed in index constraint",
S, Entity (S));
end if;
......
gcc/ada/sem_ch5.adb
......@@ -1734,8 +1734,10 @@ package body Sem_Ch5 is
if No (N) then
return;
end if;
-- Iteration scheme is present
else
declare
Cond : constant Node_Id := Condition (N);
......@@ -1768,9 +1770,9 @@ package body Sem_Ch5 is
Generate_Reference (Id, N, ' ');
-- Check for case of loop variable hiding a local
-- variable (used later on to give a nice warning
-- if the hidden variable is never assigned).
-- Check for the case of loop variable hiding a local variable
-- (used later on to give a nice warning if the hidden variable
-- is never assigned).
declare
H : constant Entity_Id := Homonym (Id);
......@@ -1785,13 +1787,16 @@ package body Sem_Ch5 is
end if;
end;
-- Now analyze the subtype definition. If it is
-- a range, create temporaries for bounds.
-- Now analyze the subtype definition. If it is a range, create
-- temporaries for bounds.
if Nkind (DS) = N_Range
and then Expander_Active
then
Process_Bounds (DS);
-- Not a range or expander not active (is that right???)
else
Analyze (DS);
......@@ -1868,10 +1873,9 @@ package body Sem_Ch5 is
end if;
end;
-- Check for null or possibly null range and issue warning.
-- We suppress such messages in generic templates and
-- instances, because in practice they tend to be dubious
-- in these cases.
-- Check for null or possibly null range and issue warning. We
-- suppress such messages in generic templates and instances,
-- because in practice they tend to be dubious in these cases.
if Nkind (DS) = N_Range and then Comes_From_Source (N) then
declare
......@@ -1884,10 +1888,10 @@ package body Sem_Ch5 is
if Compile_Time_Compare
(L, H, Assume_Valid => True) = GT
then
-- Suppress the warning if inside a generic
-- template or instance, since in practice they
-- tend to be dubious in these cases since they can
-- result from intended parametrization.
-- Suppress the warning if inside a generic template
-- or instance, since in practice they tend to be
-- dubious in these cases since they can result from
-- intended parametrization.
if not Inside_A_Generic
and then not In_Instance
......@@ -1899,8 +1903,7 @@ package body Sem_Ch5 is
(L, H, Assume_Valid => False) = GT
then
Error_Msg_N
("?loop range is null, "
& "loop will not execute",
("?loop range is null, loop will not execute",
DS);
-- Since we know the range of the loop is
......@@ -1959,7 +1962,6 @@ package body Sem_Ch5 is
end;
end if;
end;
end if;
end Analyze_Iteration_Scheme;
-------------------------------------
......
gcc/ada/sem_ch9.adb
......@@ -894,12 +894,10 @@ package body Sem_Ch9 is
-- Check subtype with predicate in entry family
if Has_Predicates (Etype (D_Sdef)) then
Error_Msg_NE
Bad_Predicated_Subtype_Use
("subtype& has predicate, not allowed in entry family",
D_Sdef, Etype (D_Sdef));
end if;
end if;
-- Decorate Def_Id
......
gcc/ada/sem_res.adb
......@@ -8481,7 +8481,7 @@ package body Sem_Res is
-- Check bad use of type with predicates
if Has_Predicates (Etype (Drange)) then
Error_Msg_NE
Bad_Predicated_Subtype_Use
("subtype& has predicate, not allowed in slice",
Drange, Etype (Drange));
......
gcc/ada/sem_util.adb
......@@ -334,21 +334,21 @@ package body Sem_Util is
--------------------------------
procedure Bad_Predicated_Subtype_Use
(Typ : Entity_Id;
(Msg : String;
N : Node_Id;
Msg : String)
Typ : Entity_Id)
is
begin
if Has_Predicates (Typ) then
if Is_Generic_Actual_Type (Typ) then
Error_Msg_F (Msg & '?', Typ);
Error_Msg_F ("\Program_Error will be raised at run time?", Typ);
Error_Msg_FE (Msg & '?', N, Typ);
Error_Msg_F ("\Program_Error will be raised at run time?", N);
Insert_Action (N,
Make_Raise_Program_Error (Sloc (N),
Reason => PE_Bad_Predicated_Generic_Type));
else
Error_Msg_F (Msg, Typ);
Error_Msg_FE (Msg, N, Typ);
end if;
end if;
end Bad_Predicated_Subtype_Use;
......
gcc/ada/sem_util.ads
......@@ -94,18 +94,19 @@ package Sem_Util is
-- whether an error or warning is given.
procedure Bad_Predicated_Subtype_Use
(Typ : Entity_Id;
(Msg : String;
N : Node_Id;
Msg : String);
Typ : Entity_Id);
-- This is called when Typ, a predicated subtype, is used in a context
-- which does not allow the use of a predicated subtype. Msg will be
-- passed to Error_Msg_F to output an appropriate message. The caller
-- should set up any insertions other than the & for the type itself.
-- Note that if Typ is a generic actual type, then the message will be
-- output as a warning, and a raise Program_Error is inserted using
-- Insert_Action with node N as the insertion point. Node N also supplies
-- the source location for construction of the raise node. If Typ is NOT a
-- type with predicates this call has no effect.
-- which does not allow the use of a predicated subtype. Msg is passed
-- to Error_Msg_FE to output an appropriate message using N as the
-- location, and Typ as the entity. The caller must set up any insertions
-- other than the & for the type itself. Note that if Typ is a generic
-- actual type, then the message will be output as a warning, and a
-- raise Program_Error is inserted using Insert_Action with node N as
-- the insertion point. Node N also supplies the source location for
-- construction of the raise node. If Typ is NOT a type with predicates
-- this call has no effect.
function Build_Actual_Subtype
(T : Entity_Id;
......
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