----------------------------------------------------------------------
--  Preparator - Package body                                       --
--  Copyright (C) 2002 Adalog                                       --
--  Author: J-P. Rosen                                              --
--                                                                  --
--  ADALOG   is   providing   training,   consultancy,   expertise, --
--  assistance and custom developments  in Ada and related software --
--  engineering techniques.  For more info about our services:      --
--  ADALOG                   Tel: +33 1 41 24 31 40                 --
--  19-21 rue du 8 mai 1945  Fax: +33 1 41 24 07 36                 --
--  94110 ARCUEIL            E-m: info@adalog.fr                    --
--  FRANCE                   URL: http://www.adalog.fr              --
--                                                                  --
--  This  unit is  free software;  you can  redistribute  it and/or --
--  modify  it under  terms of  the GNU  General Public  License as --
--  published by the Free Software Foundation; either version 2, or --
--  (at your  option) any later version.  This  unit is distributed --
--  in the hope  that it will be useful,  but WITHOUT 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 this program; see file --
--  COPYING.   If not, write  to the  Free Software  Foundation, 59 --
--  Temple Place - Suite 330, Boston, MA 02111-1307, USA.           --
--                                                                  --
--  As  a special  exception, if  other files  instantiate generics --
--  from  this unit,  or you  link this  unit with  other  files to --
--  produce an executable,  this unit does not by  itself cause the --
--  resulting executable  to be covered  by the GNU  General Public --
--  License.  This exception does  not however invalidate any other --
--  reasons why  the executable  file might be  covered by  the GNU --
--  Public License.                                                 --
----------------------------------------------------------------------

with   -- Standard Ada units
  Ada.Strings.Wide_Fixed,
  Ada.Wide_Text_IO;

with   -- ASIS components
  Asis.Compilation_Units,
  Asis.Declarations,
  Asis.Definitions,
  Asis.Elements,
  Asis.Iterator;
pragma Elaborate_All (Asis.Iterator);

with   -- Application specific units
  Thick_Queries,
  Utilities;
