mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-06 05:10:29 +08:00
Code Issues Packages Projects Releases Wiki Activity

checks.adb (Safe_To_Capture_In_Parameter_Value): Deal with case expression (cannot count on a particular branch being executed).

Browse Source 
2010-06-18  Robert Dewar  <dewar@adacore.com>

	* checks.adb (Safe_To_Capture_In_Parameter_Value): Deal with case
	expression (cannot count on a particular branch being executed).
	* exp_ch4.adb (Expand_N_Case_Expression): New procedure.
	* exp_ch4.ads (Expand_N_Case_Expression): New procedure.
	* exp_util.adb (Insert_Actions): Deal with proper insertion of actions
	within case expression.
	* expander.adb (Expand): Add call to Expand_N_Case_Expression
	* par-ch4.adb Add calls to P_Case_Expression at appropriate points
	(P_Case_Expression): New procedure
	(P_Case_Expression_Alternative): New procedure
	* par.adb (P_Case_Expression): New procedure
	* par_sco.adb (Process_Decisions): Add dummy place holder entry for
	N_Case_Expression.
	* sem.adb (Analyze): Add call to Analyze_Case_Expression
	* sem_case.ads (Analyze_Choices): Also used for case expressions now,
	this is a documentation change only.
	* sem_ch4.ads, sem_ch4.adb (Analyze_Case_Expression): New procedure.
	* sem_ch6.adb (Fully_Conformant_Expressions): Add handling of case
	expressions.
	* sem_eval.ads, sem_eval.adb (Eval_Case_Expression): New procedure.
	* sem_res.adb (Resolve_Case_Expression): New procedure.
	* sem_scil.adb (Find_SCIL_Node): Add processing for
	N_Case_Expression_Alternative.
	* sinfo.ads, sinfo.adb (N_Case_Expression): New node.
	(N_Case_Expression_Alternative): New node.
	* sprint.adb (Sprint_Node_Actual): Add processing for new nodes
	N_Case_Expression and N_Case_Expression_Alternative.

2010-06-18  Robert Dewar  <dewar@adacore.com>

	* par-ch7.adb, sem_warn.adb, types.ads, par-ch3.adb: Minor reformatting.
	* gnat1drv.adb: Fix typo.

2010-06-18  Robert Dewar  <dewar@adacore.com>

	* par-prag.adb (Prag, case Style_Checks): All_Checks sets gnat style
	for -gnatg.
	* sem_prag.adb (Analyze_Pragma, case Style_Checks): All_Checks sets
	gnat style for -gnatg.
	* gnat_rm.texi: Add documentation for ALL_CHECKS in GNAT mode.

From-SVN: r160971
This commit is contained in:
Robert Dewar 2010-06-18 09:41:49 +00:00 committed by Arnaud Charlet
parent 305caf424d
commit 19d846a008
29 changed files with 978 additions and 241 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
gcc/ada/ChangeLog
View File

@ -1,3 +1,46 @@
2010-06-18 Robert Dewar <dewar@adacore.com>
* checks.adb (Safe_To_Capture_In_Parameter_Value): Deal with case
expression (cannot count on a particular branch being executed).
* exp_ch4.adb (Expand_N_Case_Expression): New procedure.
* exp_ch4.ads (Expand_N_Case_Expression): New procedure.
* exp_util.adb (Insert_Actions): Deal with proper insertion of actions
within case expression.
* expander.adb (Expand): Add call to Expand_N_Case_Expression
* par-ch4.adb Add calls to P_Case_Expression at appropriate points
(P_Case_Expression): New procedure
(P_Case_Expression_Alternative): New procedure
* par.adb (P_Case_Expression): New procedure
* par_sco.adb (Process_Decisions): Add dummy place holder entry for
N_Case_Expression.
* sem.adb (Analyze): Add call to Analyze_Case_Expression
* sem_case.ads (Analyze_Choices): Also used for case expressions now,
this is a documentation change only.
* sem_ch4.ads, sem_ch4.adb (Analyze_Case_Expression): New procedure.
* sem_ch6.adb (Fully_Conformant_Expressions): Add handling of case
expressions.
* sem_eval.ads, sem_eval.adb (Eval_Case_Expression): New procedure.
* sem_res.adb (Resolve_Case_Expression): New procedure.
* sem_scil.adb (Find_SCIL_Node): Add processing for
N_Case_Expression_Alternative.
* sinfo.ads, sinfo.adb (N_Case_Expression): New node.
(N_Case_Expression_Alternative): New node.
* sprint.adb (Sprint_Node_Actual): Add processing for new nodes
N_Case_Expression and N_Case_Expression_Alternative.
2010-06-18 Robert Dewar <dewar@adacore.com>
* par-ch7.adb, sem_warn.adb, types.ads, par-ch3.adb: Minor reformatting.
* gnat1drv.adb: Fix typo.
2010-06-18 Robert Dewar <dewar@adacore.com>
* par-prag.adb (Prag, case Style_Checks): All_Checks sets gnat style
for -gnatg.
* sem_prag.adb (Analyze_Pragma, case Style_Checks): All_Checks sets
gnat style for -gnatg.
* gnat_rm.texi: Add documentation for ALL_CHECKS in GNAT mode.
2010-06-18 Thomas Quinot <quinot@adacore.com>
* sem_eval.adb (Test_In_Range): New subprogram, factoring duplicated

22
gcc/ada/checks.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -2741,9 +2741,11 @@ package body Checks is
end case;
if K = N_Op_And then
Error_Msg_N ("use `AND THEN` instead of AND?", P);
Error_Msg_N -- CODEFIX
("use `AND THEN` instead of AND?", P);
else
Error_Msg_N ("use `OR ELSE` instead of OR?", P);
Error_Msg_N -- CODEFIX
("use `OR ELSE` instead of OR?", P);
end if;
-- If not short-circuited, we need the ckeck
@ -2849,7 +2851,7 @@ package body Checks is
-- applied to an access [sub]type.
if not Is_Access_Type (Typ) then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("`NOT NULL` allowed only for an access type", Error_Node);
-- Enforce legality rule RM 3.10(14/1): A null exclusion can only
@ -2858,7 +2860,7 @@ package body Checks is
elsif Can_Never_Be_Null (Typ)
and then Comes_From_Source (Typ)
then
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("`NOT NULL` not allowed (& already excludes null)",
Error_Node, Typ);
end if;
@ -5293,6 +5295,16 @@ package body Checks is
return False;
end if;
-- If we are in a case eexpression, and not part of the
-- expression, then we return False, since a particular
-- branch may not always be elaborated
if Nkind (P) = N_Case_Expression
and then N /= Expression (P)
then
return False;
end if;
-- While traversing the parent chain, we find that N
-- belongs to a statement, thus it may never appear in
-- a declarative region.

131
gcc/ada/exp_ch4.adb
View File

@ -3878,6 +3878,137 @@ package body Exp_Ch4 is
procedure Expand_N_And_Then (N : Node_Id)
renames Expand_Short_Circuit_Operator;
------------------------------
-- Expand_N_Case_Expression --
------------------------------
procedure Expand_N_Case_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Cstmt : Node_Id;
Tnn : Entity_Id;
Pnn : Entity_Id;
Actions : List_Id;
Ttyp : Entity_Id;
Alt : Node_Id;
Fexp : Node_Id;
begin
-- We expand
-- case X is when A => AX, when B => BX ...
-- to
-- do
-- Tnn : typ;
-- case X is
-- when A =>
-- Tnn := AX;
-- when B =>
-- Tnn := BX;
-- ...
-- end case;
-- in Tnn end;
-- However, this expansion is wrong for limited types, and also
-- wrong for unconstrained types (since the bounds may not be the
-- same in all branches). Furthermore it involves an extra copy
-- for large objects. So we take care of this by using the following
-- modified expansion for non-scalar types:
-- do
-- type Pnn is access all typ;
-- Tnn : Pnn;
-- case X is
-- when A =>
-- T := AX'Unrestricted_Access;
-- when B =>
-- T := BX'Unrestricted_Access;
-- ...
-- end case;
-- in Tnn.all end;
Cstmt :=
Make_Case_Statement (Loc,
Expression => Expression (N),
Alternatives => New_List);
Actions := New_List;
-- Scalar case
if Is_Scalar_Type (Typ) then
Ttyp := Typ;
else
Pnn := Make_Temporary (Loc, 'P');
Append_To (Actions,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Pnn,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Subtype_Indication =>
New_Reference_To (Typ, Loc))));
Ttyp := Pnn;
end if;
Tnn := Make_Temporary (Loc, 'T');
Append_To (Actions,
Make_Object_Declaration (Loc,
Defining_Identifier => Tnn,
Object_Definition => New_Occurrence_Of (Ttyp, Loc)));
-- Now process the alternatives
Alt := First (Alternatives (N));
while Present (Alt) loop
declare
Aexp : Node_Id := Expression (Alt);
Aloc : constant Source_Ptr := Sloc (Aexp);
begin
if not Is_Scalar_Type (Typ) then
Aexp :=
Make_Attribute_Reference (Aloc,
Prefix => Relocate_Node (Aexp),
Attribute_Name => Name_Unrestricted_Access);
end if;
Append_To
(Alternatives (Cstmt),
Make_Case_Statement_Alternative (Sloc (Alt),
Discrete_Choices => Discrete_Choices (Alt),
Statements => New_List (
Make_Assignment_Statement (Aloc,
Name => New_Occurrence_Of (Tnn, Loc),
Expression => Aexp))));
end;
Next (Alt);
end loop;
Append_To (Actions, Cstmt);
-- Construct and return final expression with actions
if Is_Scalar_Type (Typ) then
Fexp := New_Occurrence_Of (Tnn, Loc);
else
Fexp :=
Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Tnn, Loc));
end if;
Rewrite (N,
Make_Expression_With_Actions (Loc,
Expression => Fexp,
Actions => Actions));
Analyze_And_Resolve (N, Typ);
end Expand_N_Case_Expression;
-------------------------------------
-- Expand_N_Conditional_Expression --
-------------------------------------

3
gcc/ada/exp_ch4.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -31,6 +31,7 @@ package Exp_Ch4 is
procedure Expand_N_Allocator (N : Node_Id);
procedure Expand_N_And_Then (N : Node_Id);
procedure Expand_N_Case_Expression (N : Node_Id);
procedure Expand_N_Conditional_Expression (N : Node_Id);
procedure Expand_N_Explicit_Dereference (N : Node_Id);
procedure Expand_N_In (N : Node_Id);

16
gcc/ada/exp_util.adb
View File

