[multiple changes]

2010-10-25  Robert Dewar  <dewar@adacore.com>

	* exp_ch5.adb (Expand_Predicated_Loop): Remove code for loop through
	non-static predicate, since we agree not to allow this.
	(Expand_Predicated_Loop): Properlay handle false predicate (null
	list in Static_Predicate field.
	* sem_ch13.adb (Build_Static_Predicate): Extensive changes to clean up
	handling of more general predicate forms.

2010-10-25  Robert Dewar  <dewar@adacore.com>

	* sem_ch4.adb, sem_util.adb: Minor reformatting.
	* sem_ch8.adb (Find_Selected_Component): Allow selection from instance
	of type in predicate or invariant expression.

2010-10-25  Pascal Obry  <obry@adacore.com>

	* adaint.c (__gnat_stat_to_attr): Can set the timestamp on Windows now.
	(f2t): New routine.
	(__gnat_stat): Rewrite Win32 version.

From-SVN: r165919

gcc/ada/ChangeLog

 2010-10-25  Robert Dewar  <dewar@adacore.com>
 
+	* exp_ch5.adb (Expand_Predicated_Loop): Remove code for loop through
+	non-static predicate, since we agree not to allow this.
+	(Expand_Predicated_Loop): Properlay handle false predicate (null
+	list in Static_Predicate field.
+	* sem_ch13.adb (Build_Static_Predicate): Extensive changes to clean up
+	handling of more general predicate forms.
+
+2010-10-25  Robert Dewar  <dewar@adacore.com>
+
+	* sem_ch4.adb, sem_util.adb: Minor reformatting.
+	* sem_ch8.adb (Find_Selected_Component): Allow selection from instance
+	of type in predicate or invariant expression.
+
+2010-10-25  Pascal Obry  <obry@adacore.com>
+
+	* adaint.c (__gnat_stat_to_attr): Can set the timestamp on Windows now.
+	(f2t): New routine.
+	(__gnat_stat): Rewrite Win32 version.
+
+2010-10-25  Robert Dewar  <dewar@adacore.com>
+
 	* sem_warn.adb, einfo.ads, exp_ch4.adb: Minor comment fix
 	* sem_case.adb: Comment clarification for loops through false
 	predicates.

gcc/ada/adaint.c

@@ -1112,8 +1112,6 @@ __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr)
   attr->executable = (!ret && (statbuf.st_mode & S_IXUSR));
 #endif
 
-#if !defined (_WIN32) || defined (RTX)
-  /* on Windows requires extra system call, see __gnat_file_time_name_attr */
   if (ret != 0) {
      attr->timestamp = (OS_Time)-1;
   } else {
@@ -1124,8 +1122,6 @@ __gnat_stat_to_attr (int fd, char* name, struct file_attributes* attr)
      attr->timestamp = (OS_Time)statbuf.st_mtime;
 #endif
   }
-#endif
-
 }
 
 /****************************************************************
@@ -1345,6 +1341,19 @@ win32_filetime (HANDLE h)
     return (time_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset);
   return (time_t) 0;
 }
+
+/* As above but starting from a FILETIME.  */
+static void f2t (const FILETIME *ft, time_t *t)
+{
+  union
+  {
+    FILETIME ft_time;
+    unsigned long long ull_time;
+  } t_write;
+
+  t_write.ft_time = *ft;
+  *t = (time_t) (t_write.ull_time / 10000000ULL - w32_epoch_offset);
+}
 #endif
 
 /* Return a GNAT time stamp given a file name.  */
