File : asis-ada_environments.adb


------------------------------------------------------------------------------
--                                                                          --
--                 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-1999, 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,  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.                                      --
--                                                                          --
-- 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  Ada Core Technologies Inc --
-- (http://www.gnat.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.Exceptions;         use Asis.Exceptions;
with Asis.Errors;             use Asis.Errors;

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.Vcheck;              use A4G.Vcheck;
with A4G.Contt;               use A4G.Contt;
with A4G.A_Output;            use A4G.A_Output;
with A4G.Contt.UT;            use A4G.Contt.UT;
with A4G.Contt.TT;            use A4G.Contt.TT;

with Output;                  use Output;

package body Asis.Ada_Environments is

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

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

      if Is_Opened (Cont) then
         Set_Error_Status (Status    => Value_Error,
                           Diagnosis => "Asis.Ada_Environments.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;

      Pre_Initialize (Cont);

      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 =>
         raise;
      when ASIS_Failed =>
         if not (Status_Indicator = Errors.Parameter_Error) then
            Add_Call_Information (Outer_Call =>
              "Asis.Ada_Environments.Associate");
         end if;
         raise;
      when others =>
         Raise_ASIS_Failed (Diagnosis => "Asis.Ada_Environments.Associate");
   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 => "Asis.Ada_Environments.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);

   exception
      when ASIS_Inappropriate_Context =>
         raise;
      when ASIS_Failed =>
         Set_Current_Cont (Nil_Context_Id);
         Add_Call_Information (Outer_Call =>
                     "Asis.Ada_Environments.Close");
         raise;
      when others =>
         Set_Current_Cont (Nil_Context_Id);
         Raise_ASIS_Failed (Diagnosis =>
                     "Asis.Ada_Environments.Close");
   end Close;

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

   function Debug_Image
     (The_Context : in Asis.Context)
       return Wide_String
   is
      LT : Wide_String renames A4G.A_Types.Asis_Wide_Line_Terminator;
   begin
      return LT & "Context Debug_Image: " &
             LT & "Context Id is" &
             Context_Id'Wide_Image (Get_Cont_Id (The_Context)) &
             LT & To_Wide_String (Debug_String (The_Context));
   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 => "Asis.Ada_Environments.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 =>
         Add_Call_Information (Outer_Call =>
           "Asis.Ada_Environments.Dissociate");
         raise;
      when others =>
         Raise_ASIS_Failed (Diagnosis => "Asis.Ada_Environments.Dissociate");
   end Dissociate;

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

   function Exists (The_Context : in 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 : in 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  : in Asis.Context;
                      Right : in 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  : in Asis.Context;
                          Right : in 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 : in 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 : in 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_Work_Mode : Context_Mode;
      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 => "Asis.Ada_Environments.Open: " &
                           "the Context dos not have association");
         raise ASIS_Inappropriate_Context;
      elsif Is_Opened (Cont) then
         Set_Error_Status (Status    => Value_Error,
                           Diagnosis => "Asis.Ada_Environments.Open: " &
                           "the Context has already been opened");
         raise ASIS_Inappropriate_Context;
      end if;
      Reset_Context (Cont);

      Context_Work_Mode := Context_Processing_Mode (Cont);

      Increase_ASIS_OS_Time;

      Pre_Initialize (Cont);
      A4G.Contt.Initialize (Cont);

      Context_Tree_Mode := Tree_Processing_Mode (Cont);

      case Context_Tree_Mode is
         when Pre_Created | Mixed =>
            Scan_Trees_New (Cont);
         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_Current_Cont (Nil_Context_Id);
         raise;
      when others =>
         Set_Current_Cont (Nil_Context_Id);
         Raise_ASIS_Failed (Diagnosis => "Asis.Ada_Environments.Open");
   end Open;

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

   function Parameters (The_Context : in 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