@ -2417,6 +2417,21 @@ package body Exp_Util is
end if;
end;
-- Alternative of case expression, we place the action in
-- the Actions field of the case expression alternative, this
-- will be handled when the case expression is expanded.
when N_Case_Expression_Alternative =>
if Present (Actions (P)) then
Insert_List_After_And_Analyze
(Last (Actions (P)), Ins_Actions);
else
Set_Actions (P, Ins_Actions);
Analyze_List (Then_Actions (P));
end if;
return;
-- Case of appearing within an Expressions_With_Actions node. We
-- prepend the actions to the list of actions already there.
@ -2679,6 +2694,7 @@ package body Exp_Util is
N_Access_To_Object_Definition |
N_Aggregate |
N_Allocator |
N_Case_Expression |
N_Case_Statement_Alternative |
N_Character_Literal |
N_Compilation_Unit |

6
gcc/ada/expander.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -163,6 +163,9 @@ package body Expander is
when N_Block_Statement =>
Expand_N_Block_Statement (N);
when N_Case_Expression =>
Expand_N_Case_Expression (N);
when N_Case_Statement =>
Expand_N_Case_Statement (N);
@ -470,7 +473,6 @@ package body Expander is
Debug_A_Exit ("expanding ", N, " (done)");
end if;
end Expand;
---------------------------

2
gcc/ada/gnat1drv.adb
View File

@ -366,7 +366,7 @@ procedure Gnat1drv is
-- Debug flag -gnatd.L decisively sets usage on
if Debug_Flag_Dot_XX then
if Debug_Flag_Dot_LL then
Back_End_Handles_Limited_Types := True;
-- If no debug flag, usage off for AAMP, VM, SCIL cases

6
gcc/ada/gnat_rm.texi
View File

