+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
-- --
-- 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- --
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
-- 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
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;
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.
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 --
-------------------------------------
-- --
-- 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- --
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);
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.
N_Access_To_Object_Definition |
N_Aggregate |
N_Allocator |
+ N_Case_Expression |
N_Case_Statement_Alternative |
N_Character_Literal |
N_Compilation_Unit |
-- --
-- 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- --
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);
Debug_A_Exit ("expanding ", N, " (done)");
end if;
-
end Expand;
---------------------------
-- 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
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
-- 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 --
---------------------------------
-- --
-- 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- --
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;
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
-- 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
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
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.
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;
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;
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;
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;
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;
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;
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
return P_Identifier;
elsif Prev_Token = Tok_Comma then
- Error_Msg_SP ("|extra "","" ignored");
+ Error_Msg_SP -- CODEFIX
+ ("|extra "","" ignored");
raise Error_Resync;
else
begin
if Token = Tok_Box then
- Error_Msg_SC ("|""'<'>"" should be ""/=""");
+ Error_Msg_SC -- CODEFIX
+ ("|""'<'>"" should be ""/=""");
end if;
Op_Kind := Relop_Node (Token);
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 --
------------------------------
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);
-- 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
-- --
-- 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- --
-- 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
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;
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;
-- 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,
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;
-- --
-- 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- --
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;
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;
end if;
end if;
- Error_Msg_N
+ Error_Msg_N -- CODEFIX???
("Casing argument for pragma% must be " &
"one of Mixedcase, Lowercase, Uppercase",
Arg);
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;
-- --
-- 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- --
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.
-- --
-- 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- --
return Skip;
end;
+ -- Case expression
+
+ when N_Case_Expression =>
+ return OK; -- ???
+
-- Conditional expression, processed like an if statement
when N_Conditional_Expression =>
-- --
-- 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- --
when N_Block_Statement =>
Analyze_Block_Statement (N);
+ when N_Case_Expression =>
+ Analyze_Case_Expression (N);
+
when N_Case_Statement =>
Analyze_Case_Statement (N);
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 |
-- --
-- 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- --
-- 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.
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;
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.
-- --
-- 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- --
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;
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;
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;
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
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 --
---------------------------
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;
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;
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
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
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;
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;
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
(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;
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);
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);
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;
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;
-- --
-- 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- --
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);
-- 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;
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;
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
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);
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!
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
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;
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;
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;
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);
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
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;
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
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);
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
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));
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));
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
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
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;
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);
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;
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;
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 --
------------------------
-- 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);
-- --
-- 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- --
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);
("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
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;
-- 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;
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
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;
or else
Get_Character (C) = '/'))
then
- Error_Msg
+ Error_Msg -- CODEFIX???
("?interface name contains illegal character",
Sloc (SN) + Source_Ptr (J));
end if;
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;
-- 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
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;
("\(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
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;
-- 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));
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;
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;
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;
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;
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;
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;
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;
(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;
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;
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;
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);
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);
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);
when N_Unchecked_Type_Conversion =>
Resolve_Unchecked_Type_Conversion (N, Ctx_Type);
-
end case;
-- If the subexpression was replaced by a non-subexpression, then
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 --
-------------------------------
-- --
-- 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- --
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 =>
N_Access_To_Object_Definition |
N_Aggregate |
N_Allocator |
+ N_Case_Expression |
N_Case_Statement_Alternative |
N_Character_Literal |
N_Compilation_Unit |
-- --
-- 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- --
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;
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;
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);
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
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));
-- 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
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
-- 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.
-- 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
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;
-- 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;
if not
Has_Unreferenced (Entity (Name (Item)))
then
- Error_Msg_N
+ Error_Msg_N -- CODEFIX
("?no entities of & are referenced!",
Name (Item));
end if;
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);
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));
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
-- 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;
-- 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;
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;
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
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;
-- Replacement subscript is now in string buffer
- Error_Msg_FE -- CODEFIX
+ Error_Msg_FE -- CODEFIX
("\suggested replacement: `&~`", Original_Node (X), Ent);
end if;
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);
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;
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;
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 |
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;
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
("?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
("?& 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;
("?& 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;
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
(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);
(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);
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
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
(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);
(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);
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
T = V8;
end Nkind_In;
-
function Nkind_In
(T : Node_Kind;
V1 : Node_Kind;
-- 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 --
N_Aggregate,
N_Allocator,
+ N_Case_Expression,
N_Extension_Aggregate,
N_Range,
N_Real_Literal,
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,
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
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));
-- --
-- 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- --
-- 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 --
-- 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
OSDN Git Service
