[multiple changes]

2011-08-02  Robert Dewar  <dewar@adacore.com>

	* exp_ch9.adb, exp_sel.adb, restrict.ads, exp_disp.adb, erroutc.ads,
	exp_ch3.adb: Minor reformatting.

2011-08-02  Emmanuel Briot  <briot@adacore.com>

	* adaint.c (__gnat_locate_exec_on_path): only returns executable
	files, not any regular file.
	(__gnat_locate_file_with_predicate): new subprogram.

2011-08-02  Yannick Moy  <moy@adacore.com>

	* sinfo.adb, sinfo.ads: Restrict the use of flags
	Has_Dynamic_Length_Check and Has_Dynamic_Range_Check to expression
	nodes, plus N_Subtype_Declaration for the 2nd one.

From-SVN: r177180

gcc/ada/adaint.c

@@ -2700,10 +2700,11 @@ __gnat_os_exit (int status)
   exit (status);
 }
 
-/* Locate a regular file, give a Path value.  */
+/* Locate file on path, that matches a predicate */
 
 char *
-__gnat_locate_regular_file (char *file_name, char *path_val)
+__gnat_locate_file_with_predicate
+   (char *file_name, char *path_val, int (*predicate)(char*))
 {
   char *ptr;
   char *file_path = (char *) alloca (strlen (file_name) + 1);
@@ -2733,7 +2734,7 @@ __gnat_locate_regular_file (char *file_name, char *path_val)
 
   if (absolute)
     {
-     if (__gnat_is_regular_file (file_path))
+     if (predicate (file_path))
        return xstrdup (file_path);
 
       return 0;
@@ -2746,7 +2747,7 @@ __gnat_locate_regular_file (char *file_name, char *path_val)
 
   if (*ptr != 0)
     {
-      if (__gnat_is_regular_file (file_name))
+      if (predicate (file_name))
         return xstrdup (file_name);
     }
 
@@ -2787,7 +2788,7 @@ __gnat_locate_regular_file (char *file_name, char *path_val)
 
       strcpy (++ptr, file_name);
 
-      if (__gnat_is_regular_file (file_path))
+      if (predicate (file_path))
         return xstrdup (file_path);
 
       if (*path_val == 0)
@@ -2802,6 +2803,24 @@ __gnat_locate_regular_file (char *file_name, char *path_val)
   return 0;
 }
 
+/* Locate an executable file, give a Path value.  */
+
+char *
+__gnat_locate_executable_file (char *file_name, char *path_val)
+{
+   return __gnat_locate_file_with_predicate
+      (file_name, path_val, &__gnat_is_executable_file);
+}
+
+/* Locate a regular file, give a Path value.  */
+
+char *
+__gnat_locate_regular_file (char *file_name, char *path_val)
+{
+   return __gnat_locate_file_with_predicate
+      (file_name, path_val, &__gnat_is_regular_file);
+}
+
 /* Locate an executable given a Path argument. This routine is only used by
    gnatbl and should not be used otherwise.  Use locate_exec_on_path
    instead.  */
@@ -2818,14 +2837,14 @@ __gnat_locate_exec (char *exec_name, char *path_val)
 
       strcpy (full_exec_name, exec_name);
       strcat (full_exec_name, HOST_EXECUTABLE_SUFFIX);
-      ptr = __gnat_locate_regular_file (full_exec_name, path_val);
+      ptr = __gnat_locate_executable_file (full_exec_name, path_val);
 
       if (ptr == 0)
-         return __gnat_locate_regular_file (exec_name, path_val);
+         return __gnat_locate_executable_file (exec_name, path_val);
       return ptr;
     }
   else
-    return __gnat_locate_regular_file (exec_name, path_val);
+    return __gnat_locate_executable_file (exec_name, path_val);
 }
 
 /* Locate an executable using the Systems default PATH.  */

gcc/ada/erroutc.ads

@@ -219,33 +219,33 @@ package Erroutc is
    --  error message table, since messages are not always inserted in sequence.
 
    Last_Error_Msg : Error_Msg_Id;