@ -4536,7 +4536,11 @@ gcc -c -gnatyl @dots{}
The form ALL_CHECKS activates all standard checks (its use is equivalent
to the use of the @code{gnaty} switch with no options. @xref{Top,
@value{EDITION} User's Guide, About This Guide, gnat_ugn,
@value{EDITION} User's Guide}, for details.
@value{EDITION} User's Guide}, for details.)
Note: the behavior is slightly different in GNAT mode (@option{-gnatg} used).
In this case, ALL_CHECKS implies the standard set of GNAT mode style check
options (i.e. equivalent to -gnatyg).
The forms with @code{Off} and @code{On}
can be used to temporarily disable style checks

1
gcc/ada/par-ch3.adb
View File

@ -111,7 +111,6 @@ package body Ch3 is
-- current token, and if this is the first such message issued, saves
-- the message id in Missing_Begin_Msg, for possible later replacement.
---------------------------------
-- Check_Restricted_Expression --
---------------------------------

169
gcc/ada/par-ch4.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -63,6 +63,7 @@ package body Ch4 is
function P_Aggregate_Or_Paren_Expr return Node_Id;
function P_Allocator return Node_Id;
function P_Case_Expression_Alternative return Node_Id;
function P_Record_Or_Array_Component_Association return Node_Id;
function P_Factor return Node_Id;
function P_Primary return Node_Id;
@ -366,7 +367,8 @@ package body Ch4 is
begin
if Token_Is_At_Start_Of_Line then
Restore_Scan_State (Scan_State); -- to apostrophe
Error_Msg_SC ("|""''"" should be "";""");
Error_Msg_SC -- CODEFIX???
("|""''"" should be "";""");
Token := Tok_Semicolon;
return True;
else
@ -738,7 +740,8 @@ package body Ch4 is
-- a possible fix.
if Nkind (Expr_Node) = N_Op_Eq then
Error_Msg_N ("\maybe `='>` was intended", Expr_Node);
Error_Msg_N -- CODEFIX???
("\maybe `='>` was intended", Expr_Node);
end if;
-- We go back to scanning out expressions, so that we do not get
@ -1089,7 +1092,7 @@ package body Ch4 is
and then
Nkind (Aggr_Node) /= N_Extension_Aggregate
then
Error_Msg
Error_Msg -- CODEFIX???
("aggregate may not have single positional component", Aggr_Sloc);
return Error;
else
@ -1164,6 +1167,13 @@ package body Ch4 is
T_Right_Paren;
return Expr_Node;
-- Case expression case
elsif Token = Tok_Case then
Expr_Node := P_Case_Expression;
T_Right_Paren;
return Expr_Node;
-- Note: the mechanism used here of rescanning the initial expression
-- is distinctly unpleasant, but it saves a lot of fiddling in scanning
-- out the discrete choice list.
@ -1254,7 +1264,7 @@ package body Ch4 is
if Nkind (Expr_Node) = N_Attribute_Reference
and then Attribute_Name (Expr_Node) = Name_Range
then
Error_Msg
Error_Msg -- CODEFIX???
("|parentheses not allowed for range attribute", Lparen_Sloc);
Scan; -- past right paren
return Expr_Node;
@ -1332,7 +1342,7 @@ package body Ch4 is
or else Token = Tok_Semicolon
then
if Present (Assoc_List) then
Error_Msg_BC
Error_Msg_BC -- CODEFIX
("""='>"" expected (positional association cannot follow " &
"named association)");
end if;
@ -1570,12 +1580,14 @@ package body Ch4 is
end P_Expression;
-- This function is identical to the normal P_Expression, except that it
-- also permits the appearence of a conditional expression without the
-- usual surrounding parentheses.
-- also permits the appearence of a case of conditional expression without
-- the usual surrounding parentheses.
function P_Expression_If_OK return Node_Id is
begin
if Token = Tok_If then
if Token = Tok_Case then
return P_Case_Expression;
elsif Token = Tok_If then
return P_Conditional_Expression;
else
return P_Expression;
@ -1672,11 +1684,13 @@ package body Ch4 is
end if;
end P_Expression_Or_Range_Attribute;
-- Version that allows a non-parenthesized conditional expression
-- Version that allows a non-parenthesized case or conditional expression
function P_Expression_Or_Range_Attribute_If_OK return Node_Id is
begin
if Token = Tok_If then
if Token = Tok_Case then
return P_Case_Expression;
elsif Token = Tok_If then
return P_Conditional_Expression;
else
return P_Expression_Or_Range_Attribute;
@ -2117,7 +2131,8 @@ package body Ch4 is
Scan; -- scan past right paren if present
end if;
Error_Msg ("parentheses not allowed for range attribute", Lptr);
Error_Msg -- CODEFIX???
("parentheses not allowed for range attribute", Lptr);
return Attr_Node;
end if;
@ -2339,10 +2354,10 @@ package body Ch4 is
return Error;
-- If this looks like a conditional expression, then treat it
-- that way with an error messasge.
-- that way with an error message.
elsif Extensions_Allowed then
Error_Msg_SC
Error_Msg_SC -- CODEFIX???
("conditional expression must be parenthesized");
return P_Conditional_Expression;
@ -2352,6 +2367,32 @@ package body Ch4 is
return P_Identifier;
end if;
-- Deal with CASE (possible unparenthesized case expression)
when Tok_Case =>
-- If this looks like a real case, defined as a CASE appearing
-- the start of a new line, then we consider we have a missing
-- operand.
if Token_Is_At_Start_Of_Line then
Error_Msg_AP ("missing operand");
return Error;
-- If this looks like a case expression, then treat it that way
-- with an error message.
elsif Extensions_Allowed then
Error_Msg_SC -- CODEFIX???
("case expression must be parenthesized");
return P_Case_Expression;
-- Otherwise treat as misused identifier
else
return P_Identifier;
end if;
-- Anything else is illegal as the first token of a primary, but
-- we test for a reserved identifier so that it is treated nicely
@ -2360,7 +2401,8 @@ package body Ch4 is
return P_Identifier;
elsif Prev_Token = Tok_Comma then
Error_Msg_SP ("|extra "","" ignored");
Error_Msg_SP -- CODEFIX
("|extra "","" ignored");
raise Error_Resync;
else
@ -2458,7 +2500,8 @@ package body Ch4 is
begin
if Token = Tok_Box then
Error_Msg_SC ("|""'<'>"" should be ""/=""");
Error_Msg_SC -- CODEFIX
("|""'<'>"" should be ""/=""");
end if;
Op_Kind := Relop_Node (Token);
@ -2620,6 +2663,95 @@ package body Ch4 is
return Alloc_Node;
end P_Allocator;
-----------------------
-- P_Case_Expression --
-----------------------
function P_Case_Expression return Node_Id is
Loc : constant Source_Ptr := Token_Ptr;
Case_Node : Node_Id;
Save_State : Saved_Scan_State;
begin
if not Extensions_Allowed then
Error_Msg_SC ("|case expression is an Ada extension");
Error_Msg_SC ("\|use -gnatX switch to compile this unit");
end if;
Scan; -- past CASE
Case_Node :=
Make_Case_Expression (Loc,
Expression => P_Expression_No_Right_Paren,
Alternatives => New_List);
T_Is;
-- We now have scanned out CASE expression IS, scan alternatives
loop
T_When;
Append_To (Alternatives (Case_Node), P_Case_Expression_Alternative);
-- Missing comma if WHEN (more alternatives present)
if Token = Tok_When then
T_Comma;
-- If comma/WHEN, skip comma and we have another alternative
elsif Token = Tok_Comma then
Save_Scan_State (Save_State);
Scan; -- past comma
if Token /= Tok_When then
Restore_Scan_State (Save_State);
exit;
end if;
-- If no comma or WHEN, definitely done
else
exit;
end if;
end loop;
-- If we have an END CASE, diagnose as not needed
if Token = Tok_End then
Error_Msg_SC -- CODEFIX???
("`END CASE` not allowed at end of case expression");
Scan; -- past END
if Token = Tok_Case then
Scan; -- past CASE;
end if;
end if;
-- Return the Case_Expression node
return Case_Node;
end P_Case_Expression;
-----------------------------------
-- P_Case_Expression_Alternative --
-----------------------------------
-- CASE_STATEMENT_ALTERNATIVE ::=
-- when DISCRETE_CHOICE_LIST =>
-- EXPRESSION
-- The caller has checked that and scanned past the initial WHEN token
-- Error recovery: can raise Error_Resync
function P_Case_Expression_Alternative return Node_Id is
Case_Alt_Node : Node_Id;
begin
Case_Alt_Node := New_Node (N_Case_Expression_Alternative, Token_Ptr);
Set_Discrete_Choices (Case_Alt_Node, P_Discrete_Choice_List);
TF_Arrow;
Set_Expression (Case_Alt_Node, P_Expression);
return Case_Alt_Node;
end P_Case_Expression_Alternative;
------------------------------
-- P_Conditional_Expression --
------------------------------
@ -2652,7 +2784,8 @@ package body Ch4 is
Scan; -- past semicolon
if Token = Tok_Else or else Token = Tok_Elsif then
Error_Msg_SP ("|extra "";"" ignored");
Error_Msg_SP -- CODEFIX
("|extra "";"" ignored");
else
Restore_Scan_State (State);
@ -2684,7 +2817,7 @@ package body Ch4 is
-- If we have an END IF, diagnose as not needed
if Token = Tok_End then
Error_Msg_SC
Error_Msg_SC -- CODEFIX???
("`END IF` not allowed at end of conditional expression");
Scan; -- past END

20
gcc/ada/par-ch7.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -69,10 +69,10 @@ package body Ch7 is
-- Pf_Flags.Rnam Set if renaming declaration OK
-- Pf_Flags.Stub Set if body stub OK
-- If an inappropriate form is encountered, it is scanned out but an
-- error message indicating that it is appearing in an inappropriate
-- context is issued. The only possible settings for Pf_Flags are those
-- defined as constants in package Par.
-- If an inappropriate form is encountered, it is scanned out but an error
-- message indicating that it is appearing in an inappropriate context is
-- issued. The only possible settings for Pf_Flags are those defined as
-- constants in package Par.
-- Note: in all contexts where a package specification is required, there
-- is a terminating semicolon. This semicolon is scanned out in the case
@ -101,7 +101,8 @@ package body Ch7 is
Scan; -- past PACKAGE
if Token = Tok_Type then
Error_Msg_SC ("TYPE not allowed here");
Error_Msg_SC -- CODEFIX
("TYPE not allowed here");
Scan; -- past TYPE
end if;
@ -204,7 +205,7 @@ package body Ch7 is
if Token_Is_At_Start_Of_Line
and then Start_Column /= Error_Msg_Col
then
Error_Msg_SC
Error_Msg_SC -- CODEFIX???
("(style) PRIVATE in wrong column, should be@");
end if;
end if;
@ -216,7 +217,7 @@ package body Ch7 is
-- Deal gracefully with multiple PRIVATE parts
while Token = Tok_Private loop
Error_Msg_SC
Error_Msg_SC -- CODEFIX???
("only one private part allowed per package");
Scan; -- past PRIVATE
Append_List (P_Basic_Declarative_Items,
@ -233,7 +234,8 @@ package body Ch7 is
end if;
if Token = Tok_Begin then
Error_Msg_SC ("begin block not allowed in package spec");
Error_Msg_SC -- CODEFIX???
("begin block not allowed in package spec");
Scan; -- past BEGIN
Discard_Junk_List (P_Sequence_Of_Statements (SS_None));
end if;

14
gcc/ada/par-prag.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -150,7 +150,7 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
Error_Msg_Name_2 := Name_On;
Error_Msg_Name_3 := Name_Off;
Error_Msg
Error_Msg -- CODEFIX???
("argument for pragma% must be% or%", Sloc (Argx));
raise Error_Resync;
end if;
@ -539,7 +539,7 @@ begin
for J in 1 .. Name_Len loop
if Is_Directory_Separator (Name_Buffer (J)) then
Error_Msg
Error_Msg -- CODEFIX???
("directory separator character not allowed",
Sloc (Expression (Arg)) + Source_Ptr (J));
end if;
@ -606,7 +606,7 @@ begin
end if;
end if;
Error_Msg_N
Error_Msg_N -- CODEFIX???
("Casing argument for pragma% must be " &
"one of Mixedcase, Lowercase, Uppercase",
Arg);
@ -943,7 +943,11 @@ begin
OK := False;
elsif Chars (A) = Name_All_Checks then
Stylesw.Set_Default_Style_Check_Options;
if GNAT_Mode then
Stylesw.Set_GNAT_Style_Check_Options;
else
Stylesw.Set_Default_Style_Check_Options;
end if;
elsif Chars (A) = Name_On then
Style_Check := True;

9
gcc/ada/par.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -676,8 +676,13 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
function P_Simple_Expression return Node_Id;
function P_Simple_Expression_Or_Range_Attribute return Node_Id;
function P_Case_Expression return Node_Id;
-- Scans out a case expression. Called with Token pointing to the CASE
-- keyword, and returns pointing to the terminating right parent,
-- semicolon, or comma, but does not consume this terminating token.
function P_Conditional_Expression return Node_Id;
-- Scans out a conditional expression. Called with token pointing to
-- Scans out a conditional expression. Called with Token pointing to
-- the IF keyword, and returns pointing to the terminating right paren,
-- semicolon or comma, but does not consume this terminating token.

7
gcc/ada/par_sco.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2009, Free Software Foundation, Inc. --
-- Copyright (C) 2009-2010, 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- --
@ -573,6 +573,11 @@ package body Par_SCO is
return Skip;
end;
-- Case expression
when N_Case_Expression =>
return OK; -- ???
-- Conditional expression, processed like an if statement
when N_Conditional_Expression =>

6
gcc/ada/sem.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -158,6 +158,9 @@ package body Sem is
when N_Block_Statement =>
Analyze_Block_Statement (N);
when N_Case_Expression =>
Analyze_Case_Expression (N);
when N_Case_Statement =>
Analyze_Case_Statement (N);
@ -632,6 +635,7 @@ package body Sem is
N_Access_Function_Definition |
N_Access_Procedure_Definition |
N_Access_To_Object_Definition |
N_Case_Expression_Alternative |
N_Case_Statement_Alternative |
N_Compilation_Unit_Aux |
N_Component_Association |

18
gcc/ada/sem_case.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1996-2008, Free Software Foundation, Inc. --
-- Copyright (C) 1996-2010, 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- --
@ -68,7 +68,7 @@ package Sem_Case is
-- Processing to carry out for a non static Choice
with procedure Process_Associated_Node (A : Node_Id);
-- Associated to each case alternative, aggregate component
-- Associated with each case alternative, aggregate component
-- association or record variant A there is a node or list of nodes
-- that need semantic processing. This routine implements that
-- processing.
@ -76,9 +76,9 @@ package Sem_Case is
package Generic_Choices_Processing is
function Number_Of_Choices (N : Node_Id) return Nat;
-- Iterates through the choices of N, (N can be a case statement,
-- array aggregate or record variant), counting all the Choice nodes
-- except for the Others choice.
-- Iterates through the choices of N, (N can be a case expression, case
-- statement, array aggregate or record variant), counting all the
-- Choice nodes except for the Others choice.
procedure Analyze_Choices
(N : Node_Id;
@ -87,10 +87,10 @@ package Sem_Case is
Last_Choice : out Nat;
Raises_CE : out Boolean;
Others_Present : out Boolean);
-- From a case statement, array aggregate or record variant N, this
-- routine analyzes the corresponding list of discrete choices.
-- Subtyp is the subtype of the discrete choices. The type against
-- which the discrete choices must be resolved is its base type.
-- From a case expression, case statement, array aggregate or record
-- variant N, this routine analyzes the corresponding list of discrete
-- choices. Subtyp is the subtype of the discrete choices. The type
-- against which the discrete choices must be resolved is its base type.
--
-- On entry Choice_Table must be big enough to contain all the discrete
-- choices encountered. The lower bound of Choice_Table must be one.

213
gcc/ada/sem_ch4.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -43,6 +43,7 @@ with Restrict; use Restrict;
with Rident; use Rident;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
@ -52,8 +53,9 @@ with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Stand; use Stand;
with Sinfo; use Sinfo;
with Snames; use Snames;
@ -305,10 +307,10 @@ package body Sem_Ch4 is
end if;
if Opnd = Left_Opnd (N) then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("\left operand has the following interpretations", N);
else
Error_Msg_N
Error_Msg_N -- CODEFIX???
("\right operand has the following interpretations", N);
Err := Opnd;
end if;
@ -320,13 +322,16 @@ package body Sem_Ch4 is
begin
if Nkind (N) in N_Membership_Test then
Error_Msg_N ("ambiguous operands for membership", N);
Error_Msg_N -- CODEFIX???
("ambiguous operands for membership", N);
elsif Nkind_In (N, N_Op_Eq, N_Op_Ne) then
Error_Msg_N ("ambiguous operands for equality", N);
Error_Msg_N -- CODEFIX???
("ambiguous operands for equality", N);
else
Error_Msg_N ("ambiguous operands for comparison", N);
Error_Msg_N -- CODEFIX???
("ambiguous operands for comparison", N);
end if;
if All_Errors_Mode then
@ -1048,6 +1053,141 @@ package body Sem_Ch4 is
end if;
end Analyze_Call;
-----------------------------
-- Analyze_Case_Expression --
-----------------------------
procedure Analyze_Case_Expression (N : Node_Id) is
Expr : constant Node_Id := Expression (N);
FirstX : constant Node_Id := Expression (First (Alternatives (N)));
Alt : Node_Id;
Exp_Type : Entity_Id;
Exp_Btype : Entity_Id;
Last_Choice : Nat;
Dont_Care : Boolean;
Others_Present : Boolean;
procedure Non_Static_Choice_Error (Choice : Node_Id);
-- Error routine invoked by the generic instantiation below when
-- the case expression has a non static choice.
package Case_Choices_Processing is new
Generic_Choices_Processing
(Get_Alternatives => Alternatives,
Get_Choices => Discrete_Choices,
Process_Empty_Choice => No_OP,
Process_Non_Static_Choice => Non_Static_Choice_Error,
Process_Associated_Node => No_OP);
use Case_Choices_Processing;
Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
-----------------------------
-- Non_Static_Choice_Error --
-----------------------------
procedure Non_Static_Choice_Error (Choice : Node_Id) is
begin
Flag_Non_Static_Expr
("choice given in case expression is not static!", Choice);
end Non_Static_Choice_Error;
-- Start of processing for Analyze_Case_Expression
begin
if Comes_From_Source (N) then
Check_Compiler_Unit (N);
end if;
Analyze_And_Resolve (Expr, Any_Discrete);
Check_Unset_Reference (Expr);
Exp_Type := Etype (Expr);
Exp_Btype := Base_Type (Exp_Type);
Alt := First (Alternatives (N));
while Present (Alt) loop
Analyze (Expression (Alt));
Next (Alt);
end loop;
if not Is_Overloaded (FirstX) then
Set_Etype (N, Etype (FirstX));
else
declare
I : Interp_Index;
It : Interp;
begin
Set_Etype (N, Any_Type);
Get_First_Interp (FirstX, I, It);
while Present (It.Nam) loop
-- For each intepretation of the first expression, we only
-- add the intepretation if every other expression in the
-- case expression alternatives has a compatible type.
Alt := Next (First (Alternatives (N)));
while Present (Alt) loop
exit when not Has_Compatible_Type (Expression (Alt), It.Typ);
Next (Alt);
end loop;
if No (Alt) then
Add_One_Interp (N, It.Typ, It.Typ);
end if;
Get_Next_Interp (I, It);
end loop;
end;
end if;
Exp_Btype := Base_Type (Exp_Type);
-- The expression must be of a discrete type which must be determinable
-- independently of the context in which the expression occurs, but
-- using the fact that the expression must be of a discrete type.
-- Moreover, the type this expression must not be a character literal
-- (which is always ambiguous).
-- If error already reported by Resolve, nothing more to do
if Exp_Btype = Any_Discrete
or else Exp_Btype = Any_Type
then
return;
elsif Exp_Btype = Any_Character then
Error_Msg_N
("character literal as case expression is ambiguous", Expr);
return;
end if;
-- If the case expression is a formal object of mode in out, then
-- treat it as having a nonstatic subtype by forcing use of the base
-- type (which has to get passed to Check_Case_Choices below). Also
-- use base type when the case expression is parenthesized.
if Paren_Count (Expr) > 0
or else (Is_Entity_Name (Expr)
and then Ekind (Entity (Expr)) = E_Generic_In_Out_Parameter)
then
Exp_Type := Exp_Btype;
end if;
-- Call instantiated Analyze_Choices which does the rest of the work
Analyze_Choices
(N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
if Exp_Type = Universal_Integer and then not Others_Present then
Error_Msg_N
("case on universal integer requires OTHERS choice", Expr);
end if;
end Analyze_Case_Expression;
---------------------------
-- Analyze_Comparison_Op --
---------------------------
@ -1263,8 +1403,13 @@ package body Sem_Ch4 is
Analyze_Expression (Else_Expr);
end if;
-- If then expression not overloaded, then that decides the type
if not Is_Overloaded (Then_Expr) then
Set_Etype (N, Etype (Then_Expr));
-- Case where then expression is overloaded
else
declare
I : Interp_Index;
@ -1274,6 +1419,12 @@ package body Sem_Ch4 is
Set_Etype (N, Any_Type);
Get_First_Interp (Then_Expr, I, It);
while Present (It.Nam) loop
-- For each possible intepretation of the Then Expression,
-- add it only if the else expression has a compatible type.
-- Is this right if Else_Expr is empty?
if Has_Compatible_Type (Else_Expr, It.Typ) then
Add_One_Interp (N, It.Typ, It.Typ);
end if;
@ -3997,20 +4148,24 @@ package body Sem_Ch4 is
elsif Nkind (Expr) = N_Null then
Error_Msg_N ("argument of conversion cannot be null", N);
Error_Msg_N ("\use qualified expression instead", N);
Error_Msg_N -- CODEFIX???
("\use qualified expression instead", N);
Set_Etype (N, Any_Type);
elsif Nkind (Expr) = N_Aggregate then
Error_Msg_N ("argument of conversion cannot be aggregate", N);
Error_Msg_N ("\use qualified expression instead", N);
Error_Msg_N -- CODEFIX???
("\use qualified expression instead", N);
elsif Nkind (Expr) = N_Allocator then
Error_Msg_N ("argument of conversion cannot be an allocator", N);
Error_Msg_N ("\use qualified expression instead", N);
Error_Msg_N -- CODEFIX???
("\use qualified expression instead", N);
elsif Nkind (Expr) = N_String_Literal then
Error_Msg_N ("argument of conversion cannot be string literal", N);
Error_Msg_N ("\use qualified expression instead", N);
Error_Msg_N -- CODEFIX???
("\use qualified expression instead", N);
elsif Nkind (Expr) = N_Character_Literal then
if Ada_Version = Ada_83 then
@ -4018,7 +4173,8 @@ package body Sem_Ch4 is
else
Error_Msg_N ("argument of conversion cannot be character literal",
N);
Error_Msg_N ("\use qualified expression instead", N);
Error_Msg_N -- CODEFIX???
("\use qualified expression instead", N);
end if;
elsif Nkind (Expr) = N_Attribute_Reference
@ -4028,7 +4184,8 @@ package body Sem_Ch4 is
Attribute_Name (Expr) = Name_Unrestricted_Access)
then
Error_Msg_N ("argument of conversion cannot be access", N);
Error_Msg_N ("\use qualified expression instead", N);
Error_Msg_N -- CODEFIX???
("\use qualified expression instead", N);
end if;
end Analyze_Type_Conversion;
@ -4502,7 +4659,7 @@ package body Sem_Ch4 is
and then From_With_Type (Etype (Actual))
then
Error_Msg_Qual_Level := 1;
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("missing with_clause for scope of imported type&",
Actual, Etype (Actual));
Error_Msg_Qual_Level := 0;
@ -5360,10 +5517,11 @@ package body Sem_Ch4 is
end if;
end if;
Error_Msg_NE
Error_Msg_NE -- CODEFIX
("operator for} is not directly visible!",
N, First_Subtype (Candidate_Type));
Error_Msg_N ("use clause would make operation legal!", N);
Error_Msg_N -- CODEFIX
("use clause would make operation legal!", N);
return;
-- If either operand is a junk operand (e.g. package name), then
@ -5522,9 +5680,9 @@ package body Sem_Ch4 is
(R,
Etype (Next_Formal (First_Formal (Op_Id))))
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("No legal interpretation for operator&", N);
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("\use clause on& would make operation legal",
N, Scope (Op_Id));
exit;
@ -6215,7 +6373,7 @@ package body Sem_Ch4 is
Prefix => Relocate_Node (Obj)));
if not Is_Aliased_View (Obj) then
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("object in prefixed call to& must be aliased"
& " (RM-2005 4.3.1 (13))",
Prefix (First_Actual), Subprog);
@ -6270,27 +6428,28 @@ package body Sem_Ch4 is
if Access_Formal and then not Access_Actual then
if Nkind (Parent (Op)) = N_Full_Type_Declaration then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("\possible interpretation"
& " (inherited, with implicit 'Access) #", N);
else
Error_Msg_N
Error_Msg_N -- CODEFIX???
("\possible interpretation (with implicit 'Access) #", N);
end if;
elsif not Access_Formal and then Access_Actual then
if Nkind (Parent (Op)) = N_Full_Type_Declaration then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("\possible interpretation"
& " ( inherited, with implicit dereference) #", N);
else
Error_Msg_N
Error_Msg_N -- CODEFIX???
("\possible interpretation (with implicit dereference) #", N);
end if;
else
if Nkind (Parent (Op)) = N_Full_Type_Declaration then
Error_Msg_N ("\possible interpretation (inherited)#", N);
Error_Msg_N -- CODEFIX???
("\possible interpretation (inherited)#", N);
else
Error_Msg_N -- CODEFIX
("\possible interpretation#", N);
@ -6491,7 +6650,8 @@ package body Sem_Ch4 is
if Present (Valid_Candidate (Success, Call_Node, Hom))
and then Nkind (Call_Node) /= N_Function_Call
then
Error_Msg_NE ("ambiguous call to&", N, Hom);
Error_Msg_NE -- CODEFIX???
("ambiguous call to&", N, Hom);
Report_Ambiguity (Matching_Op);
Report_Ambiguity (Hom);
Error := True;
@ -6908,7 +7068,8 @@ package body Sem_Ch4 is
if Present (Valid_Candidate (Success, Call_Node, Prim_Op))
and then Nkind (Call_Node) /= N_Function_Call
then
Error_Msg_NE ("ambiguous call to&", N, Prim_Op);
Error_Msg_NE -- CODEFIX???
("ambiguous call to&", N, Prim_Op);
Report_Ambiguity (Matching_Op);
Report_Ambiguity (Prim_Op);
return True;

3
gcc/ada/sem_ch4.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -30,6 +30,7 @@ package Sem_Ch4 is
procedure Analyze_Allocator (N : Node_Id);
procedure Analyze_Arithmetic_Op (N : Node_Id);
procedure Analyze_Call (N : Node_Id);
procedure Analyze_Case_Expression (N : Node_Id);
procedure Analyze_Comparison_Op (N : Node_Id);
procedure Analyze_Concatenation (N : Node_Id);
procedure Analyze_Conditional_Expression (N : Node_Id);

139
gcc/ada/sem_ch6.adb
View File

@ -315,7 +315,7 @@ package body Sem_Ch6 is
-- extended_return_statement.
if Returns_Object then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("extended_return_statement cannot return value; " &
"use `""RETURN;""`", N);
end if;
@ -1126,7 +1126,8 @@ package body Sem_Ch6 is
and then No (Actuals)
and then Comes_From_Source (N)
then
Error_Msg_N ("missing explicit dereference in call", N);
Error_Msg_N -- CODEFIX???
("missing explicit dereference in call", N);
end if;
Analyze_Call_And_Resolve;
@ -1174,7 +1175,8 @@ package body Sem_Ch6 is
if Present (Actuals) then
Analyze_Call_And_Resolve;
else
Error_Msg_N ("missing explicit dereference in call ", N);
Error_Msg_N -- CODEFIX???
("missing explicit dereference in call ", N);
end if;
-- If not an access to subprogram, then the prefix must resolve to the
@ -1827,20 +1829,20 @@ package body Sem_Ch6 is
null;
elsif not Is_Overriding_Operation (Spec_Id) then
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("subprogram& is not overriding", Body_Spec, Spec_Id);
end if;
elsif Must_Not_Override (Body_Spec) then
if Is_Overriding_Operation (Spec_Id) then
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("subprogram& overrides inherited operation",
Body_Spec, Spec_Id);
elsif Nkind (Spec_Id) = N_Defining_Operator_Symbol
and then Operator_Matches_Spec (Spec_Id, Spec_Id)
then
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("subprogram & overrides predefined operator ",
Body_Spec, Spec_Id);
@ -1850,9 +1852,10 @@ package body Sem_Ch6 is
elsif not Is_Primitive (Spec_Id)
and then Ekind (Scope (Spec_Id)) /= E_Protected_Type
then
Error_Msg_N ("overriding indicator only allowed " &
"if subprogram is primitive",
Body_Spec);
Error_Msg_N -- CODEFIX???
("overriding indicator only allowed " &
"if subprogram is primitive",
Body_Spec);
end if;
elsif Style_Check -- ??? incorrect use of Style_Check!
@ -2057,7 +2060,8 @@ package body Sem_Ch6 is
Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
if Is_Abstract_Subprogram (Spec_Id) then
Error_Msg_N ("an abstract subprogram cannot have a body", N);
Error_Msg_N -- CODEFIX???
("an abstract subprogram cannot have a body", N);
return;
else
@ -2634,7 +2638,7 @@ package body Sem_Ch6 is
end loop;
if Is_Protected_Type (Current_Scope) then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("protected operation cannot be a null procedure", N);
end if;
end if;
@ -2731,7 +2735,7 @@ package body Sem_Ch6 is
and then Null_Present (Specification (N)))
then
Error_Msg_Name_1 := Chars (Defining_Entity (N));
Error_Msg_N
Error_Msg_N -- CODEFIX???
("(Ada 2005) interface subprogram % must be abstract or null",
N);
end if;
@ -2908,7 +2912,7 @@ package body Sem_Ch6 is
and then
(Nkind (Parent (N))) /= N_Formal_Abstract_Subprogram_Declaration
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("function that returns abstract type must be abstract", N);
end if;
end if;
@ -4003,7 +4007,7 @@ package body Sem_Ch6 is
if Is_Interface_Conformant (Typ, Iface_Prim, Op)
and then Convention (Iface_Prim) /= Convention (Op)
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("inconsistent conventions in primitive operations", Typ);
Error_Msg_Name_1 := Chars (Op);
@ -4012,24 +4016,28 @@ package body Sem_Ch6 is
if Comes_From_Source (Op) then
if not Is_Overriding_Operation (Op) then
Error_Msg_N ("\\primitive % defined #", Typ);
Error_Msg_N -- CODEFIX???
("\\primitive % defined #", Typ);
else
Error_Msg_N ("\\overriding operation % with " &
"convention % defined #", Typ);
Error_Msg_N -- CODEFIX???
("\\overriding operation % with " &
"convention % defined #", Typ);
end if;
else pragma Assert (Present (Alias (Op)));
Error_Msg_Sloc := Sloc (Alias (Op));
Error_Msg_N ("\\inherited operation % with " &
"convention % defined #", Typ);
Error_Msg_N -- CODEFIX???
("\\inherited operation % with " &
"convention % defined #", Typ);
end if;
Error_Msg_Name_1 := Chars (Op);
Error_Msg_Name_2 :=
Get_Convention_Name (Convention (Iface_Prim));
Error_Msg_Sloc := Sloc (Iface_Prim);
Error_Msg_N ("\\overridden operation % with " &
"convention % defined #", Typ);
Error_Msg_N -- CODEFIX???
("\\overridden operation % with " &
"convention % defined #", Typ);
-- Avoid cascading errors
@ -4447,7 +4455,8 @@ package body Sem_Ch6 is
then
Error_Msg_Node_2 := Alias (Overridden_Subp);
Error_Msg_Sloc := Sloc (Error_Msg_Node_2);
Error_Msg_NE ("& does not match corresponding formal of&#",
Error_Msg_NE -- CODEFIX???
("& does not match corresponding formal of&#",
Form1, Form1);
exit;
end if;
@ -6074,8 +6083,9 @@ package body Sem_Ch6 is
when N_Aggregate =>
return
FCL (Expressions (E1), Expressions (E2))
and then FCL (Component_Associations (E1),
Component_Associations (E2));
and then
FCL (Component_Associations (E1),
Component_Associations (E2));
when N_Allocator =>
if Nkind (Expression (E1)) = N_Qualified_Expression
@ -6145,6 +6155,38 @@ package body Sem_Ch6 is
and then
FCE (Right_Opnd (E1), Right_Opnd (E2));
when N_Case_Expression =>
declare
Alt1 : Node_Id;
Alt2 : Node_Id;
begin
if not FCE (Expression (E1), Expression (E2)) then
return False;
else
Alt1 := First (Alternatives (E1));
Alt2 := First (Alternatives (E2));
loop
if Present (Alt1) /= Present (Alt2) then
return False;
elsif No (Alt1) then
return True;
end if;
if not FCE (Expression (Alt1), Expression (Alt2))
or else not FCL (Discrete_Choices (Alt1),
Discrete_Choices (Alt2))
then
return False;
end if;
Next (Alt1);
Next (Alt2);
end loop;
end if;
end;
when N_Character_Literal =>
return
Char_Literal_Value (E1) = Char_Literal_Value (E2);
@ -6152,7 +6194,8 @@ package body Sem_Ch6 is
when N_Component_Association =>
return
FCL (Choices (E1), Choices (E2))
and then FCE (Expression (E1), Expression (E2));
and then
FCE (Expression (E1), Expression (E2));
when N_Conditional_Expression =>
return
@ -6173,13 +6216,15 @@ package body Sem_Ch6 is
when N_Function_Call =>
return
FCE (Name (E1), Name (E2))
and then FCL (Parameter_Associations (E1),
Parameter_Associations (E2));
and then
FCL (Parameter_Associations (E1),
Parameter_Associations (E2));
when N_Indexed_Component =>
return
FCE (Prefix (E1), Prefix (E2))
and then FCL (Expressions (E1), Expressions (E2));
and then
FCL (Expressions (E1), Expressions (E2));
when N_Integer_Literal =>
return (Intval (E1) = Intval (E2));
@ -6203,12 +6248,14 @@ package body Sem_Ch6 is
when N_Qualified_Expression =>
return
FCE (Subtype_Mark (E1), Subtype_Mark (E2))
and then FCE (Expression (E1), Expression (E2));
and then
FCE (Expression (E1), Expression (E2));
when N_Range =>
return
FCE (Low_Bound (E1), Low_Bound (E2))
and then FCE (High_Bound (E1), High_Bound (E2));
and then
FCE (High_Bound (E1), High_Bound (E2));
when N_Real_Literal =>
return (Realval (E1) = Realval (E2));
@ -6216,12 +6263,14 @@ package body Sem_Ch6 is
when N_Selected_Component =>
return
FCE (Prefix (E1), Prefix (E2))
and then FCE (Selector_Name (E1), Selector_Name (E2));
and then
FCE (Selector_Name (E1), Selector_Name (E2));
when N_Slice =>
return
FCE (Prefix (E1), Prefix (E2))
and then FCE (Discrete_Range (E1), Discrete_Range (E2));
and then
FCE (Discrete_Range (E1), Discrete_Range (E2));
when N_String_Literal =>
declare
@ -6250,17 +6299,20 @@ package body Sem_Ch6 is
when N_Type_Conversion =>
return
FCE (Subtype_Mark (E1), Subtype_Mark (E2))
and then FCE (Expression (E1), Expression (E2));
and then
FCE (Expression (E1), Expression (E2));
when N_Unary_Op =>
return
Entity (E1) = Entity (E2)
and then FCE (Right_Opnd (E1), Right_Opnd (E2));
and then
FCE (Right_Opnd (E1), Right_Opnd (E2));
when N_Unchecked_Type_Conversion =>
return
FCE (Subtype_Mark (E1), Subtype_Mark (E2))
and then FCE (Expression (E1), Expression (E2));
and then
FCE (Expression (E1), Expression (E2));
-- All other node types cannot appear in this context. Strictly
-- we should raise a fatal internal error. Instead we just ignore
@ -6864,18 +6916,19 @@ package body Sem_Ch6 is
and then (not Is_Overriding
or else not Is_Abstract_Subprogram (E))
then
Error_Msg_N ("abstract subprograms must be visible "
& "(RM 3.9.3(10))!", S);
Error_Msg_N -- CODEFIX???
("abstract subprograms must be visible "
& "(RM 3.9.3(10))!", S);
elsif Ekind (S) = E_Function
and then Is_Tagged_Type (T)
and then T = Base_Type (Etype (S))
and then not Is_Overriding
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("private function with tagged result must"
& " override visible-part function", S);
Error_Msg_N
Error_Msg_N -- CODEFIX???
("\move subprogram to the visible part"
& " (RM 3.9.3(10))", S);
end if;
@ -8031,14 +8084,14 @@ package body Sem_Ch6 is
and then Null_Exclusion_Present (Param_Spec)
then
if not Is_Access_Type (Formal_Type) then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("`NOT NULL` allowed only for an access type", Param_Spec);
else
if Can_Never_Be_Null (Formal_Type)
and then Comes_From_Source (Related_Nod)
then
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("`NOT NULL` not allowed (& already excludes null)",
Param_Spec,
Formal_Type);
@ -8096,7 +8149,7 @@ package body Sem_Ch6 is
if Present (Default) then
if Out_Present (Param_Spec) then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("default initialization only allowed for IN parameters",
Param_Spec);
end if;
@ -8760,7 +8813,7 @@ package body Sem_Ch6 is
N := N + 1;
if Present (Default_Value (F)) then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("default values not allowed for operator parameters",
Parent (F));
end if;

28
gcc/ada/sem_eval.adb
View File

@ -1666,6 +1666,27 @@ package body Sem_Eval is
end if;
end Eval_Call;
--------------------------
-- Eval_Case_Expression --
--------------------------
-- Right now we do not attempt folding of any case expressions, and the
-- language does not require it, so the only required processing is to
-- do the check for all expressions appearing in the case expression.
procedure Eval_Case_Expression (N : Node_Id) is
Alt : Node_Id;
begin
Check_Non_Static_Context (Expression (N));
Alt := First (Alternatives (N));
while Present (Alt) loop
Check_Non_Static_Context (Expression (Alt));
Next (Alt);
end loop;
end Eval_Case_Expression;
------------------------
-- Eval_Concatenation --
------------------------
@ -1783,15 +1804,14 @@ package body Sem_Eval is
-- Eval_Conditional_Expression --
---------------------------------
-- This GNAT internal construct can never be statically folded, so the
-- only required processing is to do the check for non-static context
-- for the two expression operands.
-- We never attempt folding of conditional expressions (and the language)
-- does not require it, so the only required processing is to do the check
-- for non-static context for the then and else expressions.
procedure Eval_Conditional_Expression (N : Node_Id) is
Condition : constant Node_Id := First (Expressions (N));
Then_Expr : constant Node_Id := Next (Condition);
Else_Expr : constant Node_Id := Next (Then_Expr);
begin
Check_Non_Static_Context (Then_Expr);
Check_Non_Static_Context (Else_Expr);

3
gcc/ada/sem_eval.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -282,6 +282,7 @@ package Sem_Eval is
procedure Eval_Allocator (N : Node_Id);
procedure Eval_Arithmetic_Op (N : Node_Id);
procedure Eval_Call (N : Node_Id);
procedure Eval_Case_Expression (N : Node_Id);
procedure Eval_Character_Literal (N : Node_Id);
procedure Eval_Concatenation (N : Node_Id);
procedure Eval_Conditional_Expression (N : Node_Id);

69
gcc/ada/sem_prag.adb
View File

@ -1049,7 +1049,8 @@ package body Sem_Prag is
("parameters out of order for pragma%", Arg);
Error_Msg_Name_1 := Names (K);
Error_Msg_Name_2 := Names (Highest_So_Far);
Error_Msg_N ("\% must appear before %", Arg);
Error_Msg_N -- CODEFIX???
("\% must appear before %", Arg);
raise Pragma_Exit;
else
@ -2617,7 +2618,7 @@ package body Sem_Prag is
else
if Warn_On_Export_Import and not OpenVMS_On_Target then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("?unrecognized convention name, C assumed",
Expression (Arg1));
end if;
@ -3728,11 +3729,11 @@ package body Sem_Prag is
-- these types have been supported this way for some time.
if not Is_Limited_Type (Def_Id) then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("imported 'C'P'P type should be " &
"explicitly declared limited?",
Get_Pragma_Arg (Arg2));
Error_Msg_N
Error_Msg_N -- CODEFIX???
("\type will be considered limited",
Get_Pragma_Arg (Arg2));
end if;
@ -3854,7 +3855,8 @@ package body Sem_Prag is
if Front_End_Inlining
and then Analyzed (Corresponding_Body (Decl))
then
Error_Msg_N ("pragma appears too late, ignored?", N);
Error_Msg_N -- CODEFIX???
("pragma appears too late, ignored?", N);
return True;
-- If the subprogram is a renaming as body, the body is just a
@ -4078,10 +4080,10 @@ package body Sem_Prag is
and then not Suppress_All_Inlining
then
if Inlining_Not_Possible (Subp) then
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("pragma Inline for& is ignored?", N, Entity (Subp_Id));
else
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("pragma Inline for& is redundant?", N, Entity (Subp_Id));
end if;
end if;
@ -4153,7 +4155,7 @@ package body Sem_Prag is
or else
Get_Character (C) = '/'))
then
Error_Msg
Error_Msg -- CODEFIX???
("?interface name contains illegal character",
Sloc (SN) + Source_Ptr (J));
end if;
@ -4687,11 +4689,11 @@ package body Sem_Prag is
procedure Set_Exported (E : Entity_Id; Arg : Node_Id) is
begin
if Is_Imported (E) then
Error_Pragma_Arg
Error_Pragma_Arg -- CODEFIX???
("cannot export entity& that was previously imported", Arg);
elsif Present (Address_Clause (E)) then
Error_Pragma_Arg
Error_Pragma_Arg -- CODEFIX???
("cannot export entity& that has an address clause", Arg);
end if;
@ -4710,7 +4712,8 @@ package body Sem_Prag is
-- Not allowed at all for subprograms
if Is_Subprogram (E) then
Error_Pragma_Arg ("local subprogram& cannot be exported", Arg);
Error_Pragma_Arg -- CODEFIX???
("local subprogram& cannot be exported", Arg);
-- Otherwise set public and statically allocated
@ -4736,7 +4739,7 @@ package body Sem_Prag is
end if;
if Warn_On_Export_Import and then Is_Type (E) then
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("exporting a type has no effect?", Arg, E);
end if;
@ -4859,7 +4862,8 @@ package body Sem_Prag is
("\(pragma% applies to all previous entities)", N);
Error_Msg_Sloc := Sloc (E);
Error_Msg_NE ("\import not allowed for& declared#", N, E);
Error_Msg_NE -- CODEFIX???
("\import not allowed for& declared#", N, E);
-- Here if not previously imported or exported, OK to import
@ -6372,7 +6376,7 @@ package body Sem_Prag is
begin
if Warn_On_Obsolescent_Feature then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("'G'N'A'T pragma cpp'_class is now obsolete; replace it" &
" by pragma import?", N);
end if;
@ -6408,7 +6412,7 @@ package body Sem_Prag is
-- been supported this way for some time.
if not Is_Limited_Type (Typ) then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("imported 'C'P'P type should be " &
"explicitly declared limited?",
Get_Pragma_Arg (Arg1));
@ -6571,7 +6575,7 @@ package body Sem_Prag is
GNAT_Pragma;
if Warn_On_Obsolescent_Feature then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("'G'N'A'T pragma cpp'_virtual is now obsolete and has " &
"no effect?", N);
end if;
@ -6586,7 +6590,7 @@ package body Sem_Prag is
GNAT_Pragma;
if Warn_On_Obsolescent_Feature then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("'G'N'A'T pragma cpp'_vtable is now obsolete and has " &
"no effect?", N);
end if;
@ -6829,7 +6833,7 @@ package body Sem_Prag is
if Elab_Warnings and not Dynamic_Elaboration_Checks then
Error_Msg_N
("?use of pragma Elaborate may not be safe", N);
Error_Msg_N
Error_Msg_N -- CODEFIX???
("?use pragma Elaborate_All instead if possible", N);
end if;
end Elaborate;
@ -10467,13 +10471,13 @@ package body Sem_Prag is
Check_Too_Long (Internal);
if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then
Error_Pragma_Arg
Error_Pragma_Arg -- CODEFIX???
("cannot use pragma% for imported/exported object",
Internal);
end if;
if Is_Concurrent_Type (Etype (Internal)) then
Error_Pragma_Arg
Error_Pragma_Arg -- CODEFIX???
("cannot specify pragma % for task/protected object",
Internal);
end if;
@ -10486,7 +10490,7 @@ package body Sem_Prag is
end if;
if Ekind (Def_Id) = E_Constant then
Error_Pragma_Arg
Error_Pragma_Arg -- CODEFIX???
("cannot specify pragma % for a constant", Internal);
end if;
@ -10647,8 +10651,9 @@ package body Sem_Prag is
if not Effective
and then Warn_On_Redundant_Constructs
then
Error_Msg_NE ("pragma Pure_Function on& is redundant?",
N, Entity (E_Id));
Error_Msg_NE -- CODEFIX???
("pragma Pure_Function on& is redundant?",
N, Entity (E_Id));
end if;
end if;
end Pure_Function;
@ -10821,9 +10826,9 @@ package body Sem_Prag is
Set_Ravenscar_Profile (N);
if Warn_On_Obsolescent_Feature then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("pragma Ravenscar is an obsolescent feature?", N);
Error_Msg_N
Error_Msg_N -- CODEFIX???
("|use pragma Profile (Ravenscar) instead", N);
end if;
@ -10841,9 +10846,9 @@ package body Sem_Prag is
(Restricted, N, Warn => Treat_Restrictions_As_Warnings);
if Warn_On_Obsolescent_Feature then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("pragma Restricted_Run_Time is an obsolescent feature?", N);
Error_Msg_N
Error_Msg_N -- CODEFIX???
("|use pragma Profile (Restricted) instead", N);
end if;
@ -11327,7 +11332,11 @@ package body Sem_Prag is
elsif Nkind (A) = N_Identifier then
if Chars (A) = Name_All_Checks then
Set_Default_Style_Check_Options;
if GNAT_Mode then
Set_GNAT_Style_Check_Options;
else
Set_Default_Style_Check_Options;
end if;
elsif Chars (A) = Name_On then
Style_Check := True;
@ -11790,14 +11799,14 @@ package body Sem_Prag is
return;
elsif Is_Limited_Type (Typ) then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("Unchecked_Union must not be limited record type", Typ);
Explain_Limited_Type (Typ, Typ);
return;
else
if not Has_Discriminants (Typ) then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("Unchecked_Union must have one discriminant", Typ);
return;
end if;