@@ -1687,15 +1696,10 @@ int
 __gnat_stat (char *name, GNAT_STRUCT_STAT *statbuf)
 {
 #ifdef __MINGW32__
-  /* Under Windows the directory name for the stat function must not be
-     terminated by a directory separator except if just after a drive name
-     or with UNC path without directory (only the name of the shared
-     resource), for example: \\computer\share\  */
-
+  WIN32_FILE_ATTRIBUTE_DATA fad;
   TCHAR wname [GNAT_MAX_PATH_LEN + 2];
-  int name_len, k;
-  TCHAR last_char;
-  int dirsep_count = 0;
+  int name_len;
+  BOOL res;
 
   S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
   name_len = _tcslen (wname);
@@ -1703,29 +1707,43 @@ __gnat_stat (char *name, GNAT_STRUCT_STAT *statbuf)
   if (name_len > GNAT_MAX_PATH_LEN)
     return -1;
 
-  last_char = wname[name_len - 1];
-
-  while (name_len > 1 && (last_char == _T('\\') || last_char == _T('/')))
-    {
-      wname[name_len - 1] = _T('\0');
-      name_len--;
-      last_char = wname[name_len - 1];
+  ZeroMemory (statbuf, sizeof(GNAT_STRUCT_STAT));
+
+  res = GetFileAttributesEx (wname, GetFileExInfoStandard, &fad);
+
+  if (res == FALSE)
+    switch (GetLastError()) {
+    case ERROR_ACCESS_DENIED:
+    case ERROR_SHARING_VIOLATION:
+    case ERROR_LOCK_VIOLATION:
+    case ERROR_SHARING_BUFFER_EXCEEDED:
+      return EACCES;
+    case ERROR_BUFFER_OVERFLOW:
+      return ENAMETOOLONG;
+    case ERROR_NOT_ENOUGH_MEMORY:
+      return ENOMEM;
+    default:
+      return ENOENT;
     }
 
-  /* Count back-slashes.  */
+  f2t (&fad.ftCreationTime, &statbuf->st_ctime);
+  f2t (&fad.ftLastWriteTime, &statbuf->st_mtime);
+  f2t (&fad.ftLastAccessTime, &statbuf->st_atime);
+
+  statbuf->st_size = (off_t)fad.nFileSizeLow;
 
-  for (k=0; k<name_len; k++)
-    if (wname[k] == _T('\\') || wname[k] == _T('/'))
-      dirsep_count++;
+  /* We do not have the S_IEXEC attribute, but this is not used on GNAT.  */
+  statbuf->st_mode = S_IREAD;
 
-  /* Only a drive letter followed by ':', we must add a directory separator
-     for the stat routine to work properly.  */
-  if ((name_len == 2 && wname[1] == _T(':'))
-      || (name_len > 3 && wname[0] == _T('\\') && wname[1] == _T('\\')
-	  && dirsep_count == 3))
-    _tcscat (wname, _T("\\"));
+  if (fad.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY)
+    statbuf->st_mode |= S_IFDIR;
+  else
+    statbuf->st_mode |= S_IFREG;
 
-  return _tstat (wname, (struct _stat *)statbuf);
+  if (!(fad.dwFileAttributes & FILE_ATTRIBUTE_READONLY))
+    statbuf->st_mode |= S_IWRITE;
+
+  return 0;
 
 #else
   return GNAT_STAT (name, statbuf);

gcc/ada/exp_ch5.adb

@@ -3001,7 +3001,7 @@ package body Exp_Ch5 is
       if No (Isc) then
          null;
 
-      --  Case of for loop (Loop_Parameter_Specfication present)
+      --  Case of for loop (Loop_Parameter_Specification present)
 
       --  Note: we do not have to worry about validity checking of the for loop
       --  range bounds here, since they were frozen with constant declarations
@@ -3215,26 +3215,20 @@ package body Exp_Ch5 is
       Stmts   : constant List_Id    := Statements (N);
 
    begin
-      --  Case of iteration over non-static predicate. In this case we
-      --  generate the sequence:
-
-      --     for J in Ltype'First .. Ltype'Last loop
-      --        if Ltype_Predicate_Function (J) then
-      --           body;
-      --        end if;
-      --     end loop;
+      --  Case of iteration over non-static predicate, should not be possible
+      --  since this is not allowed by the semantics and should have been
+      --  caught during analysis of the loop statement.
 
       if No (Stat) then
+         raise Program_Error;
 
-         --  The analyzer already expanded the First/Last, so all we have
-         --  to do is wrap the body within the predicate function test.
+      --  If the predicate list is empty, that corresponds to a predicate of
+      --  False, in which case the loop won't run at all, and we rewrite the
+      --  entire loop as a null statement.
 
-         Set_Statements (N, New_List (
-           Make_If_Statement (Loc,
-             Condition =>
-               Make_Predicate_Call (Ltype, New_Occurrence_Of (Loop_Id, Loc)),
-             Then_Statements => Stmts)));
-         Analyze (First (Statements (N)));
+      elsif Is_Empty_List (Stat) then
+         Rewrite (N, Make_Null_Statement (Loc));
+         Analyze (N);
 
       --  For expansion over a static predicate we generate the following
 

gcc/ada/sem_ch13.adb

@@ -94,16 +94,16 @@ package body Sem_Ch13 is
      (Typ  : Entity_Id;
       Expr : Node_Id;
       Nam  : Name_Id);
-   --  Given a predicated type Typ, whose predicate expression is Expr, tests
-   --  if Expr is a static predicate, and if so, builds the predicate range
-   --  list. Nam is the name of the argument to the predicate function.
-   --  Occurrences of the type name in the predicate expression have been
-   --  replaced by identifer references to this name, which is unique, so any
-   --  identifier with Chars matching Nam must be a reference to the type. If
-   --  the predicate is non-static, this procedure returns doing nothing. If
-   --  the predicate is static, then the corresponding predicate list is stored
-   --  in Static_Predicate (Typ), and the Expr is rewritten as a canonicalized
-   --  membership operation.
+   --  Given a predicated type Typ, where Typ is a discrete static subtype,
+   --  whose predicate expression is Expr, tests if Expr is a static predicate,
+   --  and if so, builds the predicate range list. Nam is the name of the one
+   --  argument to the predicate function. Occurrences of the type name in the
+   --  predicate expression have been replaced by identifer references to this
+   --  name, which is unique, so any identifier with Chars matching Nam must be
+   --  a reference to the type. If the predicate is non-static, this procedure
+   --  returns doing nothing. If the predicate is static, then the predicate
+   --  list is stored in Static_Predicate (Typ), and the Expr is rewritten as
+   --  a canonicalized membership operation.
 
    function Get_Alignment_Value (Expr : Node_Id) return Uint;
    --  Given the expression for an alignment value, returns the corresponding
@@ -4045,7 +4045,13 @@ package body Sem_Ch13 is
 
          --  Deal with static predicate case
 
-         Build_Static_Predicate (Typ, Expr, Object_Name);
+         if Ekind_In (Typ, E_Enumeration_Subtype,
+                           E_Modular_Integer_Subtype,
+                           E_Signed_Integer_Subtype)
+           and then Is_Static_Subtype (Typ)
+         then
+            Build_Static_Predicate (Typ, Expr, Object_Name);
+         end if;
 
          --  Build function declaration
 
@@ -4115,8 +4121,15 @@ package body Sem_Ch13 is
       Non_Static : exception;
       --  Raised if something non-static is found
 
-      TLo, THi : Uint;
-      --  Low bound and high bound values of static subtype of Typ
+      Btyp : constant Entity_Id := Base_Type (Typ);
+
+      BLo : constant Uint := Expr_Value (Type_Low_Bound  (Btyp));
+      BHi : constant Uint := Expr_Value (Type_High_Bound (Btyp));
+      --  Low bound and high bound value of base type of Typ
+
+      TLo : constant Uint := Expr_Value (Type_Low_Bound  (Typ));
+      THi : constant Uint := Expr_Value (Type_High_Bound (Typ));
+      --  Low bound and high bound values of static subtype Typ
 
       type REnt is record
          Lo, Hi : Uint;
@@ -4128,15 +4141,20 @@ package body Sem_Ch13 is
       type RList is array (Nat range <>) of REnt;
       --  A list of ranges. The ranges are sorted in increasing order,
       --  and are disjoint (there is a gap of at least one value between
-      --  each range in the table).
+      --  each range in the table). A value is in the set of ranges in
+      --  Rlist if it lies within one of these ranges
 
-      Null_Range : constant RList := RList'(1 .. 0 => REnt'(No_Uint, No_Uint));
-      True_Range : RList renames Null_Range;
-      --  Constant representing null list of ranges, used to represent a
-      --  predicate of True, since there are no ranges to be satisfied.
+      False_Range : constant RList :=
+                      RList'(1 .. 0 => REnt'(No_Uint, No_Uint));
+      --  An empty set of ranges represents a range list that can never be
+      --  satisfied, since there are no ranges in which the value could lie,
+      --  so it does not lie in any of them. False_Range is a canonical value
+      --  for this empty set, but general processing should test for an Rlist
+      --  with length zero (see Is_False predicate), since other null ranges
+      --  may appear which must be treated as False.
 