-   --  The last entry on the list of error messages. Note that this is not
+   --  The last entry on the list of error messages. Note: this is not the same
-   --  the same as the physically last entry in the error message table, since
+   --  as the physically last entry in the error message table, since messages
-   --  messages are not always inserted in sequence.
+   --  are not always inserted in sequence.
 
    --------------------------
    -- Warning Mode Control --
    --------------------------
 
-   --  Pragma Warnings allows warnings to be turned off for a specified
+   --  Pragma Warnings allows warnings to be turned off for a specified region
-   --  region of code, and the following tables are the data structures used
+   --  of code, and the following tables are the data structures used to keep
-   --  to keep track of these regions.
+   --  track of these regions.
 
-   --  The first table is used for the basic command line control, and for
+   --  The first table is used for the basic command line control, and for the
-   --  the forms of Warning with a single ON or OFF parameter.
+   --  forms of Warning with a single ON or OFF parameter.
 
    --  It contains pairs of source locations, the first being the start
    --  location for a warnings off region, and the second being the end
-   --  location. When a pragma Warnings (Off) is encountered, a new entry
+   --  location. When a pragma Warnings (Off) is encountered, a new entry is
-   --  is established extending from the location of the pragma to the
+   --  established extending from the location of the pragma to the end of the
-   --  end of the current source file. A subsequent pragma Warnings (On)
+   --  current source file. A subsequent pragma Warnings (On) adjusts the end
-   --  adjusts the end point of this entry appropriately.
+   --  point of this entry appropriately.
 
-   --  If all warnings are suppressed by command switch, then there is a
+   --  If all warnings are suppressed by command switch, then there is a dummy
-   --  dummy entry (put there by Errout.Initialize) at the start of the
+   --  entry (put there by Errout.Initialize) at the start of the table which
-   --  table which covers all possible Source_Ptr values. Note that the
+   --  covers all possible Source_Ptr values. Note that the source pointer
-   --  source pointer values in this table always reference the original
+   --  values in this table always reference the original template, not an
-   --  template, not an instantiation copy, in the generic case.
+   --  instantiation copy, in the generic case.
 
    type Warnings_Entry is record
       Start : Source_Ptr;
@@ -280,9 +280,9 @@ package Erroutc is
       --  Set to True if entry has been used to suppress a warning
 
       Config : Boolean;
-      --  True if pragma is configuration pragma (in which case no matching
+      --  True if pragma is configuration pragma (in which case no matching Off
-      --  Off pragma is required, and it is not required that a specific
+      --  pragma is required, and it is not required that a specific warning be
-      --  warning be suppressed).
+      --  suppressed).
    end record;
 
    package Specific_Warnings is new Table.Table (
@@ -304,10 +304,10 @@ package Erroutc is
    --     end Mumble;
 
    --  The trouble is that the first pragma is technically a configuration
-   --  pragma, and yet it is clearly being used in the context of thinking
+   --  pragma, and yet it is clearly being used in the context of thinking of
-   --  of it as a specific case. To deal with this, what we do is that the
+   --  it as a specific case. To deal with this, what we do is that the On
-   --  On entry can match a configuration pragma from the same file, and if
+   --  entry can match a configuration pragma from the same file, and if we
-   --  we find such an On entry, we cancel the indication of it being the
+   --  find such an On entry, we cancel the indication of it being the
    --  configuration case. This seems to handle all cases we run into ok.
 
    -----------------
@@ -336,16 +336,16 @@ package Erroutc is
    --  output giving node number (of node N) if the debug X switch is set.
 
    procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id);
-   --  This function is passed the Id values of two error messages. If
+   --  This function is passed the Id values of two error messages. If either
-   --  either M1 or M2 is a continuation message, or is already deleted,
+   --  M1 or M2 is a continuation message, or is already deleted, the call is
-   --  the call is ignored. Otherwise a check is made to see if M1 and M2
+   --  ignored. Otherwise a check is made to see if M1 and M2 are duplicated or
-   --  are duplicated or redundant. If so, the message to be deleted and
+   --  redundant. If so, the message to be deleted and all its continuations
-   --  all its continuations are marked with the Deleted flag set to True.
+   --  are marked with the Deleted flag set to True.
 
    procedure Output_Error_Msgs (E : in out Error_Msg_Id);