26
gcc/ada/sem_res.adb
View File

@ -160,6 +160,7 @@ package body Sem_Res is
procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Call (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Conditional_Expression (N : Node_Id; Typ : Entity_Id);
@ -2187,6 +2188,9 @@ package body Sem_Res is
Set_Entity (N, Seen);
Generate_Reference (Seen, N);
elsif Nkind (N) = N_Case_Expression then
Set_Etype (N, Expr_Type);
elsif Nkind (N) = N_Character_Literal then
Set_Etype (N, Expr_Type);
@ -2542,6 +2546,9 @@ package body Sem_Res is
when N_Attribute_Reference
=> Resolve_Attribute (N, Ctx_Type);
when N_Case_Expression
=> Resolve_Case_Expression (N, Ctx_Type);
when N_Character_Literal
=> Resolve_Character_Literal (N, Ctx_Type);
@ -2640,7 +2647,6 @@ package body Sem_Res is
when N_Unchecked_Type_Conversion =>
Resolve_Unchecked_Type_Conversion (N, Ctx_Type);
end case;
-- If the subexpression was replaced by a non-subexpression, then
@ -5471,6 +5477,24 @@ package body Sem_Res is
Warn_On_Overlapping_Actuals (Nam, N);
end Resolve_Call;
-----------------------------
-- Resolve_Case_Expression --
-----------------------------
procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id) is
Alt : Node_Id;
begin
Alt := First (Alternatives (N));
while Present (Alt) loop
Resolve (Expression (Alt), Typ);
Next (Alt);
end loop;
Set_Etype (N, Typ);
Eval_Case_Expression (N);
end Resolve_Case_Expression;
-------------------------------
-- Resolve_Character_Literal --
-------------------------------