-      False_Range : constant RList := RList'(1 => REnt'(Uint_1, Uint_0));
-      --  Range representing false
+      True_Range : constant RList := RList'(1 => REnt'(BLo, BHi));
+      --  Range representing True, value must be in the base range
 
       function "and" (Left, Right : RList) return RList;
       --  And's together two range lists, returning a range list. This is
@@ -4153,16 +4171,27 @@ package body Sem_Ch13 is
 
       function Build_Val (V : Uint) return Node_Id;
       --  Return an analyzed N_Identifier node referencing this value, suitable
-      --  for use as an entry in the Static_Predicate list.
+      --  for use as an entry in the Static_Predicate list. This node is typed
+      --  with the base type.
 
       function Build_Range (Lo, Hi : Uint) return Node_Id;
       --  Return an analyzed N_Range node referencing this range, suitable
-      --  for use as an entry in the Static_Predicate list.
+      --  for use as an entry in the Static_Predicate list. This node is typed
+      --  with the base type.
 
       function Get_RList (Exp : Node_Id) return RList;
       --  This is a recursive routine that converts the given expression into
       --  a list of ranges, suitable for use in building the static predicate.
 
+      function Is_False (R : RList) return Boolean;
+      pragma Inline (Is_False);
+      --  Returns True if the given range list is empty, and thus represents
+      --  a False list of ranges that can never be satsified.
+
+      function Is_True (R : RList) return Boolean;
+      --  Returns True if R trivially represents the True predicate by having
+      --  a single range from BLo to BHi.
+
       function Is_Type_Ref (N : Node_Id) return Boolean;
       pragma Inline (Is_Type_Ref);
       --  Returns if True if N is a reference to the type for the predicate in