-   --  Output source line, error flag, and text of stored error message and
+   --  Output source line, error flag, and text of stored error message and all
-   --  all subsequent messages for the same line and unit. On return E is
+   --  subsequent messages for the same line and unit. On return E is set to be
-   --  set to be one higher than the last message output.
+   --  one higher than the last message output.
 
    procedure Output_Line_Number (L : Logical_Line_Number);
    --  Output a line number as six digits (with leading zeroes suppressed),
@@ -366,9 +366,9 @@ package Erroutc is
    --  including the end points) will be deleted from the error listing.
 
    function Same_Error (M1, M2 : Error_Msg_Id) return Boolean;
-   --  See if two messages have the same text. Returns true if the text
+   --  See if two messages have the same text. Returns true if the text of the
-   --  of the two messages is identical, or if one of them is the same
+   --  two messages is identical, or if one of them is the same as the other
-   --  as the other with an appended "instance at xxx" tag.
+   --  with an appended "instance at xxx" tag.
 
    procedure Set_Msg_Blank;
    --  Sets a single blank in the message if the preceding character is a

gcc/ada/exp_ch3.adb

@@ -8459,15 +8459,15 @@ package body Exp_Ch3 is
          --  they may be ancestors of synchronized interface types).
 
          elsif (not Is_Interface (Tag_Typ)
-                  and then Is_Interface (Etype (Tag_Typ))
+                 and then Is_Interface (Etype (Tag_Typ))
-                  and then Is_Limited_Record (Etype (Tag_Typ)))
+                 and then Is_Limited_Record (Etype (Tag_Typ)))
              or else
                (Is_Concurrent_Record_Type (Tag_Typ)
-                  and then Has_Interfaces (Tag_Typ))
+                 and then Has_Interfaces (Tag_Typ))
              or else
                (not Tagged_Type_Expansion
-                  and then not Is_Interface (Tag_Typ)
+                 and then not Is_Interface (Tag_Typ)
-                  and then Tag_Typ = Root_Type (Tag_Typ))
+                 and then Tag_Typ = Root_Type (Tag_Typ))
          then
             Append_To (Res,
               Make_Subprogram_Declaration (Loc,
@@ -8944,10 +8944,10 @@ package body Exp_Ch3 is
         and then not Is_Interface (Tag_Typ)
         and then
           ((Is_Interface (Etype (Tag_Typ))
-              and then Is_Limited_Record (Etype (Tag_Typ)))
+             and then Is_Limited_Record (Etype (Tag_Typ)))
            or else
              (Is_Concurrent_Record_Type (Tag_Typ)
-                and then Has_Interfaces (Tag_Typ))
+               and then Has_Interfaces (Tag_Typ))
            or else
              (not Tagged_Type_Expansion
                and then Tag_Typ = Root_Type (Tag_Typ)))

gcc/ada/exp_ch9.adb

@@ -8698,9 +8698,7 @@ package body Exp_Ch9 is
          if Tagged_Type_Expansion then
             Prepend_To (Params,
               Make_Function_Call (Loc,
-                Name =>
+                Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
-                  New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
-
                 Parameter_Associations => New_List (
                   Unchecked_Convert_To (RTE (RE_Tag), Concval),
                   Make_Integer_Literal (Loc, DT_Position (Entity (Ename))))));
