prj-pp.adb: New file.

	* prj-pp.adb : New file.

	* prj-pp.ads : New file.

From-SVN: r51512

3 files changed, 733 insertions, 0 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 42c0974..9246f26 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+2002-03-28   Geert Bosch <bosch@gnat.com>
+
+	* prj-pp.adb : New file.
+
+	* prj-pp.ads : New file.
+
 2002-03-28  Andreas Jaeger  <aj@suse.de>
 
 	* Makefile.in (stamp-sdefault): Fix path for Makefile.
diff --git a/gcc/ada/prj-pp.adb b/gcc/ada/prj-pp.adb
new file mode 100644
index 0000000..707417b
--- /dev/null
+++ b/gcc/ada/prj-pp.adb
@@ -0,0 +1,647 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               P R J . P P                                --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision$
+--                                                                          --
+--             Copyright (C) 2001-2002 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- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+
+with Hostparm;
+with Namet;     use Namet;
+with Output;    use Output;
+with Stringt;   use Stringt;
+
+package body Prj.PP is
+
+   use Prj.Tree;
+
+   Not_Tested : array (Project_Node_Kind) of Boolean := (others => True);
+
+   Max_Line_Length : constant := Hostparm.Max_Line_Length - 5;
+   --  Maximum length of a line.
+
+   Column : Natural := 0;
+   --  Column number of the last character in the line. Used to avoid
+   --  outputing lines longer than Max_Line_Length.
+
+   procedure Indicate_Tested (Kind : Project_Node_Kind);
+   --  Set the corresponding component of array Not_Tested to False.
+   --  Only called by pragmas Debug.
+   --
+
+   ---------------------
+   -- Indicate_Tested --
+   ---------------------
+
+   procedure Indicate_Tested (Kind : Project_Node_Kind) is
+   begin
+      Not_Tested (Kind) := False;
+   end Indicate_Tested;
+
+   ------------------
+   -- Pretty_Print --
+   ------------------
+
+   procedure Pretty_Print
+     (Project                            : Prj.Tree.Project_Node_Id;
+      Increment                          : Positive      := 3;
+      Eliminate_Empty_Case_Constructions : Boolean       := False;
+      Minimize_Empty_Lines               : Boolean       := False;
+      W_Char                             : Write_Char_Ap := null;
+      W_Eol                              : Write_Eol_Ap  := null;
+      W_Str                              : Write_Str_Ap  := null) is
+
+      procedure Print (Node : Project_Node_Id; Indent : Natural);
+      --  A recursive procedure that traverses a project file tree
+      --  and outputs its source.
+      --  Current_Prj is the project that we are printing. This
+      --  is used when printing attributes, since in nested packages they need
+      --  to use a fully qualified name.
+
+      procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True);
+      --  Outputs a name
+
+      procedure Start_Line (Indent : Natural);
+      --  Outputs the indentation at the beginning of the line.
+
+      procedure Output_String (S : String_Id);
+      --  Outputs a string using the default output procedures
+
+      procedure Write_Empty_Line (Always : Boolean := False);
+      --  Outputs an empty line, only if the previous line was not
+      --  empty already and either Always is True or Minimize_Empty_Lines
+      --  is False.
+
+      procedure Write_Line (S : String);
+      --  Outputs S followed by a new line
+
+      procedure Write_String (S : String);
+      --  Outputs S using Write_Str, starting a new line if line would
+      --  become too long.
+
+      Write_Char : Write_Char_Ap := Output.Write_Char'Access;
+      Write_Eol  : Write_Eol_Ap  := Output.Write_Eol'Access;
+      Write_Str  : Write_Str_Ap  := Output.Write_Str'Access;
+      --  These two access to procedure values are used for the output.
+
+      Last_Line_Is_Empty : Boolean := False;
+      --  Used to avoid two consecutive empty lines.
+
+      -----------------
+      -- Output_Name --
+      -----------------
+
+      procedure Output_Name (Name : Name_Id; Capitalize : Boolean := True) is
+         Capital : Boolean := Capitalize;
+
+      begin
+         Get_Name_String (Name);
+
+         --  If line would become too long, create new line
+
+         if Column + Name_Len > Max_Line_Length then
+            Write_Eol.all;
+            Column := 0;
+         end if;
+
+         for J in 1 .. Name_Len loop
+            if Capital then
+               Write_Char (To_Upper (Name_Buffer (J)));
+            else
+               Write_Char (Name_Buffer (J));
+            end if;
+
+            if Capitalize then
+               Capital :=
+                 Name_Buffer (J) = '_'
+                 or else Is_Digit (Name_Buffer (J));
+            end if;
+         end loop;
+      end Output_Name;
+
+      -------------------
+      -- Output_String --
+      -------------------
+
+      procedure Output_String (S : String_Id) is
+      begin
+         String_To_Name_Buffer (S);
+
+         --  If line could become too long, create new line.
+         --  Note that the number of characters on the line could be
+         --  twice the number of character in the string (if every
+         --  character is a '"') plus two (the initial and final '"').
+
+         if Column + Name_Len + Name_Len + 2 > Max_Line_Length then
+            Write_Eol.all;
+            Column := 0;
+         end if;
+
+         Write_Char ('"');
+         Column := Column + 1;
+         String_To_Name_Buffer (S);
+
+         for J in 1 .. Name_Len loop
+            if Name_Buffer (J) = '"' then
+               Write_Char ('"');
+               Write_Char ('"');
+               Column := Column + 2;
+            else
+               Write_Char (Name_Buffer (J));
+               Column := Column + 1;
+            end if;
+
+            --  If the string does not fit on one line, cut it in parts
+            --  and concatenate.
+
+            if J < Name_Len and then Column >= Max_Line_Length then
+               Write_Str (""" &");
+               Write_Eol.all;
+               Write_Char ('"');
+               Column := 1;
+            end if;
+         end loop;
+
+         Write_Char ('"');
+         Column := Column + 1;
+      end Output_String;
+
+      ----------------
+      -- Start_Line --
+      ----------------
+
+      procedure Start_Line (Indent : Natural) is
+      begin
+         if not Minimize_Empty_Lines then
+            Write_Str ((1 .. Indent => ' '));
+            Column := Column + Indent;
+         end if;
+      end Start_Line;
+
+      ----------------------
+      -- Write_Empty_Line --
+      ----------------------
+
+      procedure Write_Empty_Line (Always : Boolean := False) is
+      begin
+         if (Always or else not Minimize_Empty_Lines)
+           and then not Last_Line_Is_Empty then
+            Write_Eol.all;
+            Column := 0;
+            Last_Line_Is_Empty := True;
+         end if;
+      end Write_Empty_Line;
+
+      ----------------
+      -- Write_Line --
+      ----------------
+
+      procedure Write_Line (S : String) is
+      begin
+         Write_String (S);
+         Last_Line_Is_Empty := False;
+         Write_Eol.all;
+         Column := 0;
+      end Write_Line;
+
+      ------------------
+      -- Write_String --
+      ------------------
+
+      procedure Write_String (S : String) is
+      begin
+         --  If the string would not fit on the line,
+         --  start a new line.
+
+         if Column + S'Length > Max_Line_Length then
+            Write_Eol.all;
+            Column := 0;
+         end if;
+
+         Write_Str (S);
+         Column := Column + S'Length;
+      end Write_String;
+
+      -----------
+      -- Print --
+      -----------
+
+      procedure Print (Node   : Project_Node_Id; Indent : Natural) is
+      begin
+         if Node /= Empty_Node then
+
+            case Kind_Of (Node) is
+
+               when N_Project  =>
+                  pragma Debug (Indicate_Tested (N_Project));
+                  if First_With_Clause_Of (Node) /= Empty_Node then
+
+                     --  with clause(s)
+
+                     Print (First_With_Clause_Of (Node), Indent);
+                     Write_Empty_Line (Always => True);
+                  end if;
+
+                  Start_Line (Indent);
+                  Write_String ("project ");
+                  Output_Name (Name_Of (Node));
+
+                  --  Check if this project modifies another project
+
+                  if Modified_Project_Path_Of (Node) /= No_String then
+                     Write_String (" extends ");
+                     Output_String (Modified_Project_Path_Of (Node));
+                  end if;
+
+                  Write_Line (" is");
+                  Write_Empty_Line (Always => True);
+
+                  --  Output all of the declarations in the project
+
+                  Print (Project_Declaration_Of (Node), Indent);
+                  Start_Line (Indent);
+                  Write_String ("end ");
+                  Output_Name (Name_Of (Node));
+                  Write_Line (";");
+
+               when N_With_Clause =>
+                  pragma Debug (Indicate_Tested (N_With_Clause));
+
+                  if Name_Of (Node) /= No_Name then
+                     Start_Line (Indent);
+                     Write_String ("with ");
+                     Output_String (String_Value_Of (Node));
+                     Write_Line (";");
+                  end if;
+
+                  Print (Next_With_Clause_Of (Node), Indent);
+
+               when N_Project_Declaration =>
+                  pragma Debug (Indicate_Tested (N_Project_Declaration));
+
+                  if First_Declarative_Item_Of (Node) /= Empty_Node then
+                     Print
+                       (First_Declarative_Item_Of (Node), Indent + Increment);
+                     Write_Empty_Line (Always => True);
+                  end if;
+
+               when N_Declarative_Item =>
+                  pragma Debug (Indicate_Tested (N_Declarative_Item));
+                  Print (Current_Item_Node (Node), Indent);
+                  Print (Next_Declarative_Item (Node), Indent);
+
+               when N_Package_Declaration =>
+                  pragma Debug (Indicate_Tested (N_Package_Declaration));
+                  Write_Empty_Line (Always => True);
+                  Start_Line (Indent);
+                  Write_String ("package ");
+                  Output_Name (Name_Of (Node));
+
+                  if Project_Of_Renamed_Package_Of (Node) /= Empty_Node then
+                     Write_String (" renames ");
+                     Output_Name
+                       (Name_Of (Project_Of_Renamed_Package_Of (Node)));
+                     Write_String (".");
+                     Output_Name (Name_Of (Node));
+                     Write_Line (";");
+
+                  else
+                     Write_Line (" is");
+
+                     if First_Declarative_Item_Of (Node) /= Empty_Node then
+                        Print
+                          (First_Declarative_Item_Of (Node),
+                           Indent + Increment);
+                     end if;
+
+                     Start_Line (Indent);
+                     Write_String ("end ");
+                     Output_Name (Name_Of (Node));
+                     Write_Line (";");
+                     Write_Empty_Line;
+                  end if;
+
+               when N_String_Type_Declaration =>
+                  pragma Debug (Indicate_Tested (N_String_Type_Declaration));
+                  Start_Line (Indent);
+                  Write_String ("type ");
+                  Output_Name (Name_Of (Node));
+                  Write_Line (" is");
+                  Start_Line (Indent + Increment);
+                  Write_String ("(");
+
+                  declare
+                     String_Node : Project_Node_Id :=
+                       First_Literal_String (Node);
+
+                  begin
+                     while String_Node /= Empty_Node loop
+                        Output_String (String_Value_Of (String_Node));
+                        String_Node := Next_Literal_String (String_Node);
+
+                        if String_Node /= Empty_Node then
+                           Write_String (", ");
+                        end if;
+                     end loop;
+                  end;
+
+                  Write_Line (");");
+
+               when N_Literal_String =>
+                  pragma Debug (Indicate_Tested (N_Literal_String));
+                  Output_String (String_Value_Of (Node));
+
+               when N_Attribute_Declaration =>
+                  pragma Debug (Indicate_Tested (N_Attribute_Declaration));
+                  Start_Line (Indent);
+                  Write_String ("for ");
+                  Output_Name (Name_Of (Node));
+
+                  if Associative_Array_Index_Of (Node) /= No_String then
+                     Write_String (" (");
+                     Output_String (Associative_Array_Index_Of (Node));
+                     Write_String (")");
+                  end if;
+
+                  Write_String (" use ");
+                  Print (Expression_Of (Node), Indent);
+                  Write_Line (";");
+
+               when N_Typed_Variable_Declaration =>
+                  pragma Debug
+                    (Indicate_Tested (N_Typed_Variable_Declaration));
+                  Start_Line (Indent);
+                  Output_Name (Name_Of (Node));
+                  Write_String (" : ");
+                  Output_Name (Name_Of (String_Type_Of (Node)));
+                  Write_String (" := ");
+                  Print (Expression_Of (Node), Indent);
+                  Write_Line (";");
+
+               when N_Variable_Declaration =>
+                  pragma Debug (Indicate_Tested (N_Variable_Declaration));
+                  Start_Line (Indent);
+                  Output_Name (Name_Of (Node));
+                  Write_String (" := ");
+                  Print (Expression_Of (Node), Indent);
+                  Write_Line (";");
+
+               when N_Expression =>
+                  pragma Debug (Indicate_Tested (N_Expression));
+                  declare
+                     Term : Project_Node_Id := First_Term (Node);
+
+                  begin
+                     while Term /= Empty_Node loop
+                        Print (Term, Indent);
+                        Term := Next_Term (Term);
+
+                        if Term /= Empty_Node then
+                           Write_String (" & ");
+                        end if;
+                     end loop;
+                  end;
+
+               when N_Term =>
+                  pragma Debug (Indicate_Tested (N_Term));
+                  Print (Current_Term (Node), Indent);
+
+               when N_Literal_String_List =>
+                  pragma Debug (Indicate_Tested (N_Literal_String_List));
+                  Write_String ("(");
+
+                  declare
+                     Expression : Project_Node_Id :=
+                       First_Expression_In_List (Node);
+
+                  begin
+                     while Expression /= Empty_Node loop
+                        Print (Expression, Indent);
+                        Expression := Next_Expression_In_List (Expression);
+
+                        if Expression /= Empty_Node then
+                           Write_String (", ");
+                        end if;
+                     end loop;
+                  end;
+
+                  Write_String (")");
+
+               when N_Variable_Reference =>
+                  pragma Debug (Indicate_Tested (N_Variable_Reference));
+                  if Project_Node_Of (Node) /= Empty_Node then
+                     Output_Name (Name_Of (Project_Node_Of (Node)));
+                     Write_String (".");
+                  end if;
+
+                  if Package_Node_Of (Node) /= Empty_Node then
+                     Output_Name (Name_Of (Package_Node_Of (Node)));
+                     Write_String (".");
+                  end if;
+
+                  Output_Name (Name_Of (Node));
+
+               when N_External_Value =>
+                  pragma Debug (Indicate_Tested (N_External_Value));
+                  Write_String ("external (");
+                  Print (External_Reference_Of (Node), Indent);
+
+                  if External_Default_Of (Node) /= Empty_Node then
+                     Write_String (", ");
+                     Print (External_Default_Of (Node), Indent);
+                  end if;
+
+                  Write_String (")");
+
+               when N_Attribute_Reference =>
+                  pragma Debug (Indicate_Tested (N_Attribute_Reference));
+
+                  if Project_Node_Of (Node) /= Empty_Node
+                    and then Project_Node_Of (Node) /= Project
+                  then
+                     Output_Name (Name_Of (Project_Node_Of (Node)));
+
+                     if Package_Node_Of (Node) /= Empty_Node then
+                        Write_String (".");
+                        Output_Name (Name_Of (Package_Node_Of (Node)));
+                     end if;
+
+                  elsif Package_Node_Of (Node) /= Empty_Node then
+                     Output_Name (Name_Of (Package_Node_Of (Node)));
+
+                  else
+                     Write_String ("project");
+                  end if;
+
+                  Write_String ("'");
+                  Output_Name (Name_Of (Node));
+
+                  declare
+                     Index : constant String_Id :=
+                       Associative_Array_Index_Of (Node);
+
+                  begin
+                     if Index /= No_String then
+                        Write_String (" (");
+                        Output_String (Index);
+                        Write_String (")");
+                     end if;
+                  end;
+
+               when N_Case_Construction =>
+                  pragma Debug (Indicate_Tested (N_Case_Construction));
+
+                  declare
+                     Case_Item : Project_Node_Id := First_Case_Item_Of (Node);
+                     Is_Non_Empty : Boolean := False;
+                  begin
+                     while Case_Item /= Empty_Node loop
+                        if First_Declarative_Item_Of (Case_Item) /= Empty_Node
+                          or else not Eliminate_Empty_Case_Constructions
+                        then
+                           Is_Non_Empty := True;
+                           exit;
+                        end if;
+                        Case_Item := Next_Case_Item (Case_Item);
+                     end loop;
+
+                     if Is_Non_Empty then
+                        Write_Empty_Line;
+                        Start_Line (Indent);
+                        Write_String ("case ");
+                        Print (Case_Variable_Reference_Of (Node), Indent);
+                        Write_Line (" is");
+
+                        declare
+                           Case_Item : Project_Node_Id :=
+                             First_Case_Item_Of (Node);
+
+                        begin
+                           while Case_Item /= Empty_Node loop
+                              pragma Assert
+                                (Kind_Of (Case_Item) = N_Case_Item);
+                              Print (Case_Item, Indent + Increment);
+                              Case_Item := Next_Case_Item (Case_Item);
+                           end loop;
+                        end;
+
+                        Start_Line (Indent);
+                        Write_Line ("end case;");
+                     end if;
+                  end;
+
+               when N_Case_Item =>
+                  pragma Debug (Indicate_Tested (N_Case_Item));
+
+                  if First_Declarative_Item_Of (Node) /= Empty_Node
+                    or else not Eliminate_Empty_Case_Constructions
+                  then
+                     Write_Empty_Line;
+                     Start_Line (Indent);
+                     Write_String ("when ");
+
+                     if First_Choice_Of (Node) = Empty_Node then
+                        Write_String ("others");
+
+                     else
+                        declare
+                           Label : Project_Node_Id := First_Choice_Of (Node);
+
+                        begin
+                           while Label /= Empty_Node loop
+                              Print (Label, Indent);
+                              Label := Next_Literal_String (Label);
+
+                              if Label /= Empty_Node then
+                                 Write_String (" | ");
+                              end if;
+                           end loop;
+                        end;
+                     end if;
+
+                     Write_Line (" =>");
+
+                     declare
+                        First : Project_Node_Id :=
+                          First_Declarative_Item_Of (Node);
+
+                     begin
+                        if First = Empty_Node then
+                           Write_Eol.all;
+
+                        else
+                           Print (First, Indent + Increment);
+                        end if;
+                     end;
+                  end if;
+            end case;
+         end if;
+      end Print;
+
+   begin
+      if W_Char = null then
+         Write_Char := Output.Write_Char'Access;
+      else
+         Write_Char := W_Char;
+      end if;
+
+      if W_Eol = null then
+         Write_Eol := Output.Write_Eol'Access;
+      else
+         Write_Eol := W_Eol;
+      end if;
+
+      if W_Str = null then
+         Write_Str := Output.Write_Str'Access;
+      else
+         Write_Str := W_Str;
+      end if;
+
+      Print (Project, 0);
+
+      if W_Char = null or else W_Str = null then
+         Output.Write_Eol;
+      end if;
+   end Pretty_Print;
+
+   -----------------------
+   -- Output_Statistics --
+   -----------------------
+
+   procedure Output_Statistics is
+   begin
+      Output.Write_Line ("Project_Node_Kinds not tested:");
+
+      for Kind in Project_Node_Kind loop
+         if Not_Tested (Kind) then
+            Output.Write_Str ("   ");
+            Output.Write_Line (Project_Node_Kind'Image (Kind));
+         end if;
+      end loop;
+
+      Output.Write_Eol;
+   end Output_Statistics;
+
+end Prj.PP;
diff --git a/gcc/ada/prj-pp.ads b/gcc/ada/prj-pp.ads
new file mode 100644
index 0000000..b70ff47
--- /dev/null
+++ b/gcc/ada/prj-pp.ads
@@ -0,0 +1,80 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                               P R J . P P                                --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                            $Revision$
+--                                                                          --
+--             Copyright (C) 2001 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- --
+-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+--
+--  This package is the Project File Pretty Printer.
+--  It is used to output a project file from a project file tree.
+--  It is used by gnatname to update or create project files.
+--  It is also used GLIDE2 to display project file trees.
+--  It can also be used for debugging purposes for tools that create project
+--  file trees.
+
+with Prj.Tree;
+
+package Prj.PP is
+
+   --  The following access to procedure types are used
+   --  to redirect output when calling Pretty_Print.
+
+   type Write_Char_Ap is access procedure (C : Character);
+
+   type Write_Eol_Ap  is access procedure;
+
+   type Write_Str_Ap is access procedure (S : String);
+
+   procedure Pretty_Print
+     (Project                            : Prj.Tree.Project_Node_Id;
+      Increment                          : Positive      := 3;
+      Eliminate_Empty_Case_Constructions : Boolean       := False;
+      Minimize_Empty_Lines               : Boolean       := False;
+      W_Char                             : Write_Char_Ap := null;
+      W_Eol                              : Write_Eol_Ap  := null;
+      W_Str                              : Write_Str_Ap  := null);
+   --  Output a project file, using either the default output
+   --  routines, or the ones specified by W_Char, W_Eol and W_Str.
+   --
+   --  Increment is the number of spaces for each indentation level.
+   --
+   --  W_Char, W_Eol and W_Str can be used to change the default output
+   --  procedures. The default values force the output to Standard_Output.
+   --
+   --  If Eliminate_Empty_Case_Constructions is True, then case constructions
+   --  and case items that do not include any declarations will not be output.
+   --
+   --  If Minimize_Empty_Lines is True, empty lines will be output only
+   --  after the last with clause, after the line declaring the project name,
+   --  after the last declarative item of the project and before each
+   --  package declaration. Otherwise, more empty lines are output.
+
+private
+
+   procedure Output_Statistics;
+   --  This procedure can be used after one or more calls to Pretty_Print
+   --  to display what Project_Node_Kinds have not been exercised by the
+   --  call(s) to Pretty_Print. It is used only for testing purposes.
+
+end Prj.PP;