@@ -4207,21 +4236,15 @@ package body Sem_Ch13 is
       begin
          --  If either range is True, return the other
 
-         if Left = True_Range then
+         if Is_True (Left) then
             return Right;
-         elsif Right = True_Range then
+         elsif Is_True (Right) then
             return Left;
          end if;
 
          --  If either range is False, return False
 
-         if Left = False_Range or else Right = False_Range then
-            return False_Range;
-         end if;
-
-         --  If either range is empty, return False
-
-         if Left'Length = 0 or else Right'Length = 0 then
+         if Is_False (Left) or else Is_False (Right) then
             return False_Range;
          end if;
 
@@ -4267,18 +4290,13 @@ package body Sem_Ch13 is
             SRight := SRight + 1;
          end if;
 
-         --  If either operand is empty, that's the only entry
+         --  Compute result by concatenating this first entry with the "and"
+         --  of the remaining parts of the left and right operands. Note that
+         --  if either of these is empty, "and" will yield empty, so that we
+         --  will end up with just Fent, which is what we want in that case.
 
-         if SLeft > Left'Last or else SRight > Right'Last then
-            return RList'(1 => FEnt);
-
-         --  Else compute and of remaining entries and concatenate
-
-         else
-            return
-              FEnt &
-                (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last));
-         end if;
+         return
+           FEnt & (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last));
       end "and";
 
       -----------
@@ -4289,13 +4307,13 @@ package body Sem_Ch13 is
       begin
          --  Return True if False range
 
-         if Right = False_Range then
+         if Is_False (Right) then
             return True_Range;
          end if;
 
          --  Return False if True range
 
-         if Right'Length = 0 then
+         if Is_True (Right) then
             return False_Range;
          end if;
 
@@ -4340,100 +4358,76 @@ package body Sem_Ch13 is
       ----------
 
       function "or" (Left, Right : RList) return RList is
+         FEnt : REnt;
+         --  First range of result
+
+         SLeft : Nat := Left'First;
+         --  Start of rest of left entries
+
+         SRight : Nat := Right'First;
+         --  Start of rest of right entries
+
       begin
          --  If either range is True, return True
 
-         if Left = True_Range or else Right = True_Range then
+         if Is_True (Left) or else Is_True (Right) then
             return True_Range;
          end if;
 
-         --  If either range is False, return the other
+         --  If either range is False (empty), return the other
 
-         if Left = False_Range then
+         if Is_False (Left) then
             return Right;
-         elsif Right = False_Range then
+         elsif Is_False (Right) then
             return Left;
          end if;
 
-         --  If either operand is null, return the other one
+         --  Initialize result first entry from left or right operand
+         --  depending on which starts with the lower range.
 
-         if Left'Length = 0 then
-            return Right;
-         elsif Right'Length = 0 then
-            return Left;
+         if Left (SLeft).Lo < Right (SRight).Lo then
+            FEnt := Left (SLeft);
+            SLeft := SLeft + 1;
+         else
+            FEnt := Right (SRight);
+            SRight := SRight + 1;
          end if;
 
