----------------------------------------------------------------------
--  Translator - 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.Characters.Handling,
  Ada.Wide_Text_IO;

with   -- ASIS components
  Asis.Compilation_Units,
  Asis.Declarations,
  Asis.Elements,
  Asis.Expressions,
  Asis.Statements,
  Asis.Text;

with   -- Application specific units
  Producer,
  Translator.Processing,
  Utilities;
package body Translator is
   use Asis;
   use Compilation_Units, Elements;
   use Producer, Utilities, Dictionary;
   use Translator.Processing;

   ----------------------------------------------------------------
   --                 Internal elements                          --
   ----------------------------------------------------------------

   ----------
   -- Sort --
   ----------

   procedure Sort (Table : in out Asis.Association_List) is
      -- Sort an association list in textual order.
      -- This should be done by Asis when getting an association list with
      -- Normalized => False, however there is a bug for instanciations where
      -- this is not done.
      use Asis.Text;

      Temp : Element;
   begin
      -- This is an awful N**2 sort.
      -- Since we are typically sorting 2..5 elements, it may well be faster
      -- than any sophisticated one!

      for I in Table'Range loop
         for J in I+1 .. Table'Last loop
            if Element_Span (Table(J)).First_Line < Element_Span (Table(I)).First_Line or else
              (Element_Span (Table(J)).First_Line = Element_Span (Table(I)).First_Line and then
               Element_Span (Table(J)).First_Column < Element_Span(Table(I)).First_Column)
            then
               Temp      := Table (I);
               Table (I) := Table (J);
               Table (J) := Temp;
            end if;
         end loop;
      end loop;
   end Sort;

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

   procedure Post_Procedure
     (Element : in     Asis.Element;
      Control : in out Asis.Traverse_Control;
      State   : in out Info) is
      use Asis, Asis.Declarations, Asis.Statements;

      -- This procedure terminates the printing of the current element as we go up the tree.
      --
      -- It deals with the case where an identifier is repeated after the "end" of a construct
      -- (and must be substituted).
      -- The difficulty is that this identifier is not part of the tree, and therefore not
      -- found by the normal tree iterator.
      --
      -- It also restores the state for with/use clauses

   begin
      Control := Continue;

      case Element_Kind (Element) is
         when An_Expression =>
            case Expression_Kind (Element) is
               when A_Selected_Component =>
                  if State.Selected_Name_Depth > 0 then
                     State.Selected_Name_Depth := State.Selected_Name_Depth - 1;
                     if State.Selected_Name_Depth = 0 then
                        State.Allowed_Multiplicity := Multiple;
                     end if;
                  end if;
               when others =>
                  null;
            end case;
         when A_Declaration =>
            case Declaration_Kind (Element) is
               when
                 A_Package_Declaration         |
                 A_Generic_Package_Declaration |    -- (generic) package declarations
                 A_Procedure_Body_Declaration  |
                 A_Function_Body_Declaration   |
                 An_Entry_Body_Declaration     |
                 A_Package_Body_Declaration    |
                 A_Protected_Body_Declaration  |
                 A_Task_Body_Declaration       =>    -- Program unit bodies

                  if Declarations.Is_Name_Repeated (Element) then
                     Process_Named_Element (Element,
                                            The_Name => Names (Element) (1));
                  end if;

               when others =>
                  null;
            end case;

         when A_Definition =>
            case Definition_Kind (Element) is
               when
                 A_Task_Definition      |
                 A_Protected_Definition =>         -- Tasks and protected definitions

                  if Declarations.Is_Name_Repeated (Enclosing_Element (Element)) then
                     Process_Named_Element (Element,
                                            The_Name => Names (Enclosing_Element (Element)) (1));
                  end if;

               when others =>
                  null;
            end case;

         when A_Statement =>
            case Statement_Kind (Element) is
               when
                 A_Block_Statement      |         -- Blocks and Loops
                 A_Loop_Statement       |
                 A_While_Loop_Statement |
                 A_For_Loop_Statement   =>
                  if not Is_Nil (Statement_Identifier (Element)) then
                     Process_Named_Element (Element,
                                            The_Name => Statement_Identifier (Element));
                  end if;

               when An_Accept_Statement =>         -- Accept

                  if Statements.Is_Name_Repeated (Element) then
                     Process_Named_Element (Element,
                                            The_Name => Names (Corresponding_Entry (Element)) (1));
                  end if;
               when others =>
                  null;
            end case;

         when A_Clause =>                 ------------ Clause  ------------
            case Clause_Kind (Element) is
               when
                 A_With_Clause |
                 A_Use_Package_Clause =>
                  -- Undo what we did in the pre-procedure
                  -- (these clauses are never nested)
                  State := (Allowed_Multiplicity => Single,
                            Selected_Name_Depth  => 0);
               when others =>
                  null;
            end case;

         when others =>
            null;
      end case;

      -- We do not call Print_Up_To on a parameter association due to a A4G bug
      -- (See KLUDGE in producer.adb).
      -- Anyway, it is not necessary since all elements of the association have
      -- already been traversed up.
      if Element_Kind (Element) /= An_Association or else
        Association_Kind (Element) /= A_Parameter_Association
      then
         Print_Up_To (Element, Included => True);
      end if;

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

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

   procedure Pre_Procedure
     (Element : in     Asis.Element;
      Control : in out Asis.Traverse_Control;
      State   : in out Info) is
      use Asis.Expressions, Asis.Declarations;

      -- If the processing of the element is short enough, it is given directly in the
      -- corresponding branch of the case.
      -- Otherwise, it is processed by a subprogram in Translator.Processing.
   begin
      Control := Continue;

      case Element_Kind (Element) is
         when An_Expression =>                 ------------ Expression ------------
            case Expression_Kind (Element) is
               when An_Attribute_Reference =>
                  -- Traverse manually the left branch only, in order to avoid processing
                  -- the attribute identifier
                  Traverse (Prefix (Element), Control, State);
                  if Control /= Terminate_Immediately then
                     Control := Abandon_Children;
                  end if;

               when An_Identifier | An_Enumeration_Literal | An_Operator_Symbol | A_Selected_Component =>
                  -- Everything which is a (possibly long) name
                  -- Go do the real stuff!
                  Process_Name (Element, Control, State);

               when
                 An_And_Then_Short_Circuit |
                 An_Or_Else_Short_Circuit  =>

                  Process_Infix_Operation (Short_Circuit_Operation_Left_Expression (Element),
                                           Nil_Element,
                                           Short_Circuit_Operation_Right_Expression (Element),
                                           Control,
                                           State);

               when
                 An_In_Range_Membership_Test    |
                 A_Not_In_Range_Membership_Test =>

                  Process_Infix_Operation (Membership_Test_Expression (Element),
                                           Nil_Element,
                                           Membership_Test_Range (Element),
                                           Control,
                                           State);

               when
                 An_In_Type_Membership_Test     |
                 A_Not_In_Type_Membership_Test  =>

                  Process_Infix_Operation (Membership_Test_Expression (Element),
                                           Nil_Element,
                                           Membership_Test_Subtype_Mark (Element),
                                           Control,
                                           State);

               when A_Function_Call =>
                  if not Is_Prefix_Call (Element) then
                     -- We must explore the tree in textual order, i.e. A+B must be traversed in the
                     -- the order "A", "+", "B", while normal traversal would give "+", "A", "B".
                     -- We use the same for unary operators, although the order is correct, since we
                     -- must get rid of '"'.
                     declare
                        Params: constant Asis.Association_List := Function_Call_Parameters (Element,
                                                                                            Normalized => False);
                     begin
                        if Params'Length = 1 then
                           Process_Infix_Operation (Nil_Element,
                                                    Prefix (Element),
                                                    Params (1),
                                                    Control,
                                                    State);
                        else
                           Assert (Params'Length = 2, "Operator does not have 1 or 2 operands");

                           Process_Infix_Operation (Params (1),
                                                    Prefix (Element),
                                                    Params (2),
                                                    Control,
                                                    State);
                        end if;
                     end;
                  end if;

               when others =>
                  null;
            end case;

         when A_Defining_Name =>                            ------------ Defining Name  ------------
            case Defining_Name_Kind (Element) is
               when A_Defining_Expanded_Name =>
                  if Has_Substitution (Element, Kind => Qualified) then
                     Print_Up_To (Element, Included => False);
                     Print (Substitution (Element, Kind => Qualified));
                     Advance (Element);
                     Control := Abandon_Children;
                  end if;

               when others =>
                  -- A final (leaf) name
                  if Has_Substitution (Element) then
                     Print_Up_To (Element, Included => False);

                     -- No qualified name allowed in declaration, always replace with simple name
                     -- except for library units defining name
                     if Is_Nil (Enclosing_Element (Enclosing_Element (Element))) then
                        -- Library unit
                        Print (Substitution (Element, Kind => Short));

                     elsif Element_Kind (Enclosing_Element (Element)) = A_Statement and then
                       Statement_Kind (Enclosing_Element (Element)) in A_Loop_Statement .. A_Block_Statement
                     then
                        -- The identifier in front of a loop or block statement.
                        -- The span of Element includes the final ':', and everything between the
                        -- identifier and the ':' (we may have comments there!)
                        -- We must therefore resort to textual substitution within the original text
                        Print_Up_To (Element,
                                     Included => True,
                                     Changing => Defining_Name_Image (Element),
                                     Into     => Substitution (Element, Kind => Dictionary.Name));
                     else
                        -- Normal case
                        Print (Substitution (Element, Kind => Dictionary.Name));
                     end if;
                     Advance (Element);
                  end if;
            end case;

         when A_Declaration =>                 ------------ Declaration  ------------
            case Declaration_Kind (Element) is
               when A_Generic_Instantiation =>
                  -- Bug A4G
                  -- Unlike the documentation, elements of the association are returned
                  -- in Normalized order, not in textual order (which of course defeats
                  -- our purpose). We must therefore traverse manually.

                  Traverse (Names (Element)(1), Control, State);

                  if Control = Continue then
                     Traverse (Generic_Unit_Name (Element), Control, State);
                  end if;

                  if Control = Continue then
                     declare
                        Elements : Asis.Association_List := Generic_Actual_Part (Element);
                     begin
                        Sort (Elements);
                        for I in Elements'Range loop
                           Traverse (Elements (I), Control, State);
                           exit when Control /= Continue;
                        end loop;
                     end;
                  end if;

                  if Control /= Terminate_Immediately then
                     Control := Abandon_Children;
                  end if;

               when others =>
                  null;
            end case;


         when A_Clause =>                 ------------ Clause  ------------
            case Clause_Kind (Element) is
               when
                 A_With_Clause |
                 A_Use_Package_Clause =>
                  State := (Allowed_Multiplicity => Multiple,
                            Selected_Name_Depth  => 0);
               when others =>
                  null;
            end case;

         when others =>
            null;
      end case;

   exception
      when others =>
         Print_Up_To (Element, Included => True);
         Trace ("Exception in Pre-proc, kind of failing element: " &
                Element_Kinds'Wide_Image (Element_Kind (Element)));
         if Debug_Option then
            raise;
         else
            User_Message ("!! Internal error, continuing");
            Print (" ???? ");
            Control := Abandon_Children;
         end if;
   end Pre_Procedure;

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

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

   procedure Process (Unit_Name           : in     Wide_String;
                      Process_Spec        : in     Boolean;
                      Process_Body        : in     Boolean;
                      Print_Changed_Lines : in     Boolean;
                      Line_Length         : in     Natural;
                      Output_Prefix       : in     String;
                      Keep_Unchanged      : in     Boolean;
                      My_Context          : in out Asis.Context)
   is
      use Ada.Wide_Text_IO;
      F_Out : File_Type;

      procedure Do_Process (My_Unit : Compilation_Unit) is
         My_Declaration : Declaration;
         The_Control    : Traverse_Control := Continue;
         The_Info       : Info := (Allowed_Multiplicity => Single,
                                   Selected_Name_Depth  => 0);
         Had_Changes    : Boolean;
         use Ada.Characters.Handling;
      begin
         if Is_Nil (My_Unit) then
            Trace (Wide_String'("Nil unit"));
            return;
         end if;

         if Output_Prefix /= "" then
            Safe_Open  (F_Out,
                        Name => Output_Prefix & To_String (Text_Name (My_Unit)),
                        Mode => Create);
            Set_Output (F_Out);
         end if;

      Process_Context_Clauses :
         declare
            My_CC_List  : Context_Clause_List
              := Context_Clause_Elements (Compilation_Unit  => My_Unit,
                                          Include_Pragmas => True) ;
         begin
            for I in My_CC_List'Range loop
               Traverse (My_CC_List (I), The_Control, The_Info);
            end loop;
         end Process_Context_Clauses;


      Process_Unit :
         begin
            My_Declaration := Unit_Declaration (My_Unit);
            Traverse (My_Declaration, The_Control, The_Info);
            if The_Control /= Terminate_Immediately then
               Print_Up_To (My_Declaration, Included => True, Final => True);
            end if;
         end Process_Unit;

         Producer.Finish (Had_Changes);

         if Is_Open (F_Out) then
            Set_Output (Standard_Output);
            if Had_Changes or Keep_Unchanged then
               Close (F_Out);
            else
               Delete (F_Out);
            end if;
         end if;

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

   begin  -- Process
      Producer.Initialize (Line_Length, Print_Changed_Lines);

      if Process_Spec then
         User_Message ("Translating " & Unit_Name & " specification");
         Do_Process (Library_Unit_Declaration (Unit_Name, My_Context));
      end if;
      if Process_Body then
         User_Message ("Translating " & Unit_Name & " body");
         Do_Process (Compilation_Unit_Body (Unit_Name, My_Context));
      end if;

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

end Translator;
