----------------------------------------------------------------------
--  Utilities - 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,
  Ada.Strings.Wide_Maps.Wide_Constants;

with  -- Standard Ada units
  Ada.Exceptions,
  Ada.Characters.Handling;
with  -- ASIS units
  Asis.Errors, Asis.Implementation;
package body Utilities is

   ----------------
   -- Asis_Error --
   ----------------

   procedure Asis_Error (Occur : Ada.Exceptions.Exception_Occurrence) is
      use Ada.Exceptions, Ada.Characters.Handling, Asis.Errors, Asis.Implementation;
   begin
      User_Message ("FAILURE !!!");
      User_Message ("Exception: " & To_Wide_String (Exception_Name (Occur)));
      User_Message ("Status   : " & Error_Kinds'Wide_Image (Status));
      User_Message ("Diagnosis: " & Diagnosis);
      Reraise_Occurrence (Occur);
   end Asis_Error;

   ------------
   -- Assert --
   ------------

   procedure Assert (Condition : Boolean; Message : String) is
   begin
      if not Condition then
         Failure (Message);
      end if;
   end Assert;

   -------------
   -- Failure --
   -------------

   procedure Failure (Message : String) is
      use Ada.Exceptions;
   begin
      Raise_Exception (Program_Error'Identity, Message);
   end Failure;

   --------------
   -- User_Log --
   --------------

   procedure User_Log (Message : Wide_String) is
      use Ada.Wide_Text_IO;
   begin
      if Verbose_Option then
        User_Message (Message);
      end if;
   end User_Log;

   ------------------
   -- User_Message --
   ------------------

   procedure User_Message (Message : Wide_String) is
      use Ada.Wide_Text_IO;
      Old_Col : Count;
   begin

      if Error_Is_Out then
         Old_Col := Col (Current_Output);
         Set_Col (Current_Output, 1);
      end if;

      Put_Line (Current_Error, Message);

      if Error_Is_Out then
         Set_Col (Current_Output, Old_Col);
      end if;
   end User_Message;

   ---------------
   -- Safe_Open --
   ---------------

   procedure Safe_Open (File : in out Ada.Wide_Text_IO.File_Type;
                        Name : String;
                        Mode : Open_Mode)
   is
      use Ada.Wide_Text_IO, Ada.Characters.Handling;
   begin
      if Overwrite_Option then
         Create (File, Out_File, Name);
         Trace ("Creating output " & To_Wide_String (Name));

         case Mode is
            when Create =>
               null;
            when Append =>
               -- Further open must not overwrite the file
               Overwrite_Option := False;
         end case;

      else
         begin
            case Mode is
               when Create =>
                  Open (File, Out_File, Name);

                  -- File exists
                  Close (File);
                  User_Message ("File " &
                                To_Wide_String (Name) &
                                " already exists, use -w to overwrite");
                  raise Overwrite_Error;
               when Append =>
                  Open (File, Append_File, Name);
                  -- OK if file exists
                  Trace ("Appending output to " & To_Wide_String (Name));
            end case;

         exception
            when Name_Error =>
               -- File does not exist (either mode)
               Create (File, Out_File, Name);
               Trace ("Creating output " & To_Wide_String (Name));
         end;
      end if;
   exception
      when Occur : others =>
         declare
            use Ada.Exceptions;
         begin
            Raise_Exception (Exception_Identity (Occur),
                             Message => "Error opening " & Name &
                                        ' ' & Open_Mode'Image (Mode));
         end;
   end Safe_Open;

   --------------
   -- To_Upper --
   --------------

   function To_Upper (Item : in Wide_String) return Wide_String is
      use Ada.Strings.Wide_Maps, Ada.Strings.Wide_Maps.Wide_Constants;

      Result : Wide_String (1 .. Item'Length);
   begin
      for J in Item'Range loop
         Result (J - (Item'First - 1)) := Value (Upper_Case_Map, Item (J));
      end loop;

      return Result;
   end To_Upper;

   ------------
   -- Trace  --
   ------------

   procedure Trace (Message : Wide_String) is
      use Ada.Wide_Text_IO;
   begin
      if Debug_Option then
         Put (Current_Error, "<<");
         Put (Current_Error, Message);
         Put_Line (Current_Error, ">>");
      end if;
   end Trace;

end Utilities;

