OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

a-dispat.adb, [...]: Minor reformatting. 

2015-02-20  Robert Dewar  <dewar@adacore.com>

	* a-dispat.adb, a-stcoed.ads: Minor reformatting.

2015-02-20  Robert Dewar  <dewar@adacore.com>

	* sem_ch13.adb (Build_Discrete_Static_Predicate): Allow static
	predicate for non-static subtype.
	(Build_Predicate_Functions): Do not assume subtype associated with a
	static predicate must be static.

2015-02-20  Robert Dewar  <dewar@adacore.com>

	* errout.adb (Set_Msg_Node): Better handling of internal names
	(Set_Msg_Node): Kill message when we cannot eliminate internal name.
	* errout.ads: Document additional case of message deletion.
	* namet.adb (Is_Internal_Name): Refined to consider wide
	strings in brackets notation and character literals not to be
	internal names.
	* sem_ch8.adb (Find_Selected_Component): Give additional error
	when selector name is a subprogram whose first parameter has
	the same type as the prefix, but that type is untagged.

From-SVN: r220868
This commit is contained in:
Robert Dewar 2015-02-20 14:29:49 +00:00 committed by Arnaud Charlet
parent 4060ebd4be
commit 67c0e6625c
8 changed files with 137 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
gcc/ada/ChangeLog
View File

@ -1,3 +1,26 @@
2015-02-20 Robert Dewar <dewar@adacore.com>
* a-dispat.adb, a-stcoed.ads: Minor reformatting.
2015-02-20 Robert Dewar <dewar@adacore.com>
* sem_ch13.adb (Build_Discrete_Static_Predicate): Allow static
predicate for non-static subtype.
(Build_Predicate_Functions): Do not assume subtype associated with a
static predicate must be static.
2015-02-20 Robert Dewar <dewar@adacore.com>
* errout.adb (Set_Msg_Node): Better handling of internal names
(Set_Msg_Node): Kill message when we cannot eliminate internal name.
* errout.ads: Document additional case of message deletion.
* namet.adb (Is_Internal_Name): Refined to consider wide
strings in brackets notation and character literals not to be
internal names.
* sem_ch8.adb (Find_Selected_Component): Give additional error
when selector name is a subprogram whose first parameter has
the same type as the prefix, but that type is untagged.
2015-02-20 Robert Dewar <dewar@adacore.com>
* g-allein.ads, g-alveop.adb, g-alveop.ads, opt.ads: Minor reformatting

2
gcc/ada/a-dispat.adb
View File

@ -37,7 +37,7 @@ package body Ada.Dispatching is
procedure Yield is
Self_Id : constant System.Tasking.Task_Id :=
System.Task_Primitives.Operations.Self;
System.Task_Primitives.Operations.Self;
begin
-- If pragma Detect_Blocking is active, Program_Error must be

2
gcc/ada/a-stcoed.ads
View File

@ -27,5 +27,5 @@ package Ada.Synchronous_Task_Control.EDF is
procedure Suspend_Until_True_And_Set_Deadline
(S : in out Suspension_Object;
TS : Ada.Real_Time.Time_Span);
TS : Ada.Real_Time.Time_Span);
end Ada.Synchronous_Task_Control.EDF;

36
gcc/ada/errout.adb
View File

@ -2792,18 +2792,29 @@ package body Errout is
Nam := Pragma_Name (Node);
Loc := Sloc (Node);
-- The other cases have Chars fields, and we want to test for possible
-- internal names, which generally represent something gone wrong. An
-- exception is the case of internal type names, where we try to find a
-- reasonable external representation for the external name
-- The other cases have Chars fields
-- First deal with internal names, which generally represent something
-- gone wrong. First attempt: if this is a rewritten node that rewrites
-- something with a Chars field that is not an internal name, use that.
elsif Is_Internal_Name (Chars (Node))
and then Nkind (Original_Node (Node)) in N_Has_Chars
and then not Is_Internal_Name (Chars (Original_Node (Node)))
then
Nam := Chars (Original_Node (Node));
Loc := Sloc (Original_Node (Node));
-- Another shot for internal names, in the case of internal type names,
-- we try to find a reasonable representation for the external name.
elsif Is_Internal_Name (Chars (Node))
and then
((Is_Entity_Name (Node)
and then Present (Entity (Node))
and then Is_Type (Entity (Node)))
or else
(Nkind (Node) = N_Defining_Identifier and then Is_Type (Node)))
and then Present (Entity (Node))
and then Is_Type (Entity (Node)))
or else
(Nkind (Node) = N_Defining_Identifier and then Is_Type (Node)))
then
if Nkind (Node) = N_Identifier then
Ent := Entity (Node);
@ -2826,7 +2837,8 @@ package body Errout is
Nam := Chars (Ent);
end if;
-- If not internal name, just use name in Chars field
-- If not internal name, or if we could not find a reasonable possible
-- substitution for the internal name, just use name in Chars field.
else
Nam := Chars (Node);
@ -2854,6 +2866,12 @@ package body Errout is
Kill_Message := True;
end if;
-- If we still have an internal name, kill the message (will only
-- work if we already had errors!)
if Is_Internal_Name then
Kill_Message := True;
end if;
-- Remaining step is to adjust casing and possibly add 'Class
Adjust_Name_Case (Loc);

