par-ch3.adb (P_Discrete_Choice_List): Choice can only be simple expression if extensions permitted.

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.

From-SVN: r149556

gcc/ada/ChangeLog

+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):

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;
 

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;

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

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;
 

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 =>

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");