------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUNTIME COMPONENTS                          --
--                                                                          --
--                               D E C . I O                                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 2001 Free Software Foundation, Inc.             --
--                                                                          --
-- 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 Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT 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 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.                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  This is an AlphaVMS package that provides the interface between
--  GNAT, DECLib IO packages and the DECLib Bliss library.

pragma Extend_System (Aux_DEC);

with System;                            use  System;
with System.Task_Primitives;            use  System.Task_Primitives;
with System.Task_Primitives.Operations; use  System.Task_Primitives.Operations;
with IO_Exceptions;                     use  IO_Exceptions;
with Aux_IO_Exceptions;                 use  Aux_IO_Exceptions;

package body DEC.IO is

   type File_Type is record
      FCB : Integer   := 0;   -- Temporary
      SEQ : Integer   := 0;
   end record;

   for File_Type'Size use 64;
   for File_Type'Alignment use 8;

   for File_Type use record
      FCB at 0 range 0 .. 31;
      SEQ at 4 range 0 .. 31;
   end record;

   -----------------------
   -- Local Subprograms --
   -----------------------

   function GNAT_Name_64 (File : File_Type) return String;
   pragma Export_Function (GNAT_Name_64, "GNAT$NAME_64");
   --  ??? comment

   function GNAT_Form_64 (File : File_Type) return String;
   pragma Export_Function (GNAT_Form_64, "GNAT$FORM_64");
   --  ??? comment

   procedure Init_IO;
   pragma Interface (C, Init_IO);
   pragma Import_Procedure (Init_IO, "GNAT$$INIT_IO");
   --  ??? comment

   ----------------
   -- IO_Locking --
   ----------------

   package body IO_Locking is

      ------------------
      -- Create_Mutex --
      ------------------

      function Create_Mutex return Access_Mutex is
         M : constant Access_Mutex := new RTS_Lock;

      begin
         Initialize_Lock (M, Global_Task_Level);
         return M;
      end Create_Mutex;

      -------------
      -- Acquire --
      -------------

      procedure Acquire (M : Access_Mutex) is
      begin
         Write_Lock (M);
      end Acquire;

      -------------
      -- Release --
      -------------

      procedure Release (M : Access_Mutex) is
      begin
         Unlock (M);
      end Release;

   end IO_Locking;

   ------------------
   -- GNAT_Name_64 --
   ------------------

   function GNAT_Name_64 (File : File_Type) return String is
      subtype Buffer_Subtype is String (1 .. 8192);

      Buffer : Buffer_Subtype;
      Length : System.Integer_32;

      procedure Get_Name
        (File    : System.Address;
         MaxLen  : System.Integer_32;
         Buffer  : out Buffer_Subtype;
         Length  : out System.Integer_32);
      pragma Interface (C, Get_Name);
      pragma Import_Procedure
        (Get_Name, "GNAT$FILE_NAME",
         Mechanism => (Value, Value, Reference, Reference));

   begin
      Get_Name (File'Address, Buffer'Length, Buffer, Length);
      return Buffer (1 .. Integer (Length));
   end GNAT_Name_64;

   ------------------
   -- GNAT_Form_64 --
   ------------------

   function GNAT_Form_64 (File : File_Type) return String is
      subtype Buffer_Subtype is String (1 .. 8192);

      Buffer : Buffer_Subtype;
      Length : System.Integer_32;

      procedure Get_Form
        (File    : System.Address;
         MaxLen  : System.Integer_32;
         Buffer  : out Buffer_Subtype;
         Length  : out System.Integer_32);
      pragma Interface (C, Get_Form);
      pragma Import_Procedure
        (Get_Form, "GNAT$FILE_FORM",
         Mechanism => (Value, Value, Reference, Reference));

   begin
      Get_Form (File'Address, Buffer'Length, Buffer, Length);
      return Buffer (1 .. Integer (Length));
   end GNAT_Form_64;

   ------------------------
   -- Raise_IO_Exception --
   ------------------------

   procedure Raise_IO_Exception (EN : Exception_Number) is
   begin
      case EN is
         when GNAT_EN_LOCK_ERROR =>      raise LOCK_ERROR;
         when GNAT_EN_EXISTENCE_ERROR => raise EXISTENCE_ERROR;
         when GNAT_EN_KEY_ERROR =>       raise KEY_ERROR;
         when GNAT_EN_KEYSIZERR =>       raise PROGRAM_ERROR; -- KEYSIZERR;
         when GNAT_EN_STAOVF =>          raise STORAGE_ERROR; -- STAOVF;
         when GNAT_EN_CONSTRAINT_ERRO => raise CONSTRAINT_ERROR;
         when GNAT_EN_IOSYSFAILED =>     raise DEVICE_ERROR;  -- IOSYSFAILED;
         when GNAT_EN_LAYOUT_ERROR =>    raise LAYOUT_ERROR;
         when GNAT_EN_STORAGE_ERROR =>   raise STORAGE_ERROR;
         when GNAT_EN_DATA_ERROR =>      raise DATA_ERROR;
         when GNAT_EN_DEVICE_ERROR =>    raise DEVICE_ERROR;
         when GNAT_EN_END_ERROR =>       raise END_ERROR;
         when GNAT_EN_MODE_ERROR =>      raise MODE_ERROR;
         when GNAT_EN_NAME_ERROR =>      raise NAME_ERROR;
         when GNAT_EN_STATUS_ERROR =>    raise STATUS_ERROR;
         when GNAT_EN_NOT_OPEN =>        raise USE_ERROR;   -- NOT_OPEN;
         when GNAT_EN_ALREADY_OPEN =>    raise USE_ERROR;   -- ALREADY_OPEN;
         when GNAT_EN_USE_ERROR =>       raise USE_ERROR;
         when GNAT_EN_UNSUPPORTED =>     raise USE_ERROR;   -- UNSUPPORTED;
         when GNAT_EN_FAC_MODE_MISMAT => raise USE_ERROR;   -- FAC_MODE_MISMAT;
         when GNAT_EN_ORG_MISMATCH =>    raise USE_ERROR;   -- ORG_MISMATCH;
         when GNAT_EN_RFM_MISMATCH =>    raise USE_ERROR;   -- RFM_MISMATCH;
         when GNAT_EN_RAT_MISMATCH =>    raise USE_ERROR;   -- RAT_MISMATCH;
         when GNAT_EN_MRS_MISMATCH =>    raise USE_ERROR;   -- MRS_MISMATCH;
         when GNAT_EN_MRN_MISMATCH =>    raise USE_ERROR;   -- MRN_MISMATCH;
         when GNAT_EN_KEY_MISMATCH =>    raise USE_ERROR;   -- KEY_MISMATCH;
         when GNAT_EN_MAXLINEXC =>       raise CONSTRAINT_ERROR; -- MAXLINEXC;
         when GNAT_EN_LINEXCMRS =>       raise CONSTRAINT_ERROR; -- LINEXCMRS;
      end case;
   end Raise_IO_Exception;

-------------------------
-- Package Elaboration --
-------------------------

begin
   Init_IO;
end DEC.IO;