7
gcc/ada/errout.ads
View File

@ -104,6 +104,13 @@ package Errout is
-- messages. Warning messages are only suppressed for case 1, and
-- when they come from other than the main extended unit.
-- 7. If an error or warning references an internal name, and we have
-- already placed an error (not warning) message at that location,
-- then we assume this is cascaded junk and delete the message.
-- This normal suppression action may be overridden in cases 2-5 (but not
-- in case 1 or 7 by setting All_Errors mode, or by setting the special
-- unconditional message insertion character (!) as described below.
-- This normal suppression action may be overridden in cases 2-5 (but
-- not in case 1) by setting All_Errors mode, or by setting the special
-- unconditional message insertion character (!) as described below.

39
gcc/ada/namet.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, 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- --
@ -833,8 +833,12 @@ package body Namet is
function Is_Internal_Name (Id : Name_Id) return Boolean is
begin
Get_Name_String (Id);
return Is_Internal_Name;
if Id in Error_Name_Or_No_Name then
return False;
else
Get_Name_String (Id);
return Is_Internal_Name;
end if;
end Is_Internal_Name;
----------------------
@ -844,18 +848,41 @@ package body Namet is
-- Version taking its input from Name_Buffer
function Is_Internal_Name return Boolean is
J : Natural;
begin
-- AAny name starting with underscore is internal
if Name_Buffer (1) = '_'
or else Name_Buffer (Name_Len) = '_'
then
return True;
-- Allow quoted character
elsif Name_Buffer (1) = ''' then
return False;
-- All other cases, scan name
else
-- Test backwards, because we only want to test the last entity
-- name if the name we have is qualified with other entities.
for J in reverse 1 .. Name_Len loop
if Is_OK_Internal_Letter (Name_Buffer (J)) then
J := Name_Len;
while J /= 0 loop
-- Skip stuff between brackets (A-F OK there)
if Name_Buffer (J) = ']' then
loop
J := J - 1;
exit when J = 1 or else Name_Buffer (J) = '[';
end loop;
-- Test for internal letter
elsif Is_OK_Internal_Letter (Name_Buffer (J)) then
return True;
-- Quit if we come to terminating double underscore (note that
@ -869,6 +896,8 @@ package body Namet is
then
return False;
end if;
J := J - 1;
end loop;
end if;

31
gcc/ada/sem_ch13.adb
View File

@ -6681,9 +6681,11 @@ package body Sem_Ch13 is
BHi : constant Uint := Expr_Value (Type_High_Bound (Btyp));
-- Low bound and high bound value of base type of Typ
TLo : constant Uint := Expr_Value (Type_Low_Bound (Typ));
THi : constant Uint := Expr_Value (Type_High_Bound (Typ));
-- Low bound and high bound values of static subtype Typ
TLo : Uint;
THi : Uint;
-- Bounds for constructing the static predicate. We use the bound of the
-- subtype if it is static, otherwise the corresponding base type bound.
-- Note: a non-static subtype can have a static predicate.
type REnt is record
Lo, Hi : Uint;
@ -7406,6 +7408,20 @@ package body Sem_Ch13 is
-- Start of processing for Build_Discrete_Static_Predicate
begin
-- Establish bounds for the predicate
if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
TLo := Expr_Value (Type_Low_Bound (Typ));
else
TLo := BLo;
end if;
if Compile_Time_Known_Value (Type_High_Bound (Typ)) then
THi := Expr_Value (Type_High_Bound (Typ));
else
THi := BHi;
end if;
-- Analyze the expression to see if it is a static predicate
declare
@ -8570,15 +8586,6 @@ package body Sem_Ch13 is
-- For discrete subtype, build the static predicate list
if Is_Discrete_Type (Typ) then
if not Is_Static_Subtype (Typ) then
-- This can only happen in the presence of previous
-- semantic errors.
pragma Assert (Serious_Errors_Detected > 0);
return;
end if;
Build_Discrete_Static_Predicate (Typ, Expr, Object_Name);
-- If we don't get a static predicate list, it means that we

32
gcc/ada/sem_ch8.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2015, 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- --
@ -6862,20 +6862,38 @@ package body Sem_Ch8 is
Premature_Usage (P);
elsif Nkind (P) /= N_Attribute_Reference then
Error_Msg_N (
"invalid prefix in selected component&", P);
-- This may have been meant as a prefixed call to a primitive
-- of an untagged type.
declare
F : constant Entity_Id :=
Current_Entity (Selector_Name (N));
begin
if Present (F)
and then Is_Overloadable (F)
and then Present (First_Entity (F))
and then Etype (First_Entity (F)) = Etype (P)
and then not Is_Tagged_Type (Etype (P))
then
Error_Msg_N
("prefixed call is only allowed for objects "
& "of a tagged type", N);
end if;
end;
Error_Msg_N ("invalid prefix in selected component&", P);
if Is_Access_Type (P_Type)
and then Ekind (Designated_Type (P_Type)) = E_Incomplete_Type
then
Error_Msg_N
("\dereference must not be of an incomplete type " &
"(RM 3.10.1)", P);
("\dereference must not be of an incomplete type "
& "(RM 3.10.1)", P);
end if;
else
Error_Msg_N (
"invalid prefix in selected component", P);
Error_Msg_N ("invalid prefix in selected component", P);
end if;
end if;