@@ -8710,20 +8708,20 @@ package body Exp_Ch9 is
          else
             Prepend_To (Params,
               Make_Function_Call (Loc,
-                Name =>
+                Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
-                  New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
 
                 Parameter_Associations => New_List (
+
                   --  Obj_Typ
 
                   Make_Attribute_Reference (Loc,
-                    Prefix => Concval,
+                    Prefix         => Concval,
                     Attribute_Name => Name_Tag),
 
                   --  Tag_Typ
 
                   Make_Attribute_Reference (Loc,
-                    Prefix => New_Reference_To (Etype (Concval), Loc),
+                    Prefix         => New_Reference_To (Etype (Concval), Loc),
                     Attribute_Name => Name_Tag),
 
                   --  Position

gcc/ada/exp_disp.adb

@@ -6627,7 +6627,7 @@ package body Exp_Disp is
                            --  Iface_Tag
 
                          Make_Attribute_Reference (Loc,
-                           Prefix => New_Reference_To (Iface, Loc),
+                           Prefix         => New_Reference_To (Iface, Loc),
                            Attribute_Name => Name_Tag),
 
                            --  OSD
@@ -6648,7 +6648,7 @@ package body Exp_Disp is
                      Make_Subtype_Indication (Loc,
                        Subtype_Mark =>
                          New_Reference_To (RTE (RE_Interface_Data), Loc),
-                       Constraint => Make_Index_Or_Discriminant_Constraint
+                       Constraint   => Make_Index_Or_Discriminant_Constraint
                          (Loc,
                           Constraints => New_List (
                             Make_Integer_Literal (Loc, Num_Ifaces)))),

gcc/ada/exp_sel.adb

@@ -156,7 +156,7 @@ package body Exp_Sel is
       else
          Tag_Node :=
            Make_Attribute_Reference (Loc,
-             Prefix => Obj,
+             Prefix         => Obj,
              Attribute_Name => Name_Tag);
       end if;
 
@@ -205,7 +205,7 @@ package body Exp_Sel is
       if Tagged_Type_Expansion then
          return
            Make_Assignment_Statement (Loc,
-             Name => New_Reference_To (S, Loc),
+             Name       => New_Reference_To (S, Loc),
              Expression =>
                Make_Function_Call (Loc,
                  Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
@@ -218,10 +218,11 @@ package body Exp_Sel is
       else
          return
            Make_Assignment_Statement (Loc,
-             Name => New_Reference_To (S, Loc),
+             Name       => New_Reference_To (S, Loc),
              Expression =>
                Make_Function_Call (Loc,
                  Name => New_Reference_To (RTE (RE_Get_Offset_Index), Loc),
+
                  Parameter_Associations => New_List (
 
                      --  Obj_Typ

gcc/ada/restrict.ads

@@ -185,6 +185,10 @@ package Restrict is
    --  The table contains pairs of source locations, the first being the start
    --  location for hidden region, and the second being the end location.
 
+   --  Note that the start location is included in the hidden region, while
+   --  the end location is excluded from it. (It typically corresponds to the
+   --  next token during scanning.)
+
    type SPARK_Hide_Entry is record
       Start : Source_Ptr;
       Stop  : Source_Ptr;
@@ -310,8 +314,8 @@ package Restrict is
    function Get_Restriction_Id
      (N : Name_Id) return Restriction_Id;
    --  Given an identifier name, determines if it is a valid restriction
-   --  identifier, and if so returns the corresponding Restriction_Id
+   --  identifier, and if so returns the corresponding Restriction_Id value,
-   --  value, otherwise returns Not_A_Restriction_Id.
+   --  otherwise returns Not_A_Restriction_Id.
 
    function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean;
    --  Determine if given location is covered by a hidden region range in the
@@ -358,9 +362,9 @@ package Restrict is
 
    function Restricted_Profile return Boolean;
    --  Tests if set of restrictions corresponding to Profile (Restricted) is
-   --  currently in effect (set by pragma Profile, or by an appropriate set
+   --  currently in effect (set by pragma Profile, or by an appropriate set of
-   --  of individual Restrictions pragmas). Returns True only if all the
+   --  individual Restrictions pragmas). Returns True only if all the required
-   --  required restrictions are set.
+   --  restrictions are set.
 
    procedure Set_Hidden_Part_In_SPARK (Loc1, Loc2 : Source_Ptr);
    --  Insert a new hidden region range in the SPARK hides table
@@ -394,8 +398,8 @@ package Restrict is
      (Unit    : Node_Id;
       Warn    : Boolean;
       Profile : Profile_Name := No_Profile);
-   --  Sets given No_Dependence restriction in table if not there already.
+   --  Sets given No_Dependence restriction in table if not there already. Warn
-   --  Warn is True if from Restriction_Warnings, or for Restrictions if flag
+   --  is True if from Restriction_Warnings, or for Restrictions if the flag
    --  Treat_Restrictions_As_Warnings is set. False if from Restrictions and
    --  this flag is not set. Profile is set to a non-default value if the
    --  No_Dependence restriction comes from a Profile pragma.

gcc/ada/sinfo.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2011, 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- --
@@ -1440,11 +1440,17 @@ package body Sinfo is
    function Has_Dynamic_Length_Check
       (N : Node_Id) return Boolean is
    begin
+      pragma Assert (False
+        or else NT (N).Nkind in N_Subexpr);
       return Flag10 (N);
    end Has_Dynamic_Length_Check;
+
    function Has_Dynamic_Range_Check
       (N : Node_Id) return Boolean is
    begin
+      pragma Assert (False
+        or else NT (N).Nkind =  N_Subtype_Declaration
+        or else NT (N).Nkind in N_Subexpr);
       return Flag12 (N);
    end Has_Dynamic_Range_Check;
 
@@ -4484,12 +4490,17 @@ package body Sinfo is
    procedure Set_Has_Dynamic_Length_Check
       (N : Node_Id; Val : Boolean := True) is
    begin
+      pragma Assert (False
+        or else NT (N).Nkind in N_Subexpr);
       Set_Flag10 (N, Val);
    end Set_Has_Dynamic_Length_Check;
 
    procedure Set_Has_Dynamic_Range_Check
       (N : Node_Id; Val : Boolean := True) is
    begin
+      pragma Assert (False
+        or else NT (N).Nkind =  N_Subtype_Declaration
+        or else NT (N).Nkind in N_Subexpr);
       Set_Flag12 (N, Val);
    end Set_Has_Dynamic_Range_Check;
 

gcc/ada/sinfo.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2011, 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- --
@@ -424,6 +424,8 @@ package Sinfo is
    --       Raises_Constraint_Error  (Flag7-Sem)  evaluation raises CE
    --       Must_Not_Freeze          (Flag8-Sem)  set if must not freeze
    --       Do_Range_Check           (Flag9-Sem)  set if a range check needed
+   --       Has_Dynamic_Length_Check (Flag10-Sem) set if length check inserted
+   --       Has_Dynamic_Range_Check  (Flag12-Sem) set if range check inserted
    --       Assignment_OK            (Flag15-Sem) set if modification is OK
    --       Is_Controlling_Actual    (Flag16-Sem) set for controlling argument
 
@@ -485,18 +487,6 @@ package Sinfo is
    --    refers to a node or is posted on its source location, and has the
    --    effect of inhibiting further messages involving this same node.
 
-   --  Has_Dynamic_Length_Check (Flag10-Sem)
-   --    This flag is present on all nodes. It is set to indicate that one of
-   --    the routines in unit Checks has generated a length check action which
-   --    has been inserted at the flagged node. This is used to avoid the
-   --    generation of duplicate checks.
-
-   --  Has_Dynamic_Range_Check (Flag12-Sem)
-   --    This flag is present on all nodes. It is set to indicate that one of
-   --    the routines in unit Checks has generated a range check action which
-   --    has been inserted at the flagged node. This is used to avoid the
-   --    generation of duplicate checks.
-
    ------------------------------------
    -- Description of Semantic Fields --
    ------------------------------------
@@ -1125,6 +1115,19 @@ package Sinfo is
    --    handler is deleted during optimization. For further details on why
    --    this is required, see Exp_Ch11.Remove_Handler_Entries.
 
+   --  Has_Dynamic_Length_Check (Flag10-Sem)
+   --    This flag is present on all expression nodes. It is set to indicate
+   --    that one of the routines in unit Checks has generated a length check
+   --    action which has been inserted at the flagged node. This is used to
+   --    avoid the generation of duplicate checks.
+
+   --  Has_Dynamic_Range_Check (Flag12-Sem)
+   --    This flag is present in N_Subtype_Declaration nodes and on all
+   --    expression nodes. It is set to indicate that one of the routines in
+   --    unit Checks has generated a range check action which has been inserted
+   --    at the flagged node. This is used to avoid the generation of duplicate
+   --    checks.
+
    --  Has_Local_Raise (Flag8-Sem)
    --    Present in exception handler nodes. Set if the handler can be entered
    --    via a local raise that gets transformed to a goto statement. This will
@@ -2217,6 +2220,7 @@ package Sinfo is
       --  Subtype_Indication (Node5)
       --  Generic_Parent_Type (Node4-Sem) (set for an actual derived type).
       --  Exception_Junk (Flag8-Sem)
+      --  Has_Dynamic_Range_Check (Flag12-Sem)
 
       -------------------------------
       -- 3.2.2  Subtype Indication --