------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                A S I S . A D A _ E N V I R O N M E N T S                 --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 1995-2008, Free Software Foundation, Inc.       --
--                                                                          --
-- ASIS-for-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 --
-- Software Foundation;  either version 2,  or  (at your option)  any later --
-- version. ASIS-for-GNAT is distributed  in the hope  that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY  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 ASIS-for-GNAT; see   file --
-- COPYING.  If not,  write  to the  Free Software Foundation,  51 Franklin --
-- Street, Fifth Floor, Boston, MA 02110-1301, 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.                                      --
--                                                                          --
-- ASIS-for-GNAT was originally developed  by the ASIS-for-GNAT team at the --
-- Software  Engineering  Laboratory  of  the Swiss  Federal  Institute  of --
-- Technology (LGL-EPFL) in Lausanne,  Switzerland, in cooperation with the --
-- Scientific  Research  Computer  Center of  Moscow State University (SRCC --
-- MSU), Russia,  with funding partially provided  by grants from the Swiss --
-- National  Science  Foundation  and  the  Swiss  Academy  of  Engineering --
-- Sciences. ASIS-for-GNAT is now maintained by AdaCore                     --
-- (http://www.adaccore.com).                                               --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Strings;             use Ada.Strings;
with Ada.Strings.Fixed;       use Ada.Strings.Fixed;

with Asis.Errors;             use Asis.Errors;
with Asis.Exceptions;         use Asis.Exceptions;

with Asis.Set_Get;            use Asis.Set_Get;

with A4G.A_Debug;             use A4G.A_Debug;
with A4G.A_Opt;               use A4G.A_Opt;
with A4G.A_Output;            use A4G.A_Output;
with A4G.Contt;               use A4G.Contt;
with A4G.Contt.TT;            use A4G.Contt.TT;
with A4G.Contt.UT;            use A4G.Contt.UT;
with A4G.Vcheck;              use A4G.Vcheck;

with Output;                  use Output;

package body Asis.Ada_Environments is

   Package_Name : constant String := "Asis.Ada_Environments.";

   ---------------
   -- Associate --
   ---------------

   procedure Associate
     (The_Context : in out Asis.Context;
      Name        :        Wide_String;
      Parameters  :        Wide_String := Default_Parameters)
   is
      S_Parameters : constant String := Trim (To_String (Parameters), Both);
      Cont         :          Context_Id;
   begin

      Cont := Get_Cont_Id (The_Context);

      if not A4G.A_Opt.Is_Initialized then

         Set_Error_Status
           (Status    => Initialization_Error,
            Diagnosis => Package_Name & "Associate: "
                       & "called for non-initialized ASIS");

         raise ASIS_Failed;

      end if;

      if Is_Opened (Cont) then
         Set_Error_Status
           (Status    => Value_Error,
            Diagnosis => Package_Name & "Associate: "
                       & "the Context has already been opened");
         raise ASIS_Inappropriate_Context;
      end if;

      if Cont = Non_Associated then
         --  this is the first association for a given Context
         Cont := Allocate_New_Context;
         Set_Cont (The_Context, Cont);
      else
         Erase_Old (Cont);
      end if;

      Verify_Context_Name (To_String (Name), Cont);
      Process_Context_Parameters (S_Parameters, Cont);

      Set_Is_Associated (Cont, True);

      Save_Context (Cont);
      Set_Current_Cont (Nil_Context_Id);

   exception
      when ASIS_Inappropriate_Context =>
         Set_Is_Associated (Cont, False);
         raise;
      when ASIS_Failed =>
         Set_Is_Associated (Cont, False);

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information (Outer_Call => Package_Name & "Associate");
         end if;

         raise;
      when Ex : others =>
         Set_Is_Associated (Cont, False);

         Report_ASIS_Bug
           (Query_Name => Package_Name & "Associate",
            Ex         => Ex);
   end Associate;

   -----------
   -- Close --
   -----------

   procedure Close (The_Context : in out Asis.Context) is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      Reset_Context (Cont);

      if not Is_Opened (Cont) then
         Set_Error_Status (Status    => Value_Error,
                           Diagnosis => Package_Name & "Close: " &
                           "the Context is not open");
         raise ASIS_Inappropriate_Context;
      end if;

      if Debug_Flag_C    or else
         Debug_Lib_Model or else
         Debug_Mode
      then
         Write_Str ("Closing Context ");
         Write_Int (Int (Cont));
         Write_Eol;
         Print_Units (Cont);
         Print_Trees (Cont);
      end if;

      Set_Is_Opened (Cont, False);

      Set_Current_Cont (Nil_Context_Id);

      Reset_Cache;

   exception
      when ASIS_Inappropriate_Context =>
         raise;
      when ASIS_Failed =>
         Set_Current_Cont (Nil_Context_Id);

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information (Outer_Call => Package_Name &  "Close");
         end if;

         raise;
      when Ex : others =>
         Set_Current_Cont (Nil_Context_Id);
         Report_ASIS_Bug
           (Query_Name => Package_Name & "Associate",
            Ex         => Ex);
   end Close;

   -----------------
   -- Debug_Image --
   -----------------

   function Debug_Image
     (The_Context : Asis.Context)
      return        Wide_String
   is
      Arg_Cont : Context_Id;
      LT       : Wide_String renames A4G.A_Types.Asis_Wide_Line_Terminator;
   begin
      Arg_Cont := Get_Cont_Id (The_Context);
      Reset_Context (Arg_Cont);

      return LT & "Context Debug_Image: " &
             LT & "Context Id is" &
             Context_Id'Wide_Image (Arg_Cont) &
             LT & To_Wide_String (Debug_String (The_Context));
   exception
      when Ex : others =>
         Report_ASIS_Bug
          (Query_Name => Package_Name & "Debug_Image",
           Ex         => Ex);
   end Debug_Image;

   ------------------
   -- Default_Name --
   ------------------

   function Default_Name return Wide_String is
   begin
      return Nil_Asis_Wide_String;
   end Default_Name;

   ------------------------
   -- Default_Parameters --
   ------------------------

   function Default_Parameters return Wide_String is
   begin
      return Nil_Asis_Wide_String;
   end Default_Parameters;

   ----------------
   -- Dissociate --
   ----------------

   procedure Dissociate (The_Context : in out Asis.Context) is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);

      if Is_Opened (Cont) then
         Set_Error_Status (Status    => Value_Error,
                           Diagnosis => Package_Name & "Dissociate: "
                                      & "the Context is open");
         raise ASIS_Inappropriate_Context;
      end if;

      if Debug_Flag_C    or else
         Debug_Lib_Model or else
         Debug_Mode
      then
         Write_Str ("Dissociating Context ");
         Write_Int (Int (Cont));
         Write_Eol;
         Print_Context_Parameters (Cont);
      end if;

      if Is_Associated (Cont) then
         Erase_Old (Cont);
         Set_Is_Associated (Cont, False);
      end if;

   exception
      when ASIS_Inappropriate_Context =>
         raise;
      when ASIS_Failed =>

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information (Outer_Call => Package_Name & "Dissociate");
         end if;

         raise;
      when Ex : others =>
         Report_ASIS_Bug
           (Query_Name => Package_Name & "Dissociate",
            Ex         => Ex);
   end Dissociate;

   ------------
   -- Exists --
   ------------

   function Exists (The_Context : Asis.Context) return Boolean is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      return Is_Associated (Cont);
   end Exists;

   ----------------------
   -- Has_Associations --
   ----------------------

   function Has_Associations
     (The_Context : Asis.Context)
      return        Boolean
   is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      return Is_Associated (Cont);
   end Has_Associations;

   --------------
   -- Is_Equal --
   --------------

   function Is_Equal
     (Left  : Asis.Context;
      Right : Asis.Context)
      return  Boolean
   is
   begin
      return Get_Cont_Id (Left) = Get_Cont_Id (Right);
      --  Should be revised
   end Is_Equal;

   ------------------
   -- Is_Identical --
   ------------------

   function Is_Identical
     (Left  : Asis.Context;
      Right : Asis.Context)
      return  Boolean
   is
   begin
      return Get_Cont_Id (Left) = Get_Cont_Id (Right);
   end Is_Identical;

   -------------
   -- Is_Open --
   -------------

   function Is_Open (The_Context : Asis.Context) return Boolean is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      return Is_Opened (Cont);
   end Is_Open;

   ----------
   -- Name --
   ----------

   function Name (The_Context : Asis.Context) return Wide_String is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      return  To_Wide_String (Get_Context_Name (Cont));
   end Name;

   ----------
   -- Open --
   ----------

   procedure Open (The_Context : in out Asis.Context) is
      Cont              : Context_Id;
      Context_Tree_Mode : Tree_Mode;
   begin
      Cont := Get_Cont_Id (The_Context);

      if not Is_Associated (Cont) then
         Set_Error_Status (Status    => Value_Error,
                           Diagnosis => Package_Name & "Open: " &
                           "the Context does not have association");
         raise ASIS_Inappropriate_Context;
      elsif Is_Opened (Cont) then
         Set_Error_Status (Status    => Value_Error,
                           Diagnosis => Package_Name & "Open: " &
                           "the Context has already been opened");
         raise ASIS_Inappropriate_Context;
      end if;

      Reset_Context (Cont);
      Context_Tree_Mode := Tree_Processing_Mode (Cont);

      if Tree_Processing_Mode (Cont) = GNSA then
         Set_Error_Status (Status    => Use_Error,
                           Diagnosis => Package_Name & "Open: " &
                           "GNSA Context mode is not allowed");
         raise ASIS_Inappropriate_Context;
      end if;

      Increase_ASIS_OS_Time;

      Pre_Initialize (Cont);
      A4G.Contt.Initialize (Cont);
      --  Having these two Pre_Initialize and A4G.Contt.Initialize calling
      --  one after another is a kind of junk, but there are some problems
      --  with multi-context processing which have not been completely
      --  detected and which does not allow to get rid of this definitely
      --  redundunt "initialization"

      case Context_Tree_Mode is
         when Pre_Created | Mixed =>
            Scan_Trees_New (Cont);

         when Incremental =>

            --  Not the best approach, unfortunately
            begin
               Scan_Trees_New (Cont);
            exception
               when Inconsistent_Incremental_Context =>
                  --  Setting empty incremental context:
                  Pre_Initialize (Cont);
                  A4G.Contt.Initialize (Cont);
            end;

         when others =>
            null;
      end case;

      Set_Is_Opened (Cont, True);

      Save_Context (Cont);

      Set_Current_Cont (Nil_Context_Id);

   exception
      when Program_Error =>
         raise;
      when ASIS_Inappropriate_Context =>
         raise;
      when ASIS_Failed =>
         Set_Is_Opened (Cont, False);
         Set_Current_Cont (Nil_Context_Id);

         if Status_Indicator = Unhandled_Exception_Error then
            Add_Call_Information (Outer_Call => Package_Name & "Open");
         end if;

         raise;
      when Ex : others =>
         Set_Is_Opened (Cont, False);
         Set_Current_Cont (Nil_Context_Id);

         Report_ASIS_Bug
           (Query_Name => Package_Name & "Open",
            Ex         => Ex);
   end Open;

   ----------------
   -- Parameters --
   ----------------

   function Parameters (The_Context : Asis.Context) return Wide_String is
      Cont : Context_Id;
   begin
      Cont := Get_Cont_Id (The_Context);
      return  To_Wide_String (Get_Context_Parameters (Cont));
   end Parameters;

end Asis.Ada_Environments;
