2011-12-12 Thomas Quinot <quinot@adacore.com>

	* exp_disp.adb: Minor reformatting.

2011-12-12  Tristan Gingold  <gingold@adacore.com>

	* gnatls.adb (Search_RTS): New procedure.
	(Scan_Ls_Arg): Move code that search the RTS.
	(Gnatls): search the RTS later.
	* prj-env.ads, prj-env.adb (Get_Runtime_Path): New function.

2011-12-12  Ed Falis  <falis@adacore.com>

	* sysdep.c: Fix treatment of VxWorks task options so that run-times
	built with __SPE__ get option VX_SPE_TASK while others get VX_FP_TASK.

2011-12-12  Bob Duff  <duff@adacore.com>

	* sem_type.adb, sem_type.ads, sem_ch4.adb, treepr.adb, treepr.ads:
	Minor cleanup and fiddling with debug printouts.

2011-12-12  Vincent Celier  <celier@adacore.com>

	* prj-nmsc.adb (Get_Directories): For a non extending project,
	always get a declared object and/or exec directory if it already
	exists, even when there are no sources, but do not create them.

2011-12-12  Bob Duff  <duff@adacore.com>

	* sem_res.adb (Resolve): Deal with the case where an abstract
	operator is called with operands of type universal_integer.

2011-12-12  Thomas Quinot  <quinot@adacore.com>

	* par_sco.adb: Minor fix to dominance marker referencing WHILE
	decision.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@182227 138bc75d-0d04-0410-961f-82ee72b054a4

14 files changed, 330 insertions, 90 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 84ea178943e..afb9062a868 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,40 @@
+2011-12-12  Thomas Quinot  <quinot@adacore.com>
+
+	* exp_disp.adb: Minor reformatting.
+
+2011-12-12  Tristan Gingold  <gingold@adacore.com>
+
+	* gnatls.adb (Search_RTS): New procedure.
+	(Scan_Ls_Arg): Move code that search the RTS.
+	(Gnatls): search the RTS later.
+	* prj-env.ads, prj-env.adb (Get_Runtime_Path): New function.
+
+2011-12-12  Ed Falis  <falis@adacore.com>
+
+	* sysdep.c: Fix treatment of VxWorks task options so that run-times
+	built with __SPE__ get option VX_SPE_TASK while others get VX_FP_TASK.
+
+2011-12-12  Bob Duff  <duff@adacore.com>
+
+	* sem_type.adb, sem_type.ads, sem_ch4.adb, treepr.adb, treepr.ads:
+	Minor cleanup and fiddling with debug printouts.
+
+2011-12-12  Vincent Celier  <celier@adacore.com>
+
+	* prj-nmsc.adb (Get_Directories): For a non extending project,
+	always get a declared object and/or exec directory if it already
+	exists, even when there are no sources, but do not create them.
+
+2011-12-12  Bob Duff  <duff@adacore.com>
+
+	* sem_res.adb (Resolve): Deal with the case where an abstract
+	operator is called with operands of type universal_integer.
+
+2011-12-12  Thomas Quinot  <quinot@adacore.com>
+
+	* par_sco.adb: Minor fix to dominance marker referencing WHILE
+	decision.
+
 2011-12-12  Tristan Gingold  <gingold@adacore.com>
 
 	* mlib-tgt-specific-xi.adb: (Get_Target_Prefix): Simplify code.
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 21745288abf..df998e91e79 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -4852,8 +4852,8 @@ package body Exp_Disp is
       --            Transportable      => <<boolean-value>>,
       --            Type_Is_Abstract   => <<boolean-value>>,
       --            Needs_Finalization => <<boolean-value>>,