-         --  Now we have two non-null ranges
-
-         declare
-            FEnt : REnt;
-            --  First range of result
-
-            SLeft : Nat := Left'First;
-            --  Start of rest of left entries
+         --  This loop eats ranges from left and right operands that
+         --  are contiguous with the first range we are gathering.
 
-            SRight : Nat := Right'First;
-            --  Start of rest of right entries
-
-         begin
-            --  Initialize result first entry from left or right operand
-            --  depending on which starts with the lower range.
+         loop
+            --  Eat first entry in left operand if contiguous or
+            --  overlapped by gathered first operand of result.
 
-            if Left (SLeft).Lo < Right (SRight).Lo then
-               FEnt := Left (SLeft);
+            if SLeft <= Left'Last
+              and then Left (SLeft).Lo <= FEnt.Hi + 1
+            then
+               FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi);
                SLeft := SLeft + 1;
-            else
-               FEnt := Right (SRight);
-               SRight := SRight + 1;
-            end if;
-
-            --  This loop eats ranges from left and right operands that
-            --  are contiguous with the first range we are gathering.
-
-            loop
-               --  Eat first entry in left operand if contiguous or
-               --  overlapped by gathered first operand of result.
-
-               if SLeft <= Left'Last
-                 and then Left (SLeft).Lo <= FEnt.Hi + 1
-               then
-                  FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi);
-                  SLeft := SLeft + 1;
 
                --  Eat first entry in right operand if contiguous or
                --  overlapped by gathered right operand of result.
 
-               elsif SRight <= Right'Last
-                 and then Right (SRight).Lo <= FEnt.Hi + 1
-               then
-                  FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi);
-                  SRight := SRight + 1;
+            elsif SRight <= Right'Last
+              and then Right (SRight).Lo <= FEnt.Hi + 1
+            then
+               FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi);
+               SRight := SRight + 1;
 
                --  All done if no more entries to eat!
 
-               else
-                  exit;
-               end if;
-            end loop;
-
-            --  If left operand now empty, concatenate our new entry to right
-
-            if SLeft > Left'Last then
-               return FEnt & Right (SRight .. Right'Last);
-
-            --  If right operand now empty, concatenate our new entry to left
-
-            elsif SRight > Right'Last then
-               return FEnt & Left (SLeft .. Left'Last);
-
-            --  Otherwise, compute or of what is left and concatenate
-
             else
-               return
-                 FEnt &
-                  (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last));
+               exit;
             end if;
-         end;
+         end loop;
+
+         --  Obtain result as the first entry we just computed, concatenated
+         --  to the "or" of the remaining results (if one operand is empty,
+         --  this will just concatenate with the other
+
+         return
+           FEnt & (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last));
       end "or";
 
       -----------------
@@ -4450,7 +4444,7 @@ package body Sem_Ch13 is
               Make_Range (Loc,
                 Low_Bound  => Build_Val (Lo),
                 High_Bound => Build_Val (Hi));
-            Set_Etype (Result, Typ);
+            Set_Etype (Result, Btyp);
             Set_Analyzed (Result);
             return Result;
          end if;
@@ -4470,7 +4464,7 @@ package body Sem_Ch13 is
             Result := Make_Integer_Literal (Loc, Intval => V);
          end if;
 
-         Set_Etype (Result, Typ);
+         Set_Etype (Result, Btyp);
          Set_Is_Static_Expression (Result);
          Set_Analyzed (Result);
          return Result;
@@ -4489,15 +4483,12 @@ package body Sem_Ch13 is
 
          if Is_OK_Static_Expression (Exp) then
 
-            --  For False, return impossible range, which will always fail
+            --  For False
 
             if Expr_Value (Exp) = 0 then
                return False_Range;
-
-            --  For True, null range
-
             else
-               return Null_Range;
+               return True_Range;
             end if;
          end if;
 
@@ -4566,20 +4557,20 @@ package body Sem_Ch13 is
                      return RList'(1 => REnt'(Val, Val));
 
                   when N_Op_Ge =>
-                     return RList'(1 => REnt'(Val, THi));
+                     return RList'(1 => REnt'(Val, BHi));
 
                   when N_Op_Gt =>
-                     return RList'(1 => REnt'(Val + 1, THi));
+                     return RList'(1 => REnt'(Val + 1, BHi));
 
                   when N_Op_Le =>
