diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 16 | ||||
| -rw-r--r-- | gcc/ada/par-ch3.adb | 60 | ||||
| -rw-r--r-- | gcc/ada/par-ch4.adb | 45 | ||||
| -rw-r--r-- | gcc/ada/par.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/sinfo.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sinfo.ads | 31 | ||||
| -rw-r--r-- | gcc/ada/sprint.adb | 16 |
7 files changed, 161 insertions, 21 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4e3a587..2029915 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2009-07-13 Robert Dewar <dewar@adacore.com> + + * par-ch3.adb (P_Discrete_Choice_List): Choice can only be simple + expression if extensions permitted. + + * par-ch4.adb (P_Membership_Test): New procedure (implement membership + set tests). + (P_Relation): Use P_Membership_Test + + * par.adb (P_Membership_Test): New procedure (implement membership set + tests). + + * sinfo.ads, sinfo.adb (N_In, N_Not_In) Add Alternatives field for sets. + + * sprint.adb (Sprint_Node): Handle set form for membership tests. + 2009-07-13 Thomas Quinot <quinot@adacore.com> * exp_dist.adb (Add_RACW_Primitive_Declarations_And_Bodies): diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 973f643..820cb55 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -2057,11 +2057,14 @@ package body Ch3 is -- Error recovery: cannot raise Error_Resync - function P_Range_Or_Subtype_Mark return Node_Id is + function P_Range_Or_Subtype_Mark + (Allow_Simple_Expression : Boolean := False) return Node_Id + is Expr_Node : Node_Id; Range_Node : Node_Id; Save_Loc : Source_Ptr; + -- Start of processing for P_Range_Or_Subtype_Mark begin @@ -2071,7 +2074,8 @@ package body Ch3 is -- Scan out either a simple expression or a range (this accepts more -- than is legal here, but as explained above, we like to allow more - -- with a proper diagnostic. + -- with a proper diagnostic, and in the case of a membership operation + -- where sets are allowed, a simple expression is permissible anyway. Expr_Node := P_Simple_Expression_Or_Range_Attribute; @@ -3555,7 +3559,6 @@ package body Ch3 is begin Choices := New_List; - loop if Token = Tok_Others then Append (New_Node (N_Others_Choice, Token_Ptr), Choices); @@ -3563,6 +3566,8 @@ package body Ch3 is else begin + -- Scan out expression or range attribute + Expr_Node := P_Expression_Or_Range_Attribute; Ignore (Tok_Right_Paren); @@ -3572,9 +3577,13 @@ package body Ch3 is Error_Msg_SP ("label not permitted in this context"); Scan; -- past colon + -- Range attribute + elsif Expr_Form = EF_Range_Attr then Append (Expr_Node, Choices); + -- Explicit range + elsif Token = Tok_Dot_Dot then Check_Simple_Expression (Expr_Node); Choice_Node := New_Node (N_Range, Token_Ptr); @@ -3585,14 +3594,16 @@ package body Ch3 is Set_High_Bound (Choice_Node, Expr_Node); Append (Choice_Node, Choices); + -- Simple name, must be subtype, so range allowed + elsif Expr_Form = EF_Simple_Name then if Token = Tok_Range then Append (P_Subtype_Indication (Expr_Node), Choices); elsif Token in Token_Class_Consk then Error_Msg_SC - ("the only constraint allowed here " & - "is a range constraint"); + ("the only constraint allowed here " & + "is a range constraint"); Discard_Junk_Node (P_Constraint_Opt); Append (Expr_Node, Choices); @@ -3600,8 +3611,45 @@ package body Ch3 is Append (Expr_Node, Choices); end if; + -- Expression + else - Check_Simple_Expression_In_Ada_83 (Expr_Node); + -- If extensions are permitted then the expression must be a + -- simple expression. The resaon for this restriction (i.e. + -- going back to the Ada 83 rule) is to avoid ambiguities + -- when set membership operations are allowed, consider the + -- following: + + -- when A in 1 .. 10 | 12 => + + -- This is ambiguous without parentheses, so we require one + -- of the following two parenthesized forms to disambuguate: + + -- one of the following: + + -- when (A in 1 .. 10 | 12) => + -- when (A in 1 .. 10) | 12 => + + -- We consider it unlikely that reintroducing the Ada 83 + -- restriction will cause an upwards incompatibility issue. + -- Historically the only reason for the change in Ada 95 was + -- for consistency (all cases of Simple_Expression in Ada 83 + -- which could be changed to Expression without causing any + -- ambiguities were changed). + + if Extensions_Allowed and then Expr_Form = EF_Non_Simple then + Error_Msg_N + ("|this expression must be parenthesized!", + Expr_Node); + Error_Msg_N + ("\|since extensions (and set notation) are allowed", + Expr_Node); + + -- In Ada 83 mode, the syntax required a simple expression + else + Check_Simple_Expression_In_Ada_83 (Expr_Node); + end if; + Append (Expr_Node, Choices); end if; diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb index c164e60..0d8e33c 100644 --- a/gcc/ada/par-ch4.adb +++ b/gcc/ada/par-ch4.adb @@ -79,6 +79,11 @@ package body Ch4 is -- Called to place complaint about bad range attribute at the given -- source location. Terminates by raising Error_Resync. + procedure P_Membership_Test (N : Node_Id); + -- N is the node for a N_In or N_Not_In node whose right operand has not + -- yet been processed. It is called just after scanning out the IN keyword. + -- On return, either Right_Opnd or Alternatives is set, as appropriate. + function P_Range_Attribute_Reference (Prefix_Node : Node_Id) return Node_Id; -- Scan a range attribute reference. The caller has scanned out the -- prefix. The current token is known to be an apostrophe and the @@ -1757,7 +1762,7 @@ package body Ch4 is -- Case of IN or NOT IN if Prev_Token = Tok_In then - Set_Right_Opnd (Node2, P_Range_Or_Subtype_Mark); + P_Membership_Test (Node2); -- Case of relational operator (= /= < <= > >=) @@ -2734,4 +2739,42 @@ package body Ch4 is Expressions => Exprs); end P_Conditional_Expression; + ----------------------- + -- P_Membership_Test -- + ----------------------- + + procedure P_Membership_Test (N : Node_Id) is + Alt : constant Node_Id := + P_Range_Or_Subtype_Mark + (Allow_Simple_Expression => Extensions_Allowed); + + begin + -- Set case + + if Token = Tok_Vertical_Bar then + if not Extensions_Allowed then + Error_Msg_SC ("set notation is a language extension"); + Error_Msg_SC ("\|use -gnatX switch to compile this unit"); + end if; + + Set_Alternatives (N, New_List (Alt)); + Set_Right_Opnd (N, Empty); + + -- Loop to accumulate alternatives + + while Token = Tok_Vertical_Bar loop + Scan; -- past vertical bar + Append_To + (Alternatives (N), + P_Range_Or_Subtype_Mark (Allow_Simple_Expression => True)); + end loop; + + -- Not set case + + else + Set_Right_Opnd (N, Alt); + Set_Alternatives (N, No_List); + end if; + end P_Membership_Test; + end Ch4; diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb index 769e3e4..a323d7a 100644 --- a/gcc/ada/par.adb +++ b/gcc/ada/par.adb @@ -577,7 +577,6 @@ is function P_Known_Discriminant_Part_Opt return List_Id; function P_Signed_Integer_Type_Definition return Node_Id; function P_Range return Node_Id; - function P_Range_Or_Subtype_Mark return Node_Id; function P_Range_Constraint return Node_Id; function P_Record_Definition return Node_Id; function P_Subtype_Mark return Node_Id; @@ -629,6 +628,11 @@ is -- Ada 2005 (AI-231): The flag Not_Null_Present indicates that the -- null-excluding part has been scanned out and it was present. + function P_Range_Or_Subtype_Mark + (Allow_Simple_Expression : Boolean := False) return Node_Id; + -- Scans out a range or subtype mark, and also permits a general simple + -- expression if Allow_Simple_Expresion is set to True. + function Init_Expr_Opt (P : Boolean := False) return Node_Id; -- If an initialization expression is present (:= expression), then -- it is scanned out and returned, otherwise Empty is returned if no diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 866dd5f..073c79c 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -229,7 +229,9 @@ package body Sinfo is (N : Node_Id) return List_Id is begin pragma Assert (False - or else NT (N).Nkind = N_Case_Statement); + or else NT (N).Nkind = N_Case_Statement + or else NT (N).Nkind = N_In + or else NT (N).Nkind = N_Not_In); return List4 (N); end Alternatives; @@ -3034,7 +3036,9 @@ package body Sinfo is (N : Node_Id; Val : List_Id) is begin pragma Assert (False - or else NT (N).Nkind = N_Case_Statement); + or else NT (N).Nkind = N_Case_Statement + or else NT (N).Nkind = N_In + or else NT (N).Nkind = N_Not_In); Set_List4_With_Parent (N, Val); end Set_Alternatives; diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 4aafa59..1e2cd0a 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -3472,23 +3472,38 @@ package Sinfo is -- SIMPLE_EXPRESSION [not] in RANGE -- | SIMPLE_EXPRESSION [not] in SUBTYPE_MARK - -- Note: although the grammar above allows only a range or a - -- subtype mark, the parser in fact will accept any simple - -- expression in place of a subtype mark. This means that the - -- semantic analyzer must be prepared to deal with, and diagnose - -- a simple expression other than a name for the right operand. - -- This simplifies error recovery in the parser. + -- Note: although the grammar above allows only a range or a subtype + -- mark, the parser in fact will accept any simple expression in place + -- of a subtype mark. This means that the semantic analyzer must be able + -- to deal with, and diagnose a simple expression other than a name for + -- the right operand. This simplifies error recovery in the parser. + + -- If extensions are enabled, the grammar is as follows: + + -- RELATION ::= + -- SIMPLE_EXPRESSION [not] in SET_ALTERNATIVE {| SET_ALTERNATIVE} + + -- SET_ALTERNATIVE ::= RANGE | SUBTYPE_MARK + + -- The Alternatives field below is present only if there is more than + -- one Set_Alternative present, in which case Right_Opnd is set to + -- Empty, and Alternatives contains the list of alternatives. In the + -- tree passed to the back end, Alternatives is always No_List, and + -- Right_Opnd is set (i.e. the expansion circuitry expands out the + -- complex set membership case using simple membership operations). -- N_In -- Sloc points to IN -- Left_Opnd (Node2) -- Right_Opnd (Node3) + -- Alternatives (List4) (set to No_List if only one set alternative) -- plus fields for expression -- N_Not_In -- Sloc points to NOT of NOT IN -- Left_Opnd (Node2) -- Right_Opnd (Node3) + -- Alternatives (List4) (set to No_List if only one set alternative) -- plus fields for expression -------------------- @@ -9757,14 +9772,14 @@ package Sinfo is (1 => False, -- unused 2 => True, -- Left_Opnd (Node2) 3 => True, -- Right_Opnd (Node3) - 4 => False, -- unused + 4 => True, -- Alternatives (List4) 5 => False), -- Etype (Node5-Sem) N_Not_In => (1 => False, -- unused 2 => True, -- Left_Opnd (Node2) 3 => True, -- Right_Opnd (Node3) - 4 => False, -- unused + 4 => True, -- Alternatives (List4) 5 => False), -- Etype (Node5-Sem) N_Op_And => diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 3ae7918..86d95f3 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2009, 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- -- @@ -1885,7 +1885,12 @@ package body Sprint is when N_In => Sprint_Left_Opnd (Node); Write_Str_Sloc (" in "); - Sprint_Right_Opnd (Node); + + if Present (Right_Opnd (Node)) then + Sprint_Right_Opnd (Node); + else + Sprint_Bar_List (Alternatives (Node)); + end if; when N_Incomplete_Type_Declaration => Write_Indent_Str_Sloc ("type "); @@ -1984,7 +1989,12 @@ package body Sprint is when N_Not_In => Sprint_Left_Opnd (Node); Write_Str_Sloc (" not in "); - Sprint_Right_Opnd (Node); + + if Present (Right_Opnd (Node)) then + Sprint_Right_Opnd (Node); + else + Sprint_Bar_List (Alternatives (Node)); + end if; when N_Null => Write_Str_With_Col_Check_Sloc ("null"); |