package body Preparator is
   use Asis;
   use Compilation_Units, Elements;
   use Utilities;
   ----------------------------------------------------------------
   --                 Internal elements                          --
   ----------------------------------------------------------------

   ----------------------
   -- Global constants --
   ----------------------

   Dict_Column_Pos : constant := 35;

   ------------------
   -- Global types --
   ------------------

   type Info is null record;

   --------------
   -- Traverse --
   --------------

   procedure Pre_Procedure
     (Element : in     Asis.Element;
      Control : in out Asis.Traverse_Control;
      State   : in out Info);
   procedure Post_Procedure
     (Element : in     Asis.Element;
      Control : in out Asis.Traverse_Control;
      State   : in out Info);
   procedure Traverse is new Asis.Iterator.Traverse_Element
     (Info, Pre_Procedure, Post_Procedure);

   --------------------
   -- Post_Procedure --
   --------------------

   procedure Post_Procedure
     (Element : in     Asis.Element;
      Control : in out Asis.Traverse_Control;
      State   : in out Info) is
   begin
      null;
   end Post_Procedure;

   -------------------
   -- Pre_Procedure --
   -------------------

   procedure Pre_Procedure
     (Element : in     Asis.Element;
      Control : in out Asis.Traverse_Control;
      State   : in out Info) is
      use Ada.Wide_Text_Io;
      use Asis.Declarations, Asis.Definitions, Asis.Elements;
      use Thick_Queries;

      function Adjust_Image (Original : Wide_String) return Wide_String is
         -- We use the same syntax as Profile_Image for profiles, except that:
         --   we use "return" rather than ":" for the return type of functions.
         --   we use "access" rather than "*" for access parameters
         -- This function makes the necessary transformation
         use Ada.Strings.Wide_Fixed;

         Pos   : Natural;
         Start : Natural;
      begin
         Pos := Index (Original, ":");
         if Pos = 0 then
            -- Find a real * meaning "access", discard the "*" and "**" operators
            Start := Original'First;
            loop
               Pos := Index (Original (Start .. Original'Last), "*");

               if Pos = 0 then
                  -- No * found
                  return Original;

               elsif Original (Pos+1) = '"' then
                 -- "*" operator
                 Start := Pos+2;

               elsif Original (Pos+1) = '*' then
                 -- "**" operator
                 Start := Pos+3;

               else
                  -- Real access parameter
                  exit;
               end if;
            end loop;

            return
              Original (Original'First..Pos - 1) &
              " access " &
              Adjust_Image (Original (Pos + 1 .. Original'Last));

         else
            return
              Adjust_Image (Original (Original'First..Pos - 1)) &
              " return " &
              Adjust_Image (Original (Pos + 1 .. Original'Last));
         end if;
      end Adjust_Image;

      The_Declaration : Asis.Element;
   begin
      Control := Continue;

      case Element_Kind (Element) is
         when A_Defining_Name =>                 ------------ Defining Name  ------------
            The_Declaration := Enclosing_Element (Element);
            -- If it is the declaration of an enumeration literal, go up to the declaration
            -- of the enumerated type
            if Declaration_Kind (The_Declaration) = An_Enumeration_Literal_Specification then
               The_Declaration := Enclosing_Element (Enclosing_Element (The_Declaration));
            end if;

            Put (Adjust_Image (Full_Name_Image (Element, With_Profile  => True)));
            if Col < Dict_Column_Pos then
               Set_Col (Dict_Column_Pos);
            else
               Put (' ');
            end if;
            Put ("=> ");
            Put (Defining_Name_Image (Element));
            New_Line;

         when A_Declaration =>
            case Declaration_Kind (Element) is
               when                     ------------ (generic) package: process only visible part ------------
                 A_Package_Declaration |
                 A_Generic_Package_Declaration =>
                  declare
                     DI_List : Declarative_Item_List := Visible_Part_Declarative_Items (Element,
                                                                                        Include_Pragmas => True);
                  begin
                     for I in DI_List'Range loop
                        Traverse (DI_List (I), Control, State);
                     end loop;
                     Control := Abandon_Children;
                  end;
               when others =>
                  null;
            end case;

         when A_Definition =>
            case Definition_Kind (Element) is
               when                      ------------ task or protected: process only visible part ------------
                 A_Task_Definition |
                 A_Protected_Definition =>
                  declare
                     DI_List : Declarative_Item_List := Visible_Part_Items (Element,
                                                                            Include_Pragmas => True);
                  begin
                     for I in DI_List'Range loop
                        Traverse (DI_List (I), Control, State);
                     end loop;
                     Control := Abandon_Children;
                  end;
               when others =>
                  null;
            end case;

         when others =>
            null;
      end case;

   exception
      when others =>
         Trace ("Exception in Pre-proc, kind of failing element: " &
                Element_Kinds'Wide_Image (Element_Kind (Element)));
         raise;
   end Pre_Procedure;

   ----------------------------------------------------------------
   --                 Exported subprograms                       --
   ----------------------------------------------------------------

   -------------
   -- Process --
   -------------

   procedure Process (Unit_Name   : in     Wide_String;
                      Output_Name : in     String;
                      My_Context  : in out Asis.Context)
   is
      use Ada.Wide_Text_IO;
      F_Out : File_Type;

      procedure Do_Process (My_Unit : Compilation_Unit) is
         The_Control    : Traverse_Control := Continue;
         The_Info       : Info;
      begin
         case Unit_Kind (My_Unit) is
            when A_Package | A_Generic_Package =>
               null;
            when others =>
               -- Ignore
               Trace ("Ignoring " & Unit_Name & " (" & Unit_Kinds'Wide_Image (Unit_Kind (My_Unit)) &')');
               return;
         end case;
         Put_Line ("#");
         Put_Line ("# Elements declared in package " & Unit_Name);
         Put_Line ("#");

      Process_Unit :
         declare
            use Asis.Declarations;
            DI_List : Declarative_Item_List := Visible_Part_Declarative_Items (Unit_Declaration (My_Unit),
                                                                               Include_Pragmas => True);
         begin
            for I in DI_List'Range loop
               Traverse (DI_List (I), The_Control, The_Info);
            end loop;
         end Process_Unit;

      end Do_Process;

   begin  -- Process
      Trace ("Preparing " & Unit_Name);

      if Output_Name /= "" then
         Safe_Open  (F_Out, Name => Output_Name, Mode => Append);
         Set_Output (F_Out);
      end if;

      Do_Process (Library_Unit_Declaration (Unit_Name, My_Context));

      if Is_Open (F_Out) then
         Set_Output (Standard_Output);
         Close (F_Out);
      end if;
   exception
      when others =>
         if Is_Open (F_Out) then
            Set_Output (Standard_Output);
            Close (F_Out);
         end if;
         raise;
   end Process;

end Preparator;