12
gcc/ada/sem_scil.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2009, Free Software Foundation, Inc. --
-- Copyright (C) 2009-2010, 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- --
@ -317,6 +317,15 @@ package body Sem_SCIL is
return Found_Node;
end if;
-- Actions of case expressions
when N_Case_Expression_Alternative =>
if Present (Actions (P))
and then Find_SCIL_Node (Actions (P))
then
return Found_Node;
end if;
-- Actions of conditional expressions
when N_Conditional_Expression =>
@ -513,6 +522,7 @@ package body Sem_SCIL is
N_Access_To_Object_Definition |
N_Aggregate |
N_Allocator |
N_Case_Expression |
N_Case_Statement_Alternative |
N_Character_Literal |
N_Compilation_Unit |

132
gcc/ada/sem_warn.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1999-2010, 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- --
@ -199,7 +199,7 @@ package body Sem_Warn is
Setup_Asm_Inputs (N);
if No (Asm_Input_Value) then
Error_Msg_F
Error_Msg_F -- CODEFIX???
("?code statement with no inputs should usually be Volatile!", N);
return;
end if;
@ -207,7 +207,7 @@ package body Sem_Warn is
Setup_Asm_Outputs (N);
if No (Asm_Output_Variable) then
Error_Msg_F
Error_Msg_F -- CODEFIX???
("?code statement with no outputs should usually be Volatile!", N);
return;
end if;
@ -218,7 +218,7 @@ package body Sem_Warn is
and then Present (Prev (N))
and then Nkind (Prev (N)) = N_Code_Statement
then
Error_Msg_F
Error_Msg_F -- CODEFIX???
("?code statements in sequence should usually be Volatile!", N);
Error_Msg_F
("\?(suggest using template with multiple instructions)!", N);
@ -1083,7 +1083,7 @@ package body Sem_Warn is
if (Is_Volatile (E1) or else Has_Volatile_Components (E1))
and then not Is_Imported (E1)
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("?& is not modified, volatile has no effect!", E1);
-- Another special case, Exception_Occurrence, this catches
@ -1275,7 +1275,7 @@ package body Sem_Warn is
and then Present (Hiding_Loop_Variable (E1))
and then not Warnings_Off_E1
then
Error_Msg_N
Error_Msg_N -- CODEFIX???
("?for loop implicitly declares loop variable!",
Hiding_Loop_Variable (E1));
@ -1463,12 +1463,9 @@ package body Sem_Warn is
-- a separate spec.
and then not (Is_Formal (E1)
and then
Ekind (Scope (E1)) = E_Subprogram_Body
and then
Present (Spec_Entity (E1))
and then
Referenced (Spec_Entity (E1)))
and then Ekind (Scope (E1)) = E_Subprogram_Body
and then Present (Spec_Entity (E1))
and then Referenced (Spec_Entity (E1)))
-- Consider private type referenced if full view is referenced.
-- If there is not full view, this is a generic type on which
@ -1476,8 +1473,7 @@ package body Sem_Warn is
and then
not (Is_Private_Type (E1)
and then
Present (Full_View (E1))
and then Present (Full_View (E1))
and then Referenced (Full_View (E1)))
-- Don't worry about full view, only about private type
@ -1507,16 +1503,15 @@ package body Sem_Warn is
-- be non-referenced, since they start up tasks!
and then ((Ekind (E1) /= E_Variable
and then Ekind (E1) /= E_Constant
and then Ekind (E1) /= E_Component)
or else not Is_Task_Type (E1T))
and then Ekind (E1) /= E_Constant
and then Ekind (E1) /= E_Component)
or else not Is_Task_Type (E1T))
-- For subunits, only place warnings on the main unit itself,
-- since parent units are not completely compiled.
and then (Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit
or else
Get_Source_Unit (E1) = Main_Unit)
or else Get_Source_Unit (E1) = Main_Unit)
-- No warning on a return object, because these are often
-- created with a single expression and an implicit return.
@ -1531,9 +1526,8 @@ package body Sem_Warn is
-- since they refer to problems in internal units).
if GNAT_Mode
or else not
Is_Internal_File_Name
(Unit_File_Name (Get_Source_Unit (E1)))
or else not Is_Internal_File_Name
(Unit_File_Name (Get_Source_Unit (E1)))
then
-- We do not immediately flag the error. This is because we
-- have not expanded generic bodies yet, and they may have
@ -2103,7 +2097,7 @@ package body Sem_Warn is
while Present (Nam) loop
if Entity (Nam) = Pack then
Error_Msg_Qual_Level := 1;
Error_Msg_NE
Error_Msg_NE -- CODEFIX
("?no entities of package& are referenced!",
Nam, Pack);
Error_Msg_Qual_Level := 0;
@ -2300,7 +2294,7 @@ package body Sem_Warn is
-- else or a pragma elaborate with a body library task).
elsif Has_Visible_Entities (Entity (Name (Item))) then
Error_Msg_N
Error_Msg_N -- CODEFIX
("?unit& is not referenced!", Name (Item));
end if;
end if;
@ -2377,7 +2371,7 @@ package body Sem_Warn is
if not
Has_Unreferenced (Entity (Name (Item)))
then
Error_Msg_N
Error_Msg_N -- CODEFIX
("?no entities of & are referenced!",
Name (Item));
end if;
@ -2393,7 +2387,7 @@ package body Sem_Warn is
and then not Has_Warnings_Off (Lunit)
and then not Has_Unreferenced (Pack)
then
Error_Msg_NE
Error_Msg_NE -- CODEFIX
("?no entities of & are referenced!",
Unit_Declaration_Node (Pack),
Pack);
@ -2433,12 +2427,12 @@ package body Sem_Warn is
end if;
if Unreferenced_In_Spec (Item) then
Error_Msg_N
Error_Msg_N -- CODEFIX
("?unit& is not referenced in spec!",
Name (Item));
elsif No_Entities_Ref_In_Spec (Item) then
Error_Msg_N
Error_Msg_N -- CODEFIX
("?no entities of & are referenced in spec!",
Name (Item));
@ -2777,7 +2771,7 @@ package body Sem_Warn is
if Warn_On_Constant then
Error_Msg_N
("?formal parameter & is not modified!", E1);
Error_Msg_N
Error_Msg_N -- CODEFIX???
("\?mode could be IN instead of `IN OUT`!", E1);
-- We do not generate warnings for IN OUT parameters
@ -2787,8 +2781,9 @@ package body Sem_Warn is
-- default mode.
elsif Check_Unreferenced then
Error_Msg_N ("?formal parameter& is read but "
& "never assigned!", E1);
Error_Msg_N -- CODEFIX???
("?formal parameter& is read but "
& "never assigned!", E1);
end if;
end if;
@ -2973,21 +2968,21 @@ package body Sem_Warn is
-- Used only in context where Unmodified would have worked
elsif Warnings_Off_Used_Unmodified (E) then
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("?could use Unmodified instead of "
& "Warnings Off for &", Pragma_Identifier (N), E);
-- Used only in context where Unreferenced would have worked
elsif Warnings_Off_Used_Unreferenced (E) then
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("?could use Unreferenced instead of "
& "Warnings Off for &", Pragma_Identifier (N), E);
-- Not used at all
else
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("?pragma Warnings Off for & unused, "
& "could be omitted", N, E);
end if;
@ -3611,17 +3606,19 @@ package body Sem_Warn is
if Is_Entity_Name (Original_Node (C))
and then Nkind (Cond) /= N_Op_Not
then
Error_Msg_NE
Error_Msg_NE -- CODEFIX???
("object & is always True?", Cond, Original_Node (C));
Track (Original_Node (C), Cond);
else
Error_Msg_N ("condition is always True?", Cond);
Error_Msg_N -- CODEFIX???
("condition is always True?", Cond);
Track (Cond, Cond);
end if;
else
Error_Msg_N ("condition is always False?", Cond);
Error_Msg_N -- CODEFIX???
("condition is always False?", Cond);
Track (Cond, Cond);
end if;
end;
@ -3861,7 +3858,8 @@ package body Sem_Warn is
procedure Warn1 is
begin
Error_Msg_Uint_1 := Low_Bound;
Error_Msg_FE ("?index for& may assume lower bound of^", X, Ent);
Error_Msg_FE -- CODEFIX
("?index for& may assume lower bound of^", X, Ent);
end Warn1;
-- Start of processing for Test_Suspicious_Index
@ -3885,11 +3883,11 @@ package body Sem_Warn is
if Nkind (Original_Node (X)) = N_Integer_Literal then
if Intval (X) = Low_Bound then
Error_Msg_FE -- CODEFIX
Error_Msg_FE -- CODEFIX
("\suggested replacement: `&''First`", X, Ent);
else
Error_Msg_Uint_1 := Intval (X) - Low_Bound;
Error_Msg_FE -- CODEFIX
Error_Msg_FE -- CODEFIX
("\suggested replacement: `&''First + ^`", X, Ent);
end if;
@ -3995,7 +3993,7 @@ package body Sem_Warn is
-- Replacement subscript is now in string buffer
Error_Msg_FE -- CODEFIX
Error_Msg_FE -- CODEFIX
("\suggested replacement: `&~`", Original_Node (X), Ent);
end if;
@ -4004,7 +4002,7 @@ package body Sem_Warn is
elsif Length_Reference (X) then
Warn1;
Error_Msg_Node_2 := Ent;
Error_Msg_FE
Error_Msg_FE -- CODEFIX???
("\suggest replacement of `&''Length` by `&''Last`",
X, Ent);
@ -4015,7 +4013,7 @@ package body Sem_Warn is
then
Warn1;
Error_Msg_Node_2 := Ent;
Error_Msg_FE
Error_Msg_FE -- CODEFIX???
("\suggest replacement of `&''Length` by `&''Last`",
Left_Opnd (X), Ent);
end if;
@ -4167,10 +4165,10 @@ package body Sem_Warn is
if Present (Renamed_Object (E))
and then Comes_From_Source (Renamed_Object (E))
then
Error_Msg_N
Error_Msg_N -- CODEFIX
("?renamed variable & is not referenced!", E);
else
Error_Msg_N
Error_Msg_N -- CODEFIX
("?variable & is not referenced!", E);
end if;
end if;
@ -4180,10 +4178,11 @@ package body Sem_Warn is
if Present (Renamed_Object (E))
and then Comes_From_Source (Renamed_Object (E))
then
Error_Msg_N
Error_Msg_N -- CODEFIX
("?renamed constant & is not referenced!", E);
else
Error_Msg_N ("?constant & is not referenced!", E);
Error_Msg_N -- CODEFIX
("?constant & is not referenced!", E);
end if;
when E_In_Parameter |
@ -4208,7 +4207,7 @@ package body Sem_Warn is
end if;
if not Is_Trivial_Subprogram (Scope (E)) then
Error_Msg_NE
Error_Msg_NE -- CODEFIX
("?formal parameter & is not referenced!",
E, Spec_E);
end if;
@ -4219,32 +4218,41 @@ package body Sem_Warn is
null;
when E_Discriminant =>
Error_Msg_N ("?discriminant & is not referenced!", E);
Error_Msg_N -- CODEFIX???
("?discriminant & is not referenced!", E);
when E_Named_Integer |
E_Named_Real =>
Error_Msg_N ("?named number & is not referenced!", E);
Error_Msg_N -- CODEFIX
("?named number & is not referenced!", E);
when Formal_Object_Kind =>
Error_Msg_N ("?formal object & is not referenced!", E);
Error_Msg_N -- CODEFIX
("?formal object & is not referenced!", E);
when E_Enumeration_Literal =>
Error_Msg_N ("?literal & is not referenced!", E);
Error_Msg_N -- CODEFIX
("?literal & is not referenced!", E);
when E_Function =>
Error_Msg_N ("?function & is not referenced!", E);
Error_Msg_N -- CODEFIX
("?function & is not referenced!", E);
when E_Procedure =>
Error_Msg_N ("?procedure & is not referenced!", E);
Error_Msg_N -- CODEFIX
("?procedure & is not referenced!", E);
when E_Package =>
Error_Msg_N ("?package & is not referenced!", E);
Error_Msg_N -- CODEFIX
("?package & is not referenced!", E);
when E_Exception =>
Error_Msg_N ("?exception & is not referenced!", E);
Error_Msg_N -- CODEFIX
("?exception & is not referenced!", E);
when E_Label =>
Error_Msg_N ("?label & is not referenced!", E);
Error_Msg_N -- CODEFIX
("?label & is not referenced!", E);
when E_Generic_Procedure =>
Error_Msg_N -- CODEFIX
@ -4255,10 +4263,12 @@ package body Sem_Warn is
("?generic function & is never instantiated!", E);
when Type_Kind =>
Error_Msg_N ("?type & is not referenced!", E);
Error_Msg_N -- CODEFIX
("?type & is not referenced!", E);
when others =>
Error_Msg_N ("?& is not referenced!", E);
Error_Msg_N -- CODEFIX
("?& is not referenced!", E);
end case;
-- Kill warnings on the entity on which the message has been posted
@ -4355,7 +4365,7 @@ package body Sem_Warn is
("?& modified by call, but value never referenced",
Last_Assignment (Ent), Ent);
else
Error_Msg_NE
Error_Msg_NE -- CODEFIX
("?useless assignment to&, value never referenced!",
Last_Assignment (Ent), Ent);
end if;
@ -4371,7 +4381,7 @@ package body Sem_Warn is
("?& modified by call, but value overwritten #!",
Last_Assignment (Ent), Ent);
else
Error_Msg_NE
Error_Msg_NE -- CODEFIX
("?useless assignment to&, value overwritten #!",
Last_Assignment (Ent), Ent);
end if;