-                     return RList'(1 => REnt'(TLo, Val));
+                     return RList'(1 => REnt'(BLo, Val));
 
                   when N_Op_Lt =>
-                     return RList'(1 => REnt'(TLo, Val - 1));
+                     return RList'(1 => REnt'(BLo, Val - 1));
 
                   when N_Op_Ne =>
-                     return RList'(REnt'(TLo, Val - 1),
-                                   REnt'(Val + 1, THi));
+                     return RList'(REnt'(BLo, Val - 1),
+                                   REnt'(Val + 1, BHi));
 
                   when others  =>
                      raise Program_Error;
@@ -4633,6 +4624,14 @@ package body Sem_Ch13 is
             when N_Qualified_Expression =>
                return Get_RList (Expression (Exp));
 
+            --  Xor operator
+
+            when N_Op_Xor =>
+               return (Get_RList (Left_Opnd (Exp))
+                        and not Get_RList (Right_Opnd (Exp)))
+                 or   (Get_RList (Right_Opnd (Exp))
+                        and not Get_RList (Left_Opnd (Exp)));
+
             --  Any other node type is non-static
 
             when others =>
@@ -4654,6 +4653,26 @@ package body Sem_Ch13 is
          end if;
       end Hi_Val;
 
+      --------------
+      -- Is_False --
+      --------------
+
+      function Is_False (R : RList) return Boolean is
+      begin
+         return R'Length = 0;
+      end Is_False;
+
+      -------------
+      -- Is_True --
+      -------------
+
+      function Is_True (R : RList) return Boolean is
+      begin
+         return R'Length = 1
+           and then R (R'First).Lo = BLo
+           and then R (R'First).Hi = BHi;
+      end Is_True;
+
       -----------------
       -- Is_Type_Ref --
       -----------------
@@ -4789,22 +4808,6 @@ package body Sem_Ch13 is
    --  Start of processing for Build_Static_Predicate
 
    begin
-      --  Immediately non-static if our subtype is non static, or we
-      --  do not have an appropriate discrete subtype in the first place.
-
-      if not Ekind_In (Typ, E_Enumeration_Subtype,
-                            E_Modular_Integer_Subtype,
-                            E_Signed_Integer_Subtype)
-        or else not Is_Static_Subtype (Typ)
-      then
-         return;
-      end if;
-
-      --  Get bounds of the type
-
-      TLo := Expr_Value (Type_Low_Bound  (Typ));
-      THi := Expr_Value (Type_High_Bound (Typ));
-
       --  Now analyze the expression to see if it is a static predicate
 
       declare
@@ -4818,18 +4821,45 @@ package body Sem_Ch13 is
          --  Ranges array, we just have raw ranges, these must be converted
          --  to properly typed and analyzed static expressions or range nodes.
 
+         --  Note: here we limit ranges to the ranges of the subtype, so that
+         --  a predicate is always false for values outside the subtype. That
+         --  seems fine, such values are invalid anyway, and considering them
+         --  to fail the predicate seems allowed and friendly, and furthermore
+         --  simplifies processing for case statements and loops.
+
          Plist := New_List;
 
          for J in Ranges'Range loop
             declare
-               Lo : constant Uint := Ranges (J).Lo;
-               Hi : constant Uint := Ranges (J).Hi;
+               Lo : Uint := Ranges (J).Lo;
+               Hi : Uint := Ranges (J).Hi;
 
             begin
-               if Lo = Hi then
-                  Append_To (Plist, Build_Val (Lo));
+               --  Ignore completely out of range entry
+
+               if Hi < TLo or else Lo > THi then
+                  null;
+
+                  --  Otherwise process entry
+
                else
-                  Append_To (Plist, Build_Range (Lo, Hi));
+                  --  Adjust out of range value to subtype range
+
+                  if Lo < TLo then
+                     Lo := TLo;
+                  end if;
+
+                  if Hi > THi then
+                     Hi := THi;
+                  end if;
+
+                  --  Convert range into required form
+
+                  if Lo = Hi then
+                     Append_To (Plist, Build_Val (Lo));
+                  else
+                     Append_To (Plist, Build_Range (Lo, Hi));
+                  end if;
                end if;
             end;
          end loop;
@@ -4865,21 +4895,12 @@ package body Sem_Ch13 is
                Next (Old_Node);
             end loop;
 
-            --  If empty list, replace by True
+            --  If empty list, replace by False
 
             if Is_Empty_List (New_Alts) then
-               Rewrite (Expr, New_Occurrence_Of (Standard_True, Loc));
-
-            --  If singleton list, replace by simple membership test
-
-            elsif List_Length (New_Alts) = 1 then
-               Rewrite (Expr,
-                 Make_In (Loc,
-                   Left_Opnd    => Make_Identifier (Loc, Nam),
-                   Right_Opnd   => Relocate_Node (First (New_Alts)),
-                   Alternatives => No_List));
+               Rewrite (Expr, New_Occurrence_Of (Standard_False, Loc));
 
-            --  If more than one range, replace by set membership test
+            --  Else replace by set membership test
 
             else
                Rewrite (Expr,

gcc/ada/sem_ch4.adb

@@ -2440,9 +2440,8 @@ package body Sem_Ch4 is
             end loop;
          end if;
 
-      --  If not a range, it can be a subtype mark, or else it is
-      --  a degenerate membership test with a singleton value, i.e.
-      --  a test for equality.
+      --  If not a range, it can be a subtype mark, or else it is a degenerate
+      --  membership test with a singleton value, i.e. a test for equality.
 
       else
          Analyze (R);
@@ -2469,8 +2468,8 @@ package body Sem_Ch4 is
             return;
 
          else
-            --  in previous version of the language this is an error
-            --  that will be diagnosed below.
+            --  In previous version of the language this is an error that will
+            --  be diagnosed below.
 
             Find_Type (R);
          end if;

gcc/ada/sem_ch8.adb

@@ -5479,6 +5479,11 @@ package body Sem_Ch8 is
 
             Analyze_Selected_Component (N);
 
+         --  Reference to type name in predicate/invariant expression
+
+         elsif OK_To_Reference (Etype (P)) then
+            Analyze_Selected_Component (N);
+
          elsif Is_Appropriate_For_Entry_Prefix (P_Type)
            and then not In_Open_Scopes (P_Name)
            and then (not Is_Concurrent_Type (Etype (P_Name))
@@ -5490,10 +5495,10 @@ package body Sem_Ch8 is
             Analyze_Selected_Component (N);
 
          elsif (In_Open_Scopes (P_Name)
-                  and then Ekind (P_Name) /= E_Void
-                  and then not Is_Overloadable (P_Name))
+                 and then Ekind (P_Name) /= E_Void
+                 and then not Is_Overloadable (P_Name))
            or else (Is_Concurrent_Type (Etype (P_Name))
-                      and then In_Open_Scopes (Etype (P_Name)))
+                     and then In_Open_Scopes (Etype (P_Name)))
          then
             --  Prefix denotes an enclosing loop, block, or task, i.e. an
             --  enclosing construct that is not a subprogram or accept.
@@ -5508,8 +5513,7 @@ package body Sem_Ch8 is
             --  The subprogram may be a renaming (of an enclosing scope) as
             --  in the case of the name of the generic within an instantiation.
 
-            if (Ekind (P_Name) = E_Procedure
-                 or else Ekind (P_Name) = E_Function)
+            if Ekind_In (P_Name, E_Procedure, E_Function)
               and then Present (Alias (P_Name))
               and then Is_Generic_Instance (Alias (P_Name))
             then

gcc/ada/sem_util.adb

@@ -1226,7 +1226,7 @@ package body Sem_Util is
          return;
       end if;
 
-      --  Ada 2012 AI04-0144-2 : dangerous order dependence. Actuals in nested
+      --  Ada 2012 AI04-0144-2: Dangerous order dependence. Actuals in nested
       --  calls within a construct have been collected. If one of them is
       --  writable and overlaps with another one, evaluation of the enclosing
       --  construct is nondeterministic. This is illegal in Ada 2012, but is
@@ -1278,6 +1278,7 @@ package body Sem_Util is
 
    procedure Check_Potentially_Blocking_Operation (N : Node_Id) is
       S : Entity_Id;
+
    begin
       --  N is one of the potentially blocking operations listed in 9.5.1(8).
       --  When pragma Detect_Blocking is active, the run time will raise
@@ -1294,7 +1295,6 @@ package body Sem_Util is
          if Is_Protected_Type (S) then
             Error_Msg_N
               ("potentially blocking operation in protected operation?", N);
-
             return;
          end if;