diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 43 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 131 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/expander.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/gnat1drv.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 6 | ||||
| -rw-r--r-- | gcc/ada/par-ch3.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/par-ch4.adb | 169 | ||||
| -rw-r--r-- | gcc/ada/par-ch7.adb | 20 | ||||
| -rw-r--r-- | gcc/ada/par-prag.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/par.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/par_sco.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_case.ads | 18 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 213 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 139 | ||||
| -rw-r--r-- | gcc/ada/sem_eval.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/sem_eval.ads | 3 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 69 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 26 | ||||
| -rw-r--r-- | gcc/ada/sem_scil.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/sem_warn.adb | 132 | ||||
| -rw-r--r-- | gcc/ada/sinfo.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 60 | ||||
| -rw-r--r-- | gcc/ada/sprint.adb | 26 | ||||
| -rw-r--r-- | gcc/ada/types.ads | 24 |
29 files changed, 978 insertions, 241 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4f6d002..f76b284 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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 diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 199d372..89f52a9 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -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. diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 821103c..9a67fa9c 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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 -- ------------------------------------- diff --git a/gcc/ada/exp_ch4.ads b/gcc/ada/exp_ch4.ads index a91daf1..745ce29 100644 --- a/gcc/ada/exp_ch4.ads +++ b/gcc/ada/exp_ch4.ads @@ -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); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 4f2e7f7..e8a8510 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -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 | diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb index 674137d..cc2122d 100644 --- a/gcc/ada/expander.adb +++ b/gcc/ada/expander.adb @@ -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; --------------------------- diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 47f8774..a69f732 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -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 diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 0cbe160..accb855 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -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 diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 78aa3d1..c0ae8b3 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -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 -- --------------------------------- diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index 2bb9d25..bb2063f 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -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 diff --git a/gcc/ada/par-ch7.adb b/gcc/ada/par-ch7.adb index 3b24c87..50a113f 100644 --- a/gcc/ada/par-ch7.adb +++ b/gcc/ada/par-ch7.adb @@ -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; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 9b5b0ab..4b532e2 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -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; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 145dda4..bf3dc1e 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -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. diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb index d0b2a9f..7dbaf93 100644 --- a/gcc/ada/par_sco.adb +++ b/gcc/ada/par_sco.adb @@ -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 => diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 30ed723..8a9628e 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -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 | diff --git a/gcc/ada/sem_case.ads b/gcc/ada/sem_case.ads index dcc7293..78ae7c6 100644 --- a/gcc/ada/sem_case.ads +++ b/gcc/ada/sem_case.ads @@ -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. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 946f7b8..49775b9c 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -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; diff --git a/gcc/ada/sem_ch4.ads b/gcc/ada/sem_ch4.ads index a6db3aa..e5c646f 100644 --- a/gcc/ada/sem_ch4.ads +++ b/gcc/ada/sem_ch4.ads @@ -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); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 2be771a..7e897ff 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 1b1307d..448872d 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -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); diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 565ce67..078ac37 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -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); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index bcc416b..f9f7384 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 1a20129..7fb17fd 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -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 -- ------------------------------- diff --git a/gcc/ada/sem_scil.adb b/gcc/ada/sem_scil.adb index 8436cf0..9a2425b 100644 --- a/gcc/ada/sem_scil.adb +++ b/gcc/ada/sem_scil.adb @@ -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 | diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 0e00f51..bcfff4e 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -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; diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 382968c..ff77ebb 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -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; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 705530c..24075c7 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -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 diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index a7fc6e7..bc1f35d 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -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)); diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index cc3603a..5467f4e 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -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 |