11
gcc/ada/sinfo.adb
View File

@ -146,6 +146,7 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_And_Then
or else NT (N).Nkind = N_Case_Expression_Alternative
or else NT (N).Nkind = N_Compilation_Unit_Aux
or else NT (N).Nkind = N_Expression_With_Actions
or else NT (N).Nkind = N_Freeze_Entity
@ -230,6 +231,7 @@ package body Sinfo is
(N : Node_Id) return List_Id is
begin
pragma Assert (False
or else NT (N).Nkind = N_Case_Expression
or else NT (N).Nkind = N_Case_Statement
or else NT (N).Nkind = N_In
or else NT (N).Nkind = N_Not_In);
@ -792,6 +794,7 @@ package body Sinfo is
(N : Node_Id) return List_Id is
begin
pragma Assert (False
or else NT (N).Nkind = N_Case_Expression_Alternative
or else NT (N).Nkind = N_Case_Statement_Alternative
or else NT (N).Nkind = N_Variant);
return List4 (N);
@ -1170,6 +1173,8 @@ package body Sinfo is
or else NT (N).Nkind = N_Assignment_Statement
or else NT (N).Nkind = N_At_Clause
or else NT (N).Nkind = N_Attribute_Definition_Clause
or else NT (N).Nkind = N_Case_Expression
or else NT (N).Nkind = N_Case_Expression_Alternative
or else NT (N).Nkind = N_Case_Statement
or else NT (N).Nkind = N_Code_Statement
or else NT (N).Nkind = N_Component_Association
@ -3067,6 +3072,7 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_And_Then
or else NT (N).Nkind = N_Case_Expression_Alternative
or else NT (N).Nkind = N_Compilation_Unit_Aux
or else NT (N).Nkind = N_Expression_With_Actions
or else NT (N).Nkind = N_Freeze_Entity
@ -3151,6 +3157,7 @@ package body Sinfo is
(N : Node_Id; Val : List_Id) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Case_Expression
or else NT (N).Nkind = N_Case_Statement
or else NT (N).Nkind = N_In
or else NT (N).Nkind = N_Not_In);
@ -3713,6 +3720,7 @@ package body Sinfo is
(N : Node_Id; Val : List_Id) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Case_Expression_Alternative
or else NT (N).Nkind = N_Case_Statement_Alternative
or else NT (N).Nkind = N_Variant);
Set_List4_With_Parent (N, Val);
@ -4082,6 +4090,8 @@ package body Sinfo is
or else NT (N).Nkind = N_Assignment_Statement
or else NT (N).Nkind = N_At_Clause
or else NT (N).Nkind = N_Attribute_Definition_Clause
or else NT (N).Nkind = N_Case_Expression
or else NT (N).Nkind = N_Case_Expression_Alternative
or else NT (N).Nkind = N_Case_Statement
or else NT (N).Nkind = N_Code_Statement
or else NT (N).Nkind = N_Component_Association
@ -6050,7 +6060,6 @@ package body Sinfo is
T = V8;
end Nkind_In;
function Nkind_In
(T : Node_Kind;
V1 : Node_Kind;

60
gcc/ada/sinfo.ads
View File

@ -6543,10 +6543,46 @@ package Sinfo is
-- reconstructed tree printed by Sprint, and the node descriptions here
-- show this syntax.
-- Note: Conditional_Expression is in this section for historical reasons.
-- We will move it to its appropriate place when it is officially approved
-- as an extension (and then we will know what the exact grammar and place
-- in the Reference Manual is!)
-- Note: Case_Expression and Conditional_Expression is in this section for
-- now, since they are extensions. We will move them to their appropriate
-- places when they are officially approved as extensions (and then we will
-- know what the exact grammar and place in the Reference Manual is!)
---------------------
-- Case Expression --
---------------------
-- CASE_EXPRESSION ::=
-- case EXPRESSION is
-- CASE_EXPRESSION_ALTERNATIVE
-- {CASE_EXPRESSION_ALTERNATIVE}
-- Note that the Alternatives cannot include pragmas (this constrasts
-- with the situation of case statements where pragmas are allowed).
-- N_Case_Expression
-- Sloc points to CASE
-- Expression (Node3)
-- Alternatives (List4)
---------------------------------
-- Case Expression Alternative --
---------------------------------
-- CASE_STATEMENT_ALTERNATIVE ::=
-- when DISCRETE_CHOICE_LIST =>
-- EXPRESSION
-- N_Case_Expression_Alternative
-- Sloc points to WHEN
-- Actions (List1)
-- Discrete_Choices (List4)
-- Expression (Node3)
-- Note: The Actions field temporarily holds any actions associated with
-- evaluation of the Expression. During expansion of the case expression
-- these actions are wrapped into the an N_Expressions_With_Actions node
-- replacing the original expression.
----------------------------
-- Conditional Expression --
@ -7259,6 +7295,7 @@ package Sinfo is
N_Aggregate,
N_Allocator,
N_Case_Expression,
N_Extension_Aggregate,
N_Range,
N_Real_Literal,
@ -7437,6 +7474,7 @@ package Sinfo is
N_Abstract_Subprogram_Declaration,
N_Access_Definition,
N_Access_To_Object_Definition,
N_Case_Expression_Alternative,
N_Case_Statement_Alternative,
N_Compilation_Unit,
N_Compilation_Unit_Aux,
@ -10260,6 +10298,20 @@ package Sinfo is
4 => False, -- unused
5 => False), -- unused
N_Case_Expression =>
(1 => False, -- unused
2 => False, -- unused
3 => True, -- Expression (Node3)
4 => True, -- Alternatives (List4)
5 => False), -- unused
N_Case_Expression_Alternative =>
(1 => False, -- Actions (List1-Sem)
2 => False, -- unused
3 => True, -- Statements (List3)
4 => True, -- Expression (Node4)
5 => False), -- unused
N_Case_Statement =>
(1 => False, -- unused
2 => False, -- unused

26
gcc/ada/sprint.adb
View File

@ -1084,6 +1084,32 @@ package body Sprint is
Write_Char (';');
when N_Case_Expression =>
declare
Alt : Node_Id;
begin
Write_Str_With_Col_Check_Sloc ("(case ");
Sprint_Node (Expression (Node));
Write_Str_With_Col_Check (" is");
Alt := First (Alternatives (Node));
loop
Sprint_Node (Alt);
Next (Alt);
exit when No (Alt);
Write_Char (',');
end loop;
Write_Char (')');
end;
when N_Case_Expression_Alternative =>
Write_Str_With_Col_Check (" when ");
Sprint_Bar_List (Discrete_Choices (Node));
Write_Str (" => ");
Sprint_Node (Expression (Node));
when N_Case_Statement =>
Write_Indent_Str_Sloc ("case ");
Sprint_Node (Expression (Node));

24
gcc/ada/types.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -730,14 +730,14 @@ package Types is
-- Parameter Mechanism Control --
---------------------------------
-- Function and parameter entities have a field that records the
-- passing mechanism. See specification of Sem_Mech for full details.
-- The following subtype is used to represent values of this type:
-- Function and parameter entities have a field that records the passing
-- mechanism. See specification of Sem_Mech for full details. The following
-- subtype is used to represent values of this type:
subtype Mechanism_Type is Int range -18 .. Int'Last;
-- Type used to represent a mechanism value. This is a subtype rather
-- than a type to avoid some annoying processing problems with certain
-- routines in Einfo (processing them to create the corresponding C).
-- Type used to represent a mechanism value. This is a subtype rather than
-- a type to avoid some annoying processing problems with certain routines
-- in Einfo (processing them to create the corresponding C).
------------------------------
-- Run-Time Exception Codes --
@ -762,12 +762,12 @@ package Types is
-- 1. Modify the type and subtype declarations below appropriately,
-- keeping things in alphabetical order.
-- 2. Modify the corresponding definitions in types.h, including
-- the definition of last_reason_code.
-- 2. Modify the corresponding definitions in types.h, including the
-- definition of last_reason_code.
-- 3. Add a new routine in Ada.Exceptions with the appropriate call
-- and static string constant. Note that there is more than one
-- version of a-except.adb which must be modified.
-- 3. Add a new routine in Ada.Exceptions with the appropriate call and
-- static string constant. Note that there is more than one version
-- of a-except.adb which must be modified.
type RT_Exception_Code is
(CE_Access_Check_Failed, -- 00