gcc/ada/dec-io.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME COMPONENTS                          --
   4 --                                                                          --
   5 --                               D E C . I O                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                                                                          --
  10 --            Copyright (C) 2001 Free Software Foundation, Inc.             --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 --  This is an AlphaVMS package that provides the interface between
  36 --  GNAT, DECLib IO packages and the DECLib Bliss library.
  37
  38 pragma Extend_System (Aux_DEC);
  39
  40 with System;                            use  System;
  41 with System.Task_Primitives;            use  System.Task_Primitives;
  42 with System.Task_Primitives.Operations; use  System.Task_Primitives.Operations;
  43 with IO_Exceptions;                     use  IO_Exceptions;
  44 with Aux_IO_Exceptions;                 use  Aux_IO_Exceptions;
  45
  46 package body DEC.IO is
  47
  48    type File_Type is record
  49       FCB : Integer   := 0;   -- Temporary
  50       SEQ : Integer   := 0;
  51    end record;
  52
  53    for File_Type'Size use 64;
  54    for File_Type'Alignment use 8;
  55
  56    for File_Type use record
  57       FCB at 0 range 0 .. 31;
  58       SEQ at 4 range 0 .. 31;
  59    end record;
  60
  61    -----------------------
  62    -- Local Subprograms --
  63    -----------------------
  64
  65    function GNAT_Name_64 (File : File_Type) return String;
  66    pragma Export_Function (GNAT_Name_64, "GNAT$NAME_64");
  67    --  ??? comment
  68
  69    function GNAT_Form_64 (File : File_Type) return String;
  70    pragma Export_Function (GNAT_Form_64, "GNAT$FORM_64");
  71    --  ??? comment
  72
  73    procedure Init_IO;
  74    pragma Interface (C, Init_IO);
  75    pragma Import_Procedure (Init_IO, "GNAT$$INIT_IO");
  76    --  ??? comment
  77
  78    ----------------
  79    -- IO_Locking --
  80    ----------------
  81
  82    package body IO_Locking is
  83
  84       ------------------
  85       -- Create_Mutex --
  86       ------------------
  87
  88       function Create_Mutex return Access_Mutex is
  89          M : constant Access_Mutex := new RTS_Lock;
  90
  91       begin
  92          Initialize_Lock (M, Global_Task_Level);
  93          return M;
  94       end Create_Mutex;
  95
  96       -------------
  97       -- Acquire --
  98       -------------
  99
 100       procedure Acquire (M : Access_Mutex) is
 101       begin
 102          Write_Lock (M);
 103       end Acquire;
 104
 105       -------------
 106       -- Release --
 107       -------------
 108
 109       procedure Release (M : Access_Mutex) is
 110       begin
 111          Unlock (M);
 112       end Release;
 113
 114    end IO_Locking;
 115
 116    ------------------
 117    -- GNAT_Name_64 --
 118    ------------------
 119
 120    function GNAT_Name_64 (File : File_Type) return String is
 121       subtype Buffer_Subtype is String (1 .. 8192);
 122
 123       Buffer : Buffer_Subtype;
 124       Length : System.Integer_32;
 125
 126       procedure Get_Name
 127         (File    : System.Address;
 128          MaxLen  : System.Integer_32;
 129          Buffer  : out Buffer_Subtype;
 130          Length  : out System.Integer_32);
 131       pragma Interface (C, Get_Name);
 132       pragma Import_Procedure
 133         (Get_Name, "GNAT$FILE_NAME",
 134          Mechanism => (Value, Value, Reference, Reference));
 135
 136    begin
 137       Get_Name (File'Address, Buffer'Length, Buffer, Length);
 138       return Buffer (1 .. Integer (Length));
 139    end GNAT_Name_64;
 140
 141    ------------------
 142    -- GNAT_Form_64 --
 143    ------------------
 144
 145    function GNAT_Form_64 (File : File_Type) return String is
 146       subtype Buffer_Subtype is String (1 .. 8192);
 147
 148       Buffer : Buffer_Subtype;
 149       Length : System.Integer_32;
 150
 151       procedure Get_Form
 152         (File    : System.Address;
 153          MaxLen  : System.Integer_32;
 154          Buffer  : out Buffer_Subtype;
 155          Length  : out System.Integer_32);
 156       pragma Interface (C, Get_Form);
 157       pragma Import_Procedure
 158         (Get_Form, "GNAT$FILE_FORM",
 159          Mechanism => (Value, Value, Reference, Reference));
 160
 161    begin
 162       Get_Form (File'Address, Buffer'Length, Buffer, Length);
 163       return Buffer (1 .. Integer (Length));
 164    end GNAT_Form_64;
 165
 166    ------------------------
 167    -- Raise_IO_Exception --
 168    ------------------------
 169
 170    procedure Raise_IO_Exception (EN : Exception_Number) is
 171    begin
 172       case EN is
 173          when GNAT_EN_LOCK_ERROR =>      raise LOCK_ERROR;
 174          when GNAT_EN_EXISTENCE_ERROR => raise EXISTENCE_ERROR;
 175          when GNAT_EN_KEY_ERROR =>       raise KEY_ERROR;
 176          when GNAT_EN_KEYSIZERR =>       raise PROGRAM_ERROR; -- KEYSIZERR;
 177          when GNAT_EN_STAOVF =>          raise STORAGE_ERROR; -- STAOVF;
 178          when GNAT_EN_CONSTRAINT_ERRO => raise CONSTRAINT_ERROR;
 179          when GNAT_EN_IOSYSFAILED =>     raise DEVICE_ERROR;  -- IOSYSFAILED;
 180          when GNAT_EN_LAYOUT_ERROR =>    raise LAYOUT_ERROR;
 181          when GNAT_EN_STORAGE_ERROR =>   raise STORAGE_ERROR;
 182          when GNAT_EN_DATA_ERROR =>      raise DATA_ERROR;
 183          when GNAT_EN_DEVICE_ERROR =>    raise DEVICE_ERROR;
 184          when GNAT_EN_END_ERROR =>       raise END_ERROR;
 185          when GNAT_EN_MODE_ERROR =>      raise MODE_ERROR;
 186          when GNAT_EN_NAME_ERROR =>      raise NAME_ERROR;
 187          when GNAT_EN_STATUS_ERROR =>    raise STATUS_ERROR;
 188          when GNAT_EN_NOT_OPEN =>        raise USE_ERROR;   -- NOT_OPEN;
 189          when GNAT_EN_ALREADY_OPEN =>    raise USE_ERROR;   -- ALREADY_OPEN;
 190          when GNAT_EN_USE_ERROR =>       raise USE_ERROR;
 191          when GNAT_EN_UNSUPPORTED =>     raise USE_ERROR;   -- UNSUPPORTED;
 192          when GNAT_EN_FAC_MODE_MISMAT => raise USE_ERROR;   -- FAC_MODE_MISMAT;
 193          when GNAT_EN_ORG_MISMATCH =>    raise USE_ERROR;   -- ORG_MISMATCH;
 194          when GNAT_EN_RFM_MISMATCH =>    raise USE_ERROR;   -- RFM_MISMATCH;
 195          when GNAT_EN_RAT_MISMATCH =>    raise USE_ERROR;   -- RAT_MISMATCH;
 196          when GNAT_EN_MRS_MISMATCH =>    raise USE_ERROR;   -- MRS_MISMATCH;
 197          when GNAT_EN_MRN_MISMATCH =>    raise USE_ERROR;   -- MRN_MISMATCH;
 198          when GNAT_EN_KEY_MISMATCH =>    raise USE_ERROR;   -- KEY_MISMATCH;
 199          when GNAT_EN_MAXLINEXC =>       raise CONSTRAINT_ERROR; -- MAXLINEXC;
 200          when GNAT_EN_LINEXCMRS =>       raise CONSTRAINT_ERROR; -- LINEXCMRS;
 201       end case;
 202    end Raise_IO_Exception;
 203
 204 -------------------------
 205 -- Package Elaboration --
 206 -------------------------
 207
 208 begin
 209    Init_IO;
 210 end DEC.IO;