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