-      --            [ Size_Func         => Size_Prim'Access ]
-      --            [ Interfaces_Table  => <<access-value>> ]
+      --            [ Size_Func         => Size_Prim'Access, ]
+      --            [ Interfaces_Table  => <<access-value>>, ]
       --            [ SSD               => SSD_Table'Address ]
       --            Tags_Table         => (0 => null,
       --                                   1 => Parent'Tag
@@ -4900,7 +4900,7 @@ package body Exp_Disp is
       Append_To (TSD_Aggr_List,
         Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
           Make_Attribute_Reference (Loc,
-            Prefix => New_Reference_To (Exname, Loc),
+            Prefix         => New_Reference_To (Exname, Loc),
             Attribute_Name => Name_Address)));
 
       --  External_Tag of a local tagged type
diff --git a/gcc/ada/gnatls.adb b/gcc/ada/gnatls.adb
index 7c7b41f89e8..ac00ec84d9e 100644
--- a/gcc/ada/gnatls.adb
+++ b/gcc/ada/gnatls.adb
@@ -75,7 +75,7 @@ procedure Gnatls is
       Value : String_Access;
       Next  : Dir_Ref;
    end record;
-   --  ??? comment needed
+   --  Simply linked list of dirs
 
    First_Source_Dir : Dir_Ref;
    Last_Source_Dir  : Dir_Ref;
@@ -169,6 +169,9 @@ procedure Gnatls is
    procedure Scan_Ls_Arg (Argv : String);
    --  Scan and process lser specific arguments. Argv is a single argument
 
+   procedure Search_RTS (Name : String);
+   --  Find include and objects path for the RTS name.
+
    procedure Usage;
    --  Print usage message
 
@@ -1176,6 +1179,62 @@ procedure Gnatls is
       end if;
    end Reset_Print;
 
+   ----------------
+   -- Search_RTS --
+   ----------------
+
+   procedure Search_RTS (Name : String) is
+      Src_Path : String_Ptr;
+      Lib_Path : String_Ptr;
+      --  Pathes for source and include subdirs
+
+      Rts_Full_Path : String_Access;
+      --  Full path for RTS project
+   begin
+      --  Try to find the RTS
+
+      Src_Path := Get_RTS_Search_Dir (Name, Include);
+      Lib_Path := Get_RTS_Search_Dir (Name, Objects);
+
+      --  For non-project RTS, both the include and the objects directories
+      --  must be present.
+
+      if Src_Path /= null and then Lib_Path /= null then
+         Add_Search_Dirs (Src_Path, Include);
+         Add_Search_Dirs (Lib_Path, Objects);
+         return;
+      end if;
+
+      if Lib_Path /= null then
+         Osint.Fail ("RTS path not valid: missing adainclude directory");
+
+      elsif Src_Path /= null then
+         Osint.Fail ("RTS path not valid: missing adalib directory");
+
+      end if;
+
+      --  Try to find the RTS on the project path.  First setup the project
+      --  path.
+
+      Initialize_Default_Project_Path
+        (Prj_Path, Target_Name => Sdefault.Target_Name.all);
+
+      Rts_Full_Path := Get_Runtime_Path (Prj_Path, Name);
+      if Rts_Full_Path /= null then
+         --  Directory name was found on the project path.  Look for the
+         --  include subdir(s).
+
+         Src_Path := Get_RTS_Search_Dir (Name, Include);
+         if Src_Path /= null then
+            Add_Search_Dirs (Src_Path, Include);
+            return;
+         end if;
+      end if;
+
+      Osint.Fail ("RTS path not valid: missing " &
+                    "adainclude and adalib directories");
+   end Search_RTS;
+
    -------------------
    -- Scan_Ls_Arg --
    -------------------
@@ -1326,37 +1385,6 @@ procedure Gnatls is
 
                Opt.No_Stdinc := True;
                Opt.RTS_Switch := True;
-
-               declare
-                  Src_Path_Name : constant String_Ptr :=
-                                    Get_RTS_Search_Dir
-                                      (Argv (7 .. Argv'Last), Include);
-                  Lib_Path_Name : constant String_Ptr :=
-                                    Get_RTS_Search_Dir
-                                      (Argv (7 .. Argv'Last), Objects);
-
-               begin
-                  if Src_Path_Name /= null
-                    and then Lib_Path_Name /= null
-                  then
-                     Add_Search_Dirs (Src_Path_Name, Include);
-                     Add_Search_Dirs (Lib_Path_Name, Objects);
-
-                  elsif Src_Path_Name = null
-                    and then Lib_Path_Name = null
-                  then
-                     Osint.Fail ("RTS path not valid: missing " &
-                                 "adainclude and adalib directories");
-
-                  elsif Src_Path_Name = null then
-                     Osint.Fail ("RTS path not valid: missing " &
-                                 "adainclude directory");
-
-                  elsif Lib_Path_Name = null then
-                     Osint.Fail ("RTS path not valid: missing " &
-                                 "adalib directory");
-                  end if;
-               end;
             end if;
          end if;
 
@@ -1521,6 +1549,12 @@ begin
       Exit_Program (E_Fatal);
    end if;
 
+   --  Handle --RTS switch
+
+   if RTS_Specified /= null then
+      Search_RTS (RTS_Specified.all);
+   end if;
+
    --  Add the source and object directories specified on the command line, if
    --  any, to the searched directories.
 
diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb
index 38991ce6be3..28fa18681ce 100644
--- a/gcc/ada/par_sco.adb
+++ b/gcc/ada/par_sco.adb
@@ -1482,8 +1482,10 @@ package body Par_SCO is
                            Process_Decisions_Defer (Condition (ISC), 'W');
 
                            --  Set more specific dominant for inner statements
+                           --  (the control sloc for the decision is that of
+                           --  the WHILE token).
 
-                           Inner_Dominant := ('T', N);
+                           Inner_Dominant := ('T', ISC);
 
                         --  For loop
 
diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb
index 898ba8dfa35..7cd1fe5fe8b 100644
--- a/gcc/ada/prj-env.adb
+++ b/gcc/ada/prj-env.adb
@@ -1401,6 +1401,35 @@ package body Prj.Env is
       end if;
    end Get_Reference;
 
+   ----------------------
+   -- Get_Runtime_Path --
+   ----------------------
+
+   function Get_Runtime_Path (Self : Project_Search_Path; Name : String)
+     return String_Access is
+      function Is_Base_Name (Path : String) return Boolean;
+      --  Returns True if Path has no directory separator
+
+      function Is_Base_Name (Path : String) return Boolean is
+      begin
+         for I in Path'Range loop
+            if Path (I) = Directory_Separator or else Path (I) = '/' then
+               return False;
+            end if;
+         end loop;
+         return True;
+      end Is_Base_Name;
+
+      function Find_Rts_In_Path is new Prj.Env.Find_Name_In_Path
+        (Check_Filename => Is_Directory);
+   begin
+      if not Is_Base_Name (Name) then
+         return Find_Rts_In_Path (Self, Name);
+      else
+         return null;
+      end if;
+   end Get_Runtime_Path;
+
    ----------------
    -- Initialize --
    ----------------
diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads
index 79de6464a0a..0bdaafa5862 100644
--- a/gcc/ada/prj-env.ads
+++ b/gcc/ada/prj-env.ads
@@ -236,6 +236,13 @@ package Prj.Env is
    --
    --  Returns No_Name if no such project was found
 
+   function Get_Runtime_Path (Self : Project_Search_Path; Name : String)
+     return String_Access;
+   --  Compute the full path for the project-based runtime name.  It first
+   --  checks that name is not a simple name (must has a path separator in it),
+   --  and returns null in case of failure.  This check might be removed in the
+   --  future.  The name is simply searched on the project path.
+
 private
    package Projects_Paths is new GNAT.Dynamic_HTables.Simple_HTable
      (Header_Num => Header_Num,
diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb
index 0ff3eda1732..be644828594 100644
--- a/gcc/ada/prj-nmsc.adb
+++ b/gcc/ada/prj-nmsc.adb
@@ -5284,8 +5284,24 @@ package body Prj.Nmsc is
                "Object_Dir cannot be empty",
                Object_Dir.Location, Project);
 
-         elsif not No_Sources then
+         elsif Setup_Projects and then
+               No_Sources and then
+               Project.Extends = No_Project
+         then
+            --  Do not create an object directory for a non extending project
+            --  with no sources.
+
+            Locate_Directory
+              (Project,
+               File_Name_Type (Object_Dir.Value),
+               Path             => Project.Object_Directory,
+               Dir_Exists       => Dir_Exists,
+               Data             => Data,
+               Location         => Object_Dir.Location,
+               Must_Exist       => False,
+               Externally_Built => Project.Externally_Built);
 
+         else
             --  We check that the specified object directory does exist.
             --  However, even when it doesn't exist, we set it to a default
             --  value. This is for the benefit of tools that recover from
@@ -5355,8 +5371,23 @@ package body Prj.Nmsc is
                "Exec_Dir cannot be empty",
                Exec_Dir.Location, Project);
 
-         elsif not No_Sources then
+         elsif Setup_Projects and then
+               No_Sources and then
+               Project.Extends = No_Project
+         then
+            --  Do not create an exec directory for a non extending project
+            --  with no sources.
 
+            Locate_Directory
+              (Project,
+               File_Name_Type (Exec_Dir.Value),
+               Path             => Project.Exec_Directory,
+               Dir_Exists       => Dir_Exists,
+               Data             => Data,
+               Location         => Exec_Dir.Location,
+               Externally_Built => Project.Externally_Built);
+
+         else
             --  We check that the specified exec directory does exist
 
             Locate_Directory
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 197b5757d4b..7e8fed1d852 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -6219,6 +6219,11 @@ package body Sem_Ch4 is
 
    begin
       if Is_Overloaded (N) then
+         if Debug_Flag_V then
+            Write_Str ("Remove_Abstract_Operations: ");
+            Write_Overloads (N);
+         end if;
+
          Get_First_Interp (N, I, It);
 
          while Present (It.Nam) loop
@@ -6412,6 +6417,11 @@ package body Sem_Ch4 is
                end loop;
             end if;
          end if;
+
+         if Debug_Flag_V then
+            Write_Str ("Remove_Abstract_Operations done: ");
+            Write_Overloads (N);
+         end if;
       end if;
    end Remove_Abstract_Operations;
 
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index a240781dc8a..64ac6526b0b 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -1989,6 +1989,9 @@ package body Sem_Res is
       end if;
 
       Debug_A_Entry ("resolving  ", N);
+      if Debug_Flag_V then
+         Write_Overloads (N);
+      end if;
 
       if Comes_From_Source (N) then
          if Is_Fixed_Point_Type (Typ) then
@@ -2033,6 +2036,11 @@ package body Sem_Res is
          Get_First_Interp (N, I, It);
          Interp_Loop : while Present (It.Typ) loop
 
+            if Debug_Flag_V then
+               Write_Str ("Interp: ");
+               Write_Interp (It);
+            end if;
+
             --  We are only interested in interpretations that are compatible
             --  with the expected type, any other interpretations are ignored.
 
@@ -2054,6 +2062,10 @@ package body Sem_Res is
                  and then Typ /= Universal_Real
                  and then Present (It.Abstract_Op)
                then
+                  if Debug_Flag_V then
+                     Write_Line ("Skip.");
+                  end if;
+
                   goto Continue;
                end if;
 
@@ -2572,9 +2584,36 @@ package body Sem_Res is
          Resolution_Failed;
          return;
 
-      --  Here we have an acceptable interpretation for the context
-
       else
+         --  In Ada 2005, if we have something like "X : T := 2 + 2;", where
+         --  the "+" on T is abstract, and the operands are of universal type,
+         --  the above code will have (incorrectly) resolved the "+" to the
+         --  universal one in Standard. Therefore, we check for this case, and
+         --  give an error. We can't do this earlier, because it would cause
+         --  legal cases to get errors (when some other type has an abstract
+         --  "+").
+
+         if Ada_Version >= Ada_2005 and then
+           Nkind (N) in N_Op and then
+           Is_Overloaded (N) and then
+           Is_Universal_Numeric_Type (Etype (Entity (N)))
+         then
+            Get_First_Interp (N, I, It);
+            while Present (It.Typ) loop
+               if Present (It.Abstract_Op) and then
+                 Etype (It.Abstract_Op) = Typ
+               then
+                  Error_Msg_NE
+                    ("cannot call abstract subprogram &!", N, It.Abstract_Op);
+                  return;
+               end if;
+
+               Get_Next_Interp (I, It);
+            end loop;
+         end if;
+
+         --  Here we have an acceptable interpretation for the context
+
          --  Propagate type information and normalize tree for various
          --  predefined operations. If the context only imposes a class of
          --  types, rather than a specific type, propagate the actual type
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index c391163ea4b..0d10262fc28 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -46,6 +46,7 @@ with Stand;    use Stand;
 with Sinfo;    use Sinfo;
 with Snames;   use Snames;
 with Table;
+with Treepr;   use Treepr;
 with Uintp;    use Uintp;
 
 package body Sem_Type is
@@ -81,7 +82,7 @@ package body Sem_Type is
 
    package All_Interp is new Table.Table (
      Table_Component_Type => Interp,
-     Table_Index_Type     => Int,
+     Table_Index_Type     => Interp_Index,
      Table_Low_Bound      => 0,
      Table_Initial        => Alloc.All_Interp_Initial,
      Table_Increment      => Alloc.All_Interp_Increment,
@@ -3435,6 +3436,20 @@ package body Sem_Type is
       end if;
    end Valid_Comparison_Arg;
 
+   ------------------
+   -- Write_Interp --
+   ------------------
+
+   procedure Write_Interp (It : Interp) is
+   begin
+      Write_Str ("Nam: ");
+      Print_Tree_Node (It.Nam);
+      Write_Str ("Typ: ");
+      Print_Tree_Node (It.Typ);
+      Write_Str ("Abstract_Op: ");
+      Print_Tree_Node (It.Abstract_Op);
+   end Write_Interp;
+
    ----------------------
    -- Write_Interp_Ref --
    ----------------------
@@ -3460,6 +3475,13 @@ package body Sem_Type is
       Nam : Entity_Id;
 
    begin
+      Write_Str ("Overloads: ");
+      Print_Node_Briefly (N);
+
+      if Nkind (N) not in N_Has_Entity then
+         return;
+      end if;
+
       if not Is_Overloaded (N) then
          Write_Str ("Non-overloaded entity ");
          Write_Eol;
diff --git a/gcc/ada/sem_type.ads b/gcc/ada/sem_type.ads
index 4d46a8e1fd1..2c5c1dba778 100644
--- a/gcc/ada/sem_type.ads
+++ b/gcc/ada/sem_type.ads
@@ -73,7 +73,7 @@ package Sem_Type is
 
    No_Interp : constant Interp := (Empty, Empty, Empty);
 
-   subtype Interp_Index is Int;
+   type Interp_Index is new Int;
 
    ---------------------
    -- Error Reporting --
@@ -148,7 +148,7 @@ package Sem_Type is
    --  The end of the list of interpretations is signalled by It.Nam = Empty.
 
    procedure Remove_Interp (I : in out Interp_Index);
-   --  Remove an interpretation that his hidden by another, or that does not
+   --  Remove an interpretation that is hidden by another, or that does not
    --  match the context. The value of I on input was set by a call to either
    --  Get_First_Interp or Get_Next_Interp and references the interpretation
    --  to be removed. The only allowed use of the exit value of I is as input
@@ -264,6 +264,9 @@ package Sem_Type is
    --  A valid argument of a boolean operator is either some boolean type, or a
    --  one-dimensional array of boolean type.
 
+   procedure Write_Interp (It : Interp);
+   --  Debugging procedure to display an Interp
+
    procedure Write_Interp_Ref (Map_Ptr : Int);
    --  Debugging procedure to display entry in Interp_Map. Would not be needed
    --  if it were possible to debug instantiations of Table.
diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c
index 2b99a32b132..fbb4a00809a 100644
--- a/gcc/ada/sysdep.c
+++ b/gcc/ada/sysdep.c
@@ -850,7 +850,7 @@ __gnat_localtime_tzoff (const time_t *timer, long *off)
    the options assigned to the current task (parent), so offering some user
    level control over the options for a task hierarchy. It forces VX_FP_TASK
    because it is almost always required. On processors with the SPE
-   category, VX_SPE_TASK is needed to enable the SPE. */
+   category, VX_SPE_TASK should be used instead to enable the SPE. */
 extern int __gnat_get_task_options (void);
 
 int
@@ -861,10 +861,11 @@ __gnat_get_task_options (void)
   /* Get the options for the task creator */
   taskOptionsGet (taskIdSelf (), &options);
 
-  /* Force VX_FP_TASK because it is almost always required */
-  options |= VX_FP_TASK;
-#if defined (__SPE__) && (! defined (__VXWORKSMILS__))
+  /* Force VX_FP_TASK or VX_SPE_TASK as needed */
+#if defined (__SPE__)
   options |= VX_SPE_TASK;
+#else
+  options |= VX_FP_TASK;
 #endif
 
   /* Mask those bits that are not under user control */
diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb
index 684cccdcc19..ed827ccdfcf 100644
--- a/gcc/ada/treepr.adb
+++ b/gcc/ada/treepr.adb
@@ -138,6 +138,9 @@ package body Treepr is
    --  Print name from names table if currently in print phase, noop if in
    --  marking phase. Note that the name is output in mixed case mode.
 
+   procedure Print_Node_Header (N : Node_Id);
+   --  Print header line used by Print_Node and Print_Node_Briefly
+
    procedure Print_Node_Kind (N : Node_Id);
    --  Print node kind name in mixed case if in print phase, noop if in
    --  marking phase.
@@ -885,7 +888,6 @@ package body Treepr is
       Prefix_Str_Char     : String (Prefix_Str'First .. Prefix_Str'Last + 1);
 
       Sfile : Source_File_Index;
-      Notes : Boolean;
       Fmt   : UI_Format;
 
    begin
@@ -905,48 +907,7 @@ package body Treepr is
       --  Print header line
 
       Print_Str (Prefix_Str);
-      Print_Node_Ref (N);
-
-      Notes := False;
-
-      if N > Atree_Private_Part.Nodes.Last then
-         Print_Str (" (no such node)");
-         Print_Eol;
-         return;
-      end if;
-
-      if Comes_From_Source (N) then
-         Notes := True;
-         Print_Str (" (source");
-      end if;
-
-      if Analyzed (N) then
-         if not Notes then
-            Notes := True;
-            Print_Str (" (");
-         else
-            Print_Str (",");
-         end if;
-
-         Print_Str ("analyzed");
-      end if;
-
-      if Error_Posted (N) then
-         if not Notes then
-            Notes := True;
-            Print_Str (" (");
-         else
-            Print_Str (",");
-         end if;
-
-         Print_Str ("posted");
-      end if;
-
-      if Notes then
-         Print_Char (')');
-      end if;
-
-      Print_Eol;
+      Print_Node_Header (N);
 
       if Is_Rewrite_Substitution (N) then
          Print_Str (Prefix_Str);
@@ -1275,6 +1236,67 @@ package body Treepr is
       end if;
    end Print_Node;
 
+   ------------------------
+   -- Print_Node_Briefly --
+   ------------------------
+
+   procedure Print_Node_Briefly (N : Node_Id) is
+   begin
+      Printing_Descendants := False;
+      Phase := Printing;
+      Print_Node_Header (N);
+   end Print_Node_Briefly;
+
+   -----------------------
+   -- Print_Node_Header --
+   -----------------------
+
+   procedure Print_Node_Header (N : Node_Id) is
+      Notes : Boolean := False;
+
+   begin
+      Print_Node_Ref (N);
+
+      if N > Atree_Private_Part.Nodes.Last then
+         Print_Str (" (no such node)");
+         Print_Eol;
+         return;
+      end if;
+
+      if Comes_From_Source (N) then
+         Notes := True;
+         Print_Str (" (source");
+      end if;
+
+      if Analyzed (N) then
+         if not Notes then
+            Notes := True;
+            Print_Str (" (");
+         else
+            Print_Str (",");
+         end if;
+
+         Print_Str ("analyzed");
+      end if;
+
+      if Error_Posted (N) then
+         if not Notes then
+            Notes := True;
+            Print_Str (" (");
+         else
+            Print_Str (",");
+         end if;
+
+         Print_Str ("posted");
+      end if;
+
+      if Notes then
+         Print_Char (')');
+      end if;
+
+      Print_Eol;
+   end Print_Node_Header;
+
    ---------------------
    -- Print_Node_Kind --
    ---------------------
diff --git a/gcc/ada/treepr.ads b/gcc/ada/treepr.ads
index 683eb0db90b..6e9541a8e9f 100644
--- a/gcc/ada/treepr.ads
+++ b/gcc/ada/treepr.ads
@@ -37,6 +37,9 @@ package Treepr is
    --  Prints a single tree node, without printing descendants. The Label
    --  string is used to preface each line of the printed output.
 
+   procedure Print_Node_Briefly (N : Node_Id);
+   --  Terse version of Print_Tree_Node
+
    procedure Print_Tree_List (L : List_Id);
    --  Prints a single node list, without printing the descendants of any
    --  of the nodes in the list