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