| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT RUNTIME COMPONENTS -- |
| -- -- |
| -- D E C . I O -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- $Revision: 1.2 $ |
| -- -- |
| -- 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. -- |
| -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| -- 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; |
