VMS has a multitude of sophisticated file organizations, formats,
and attributes that are handled at the system service level (aka RMS)
Under some circumstances a file can be created that cannot be read
without the appropriate RMS key in the file open call. A mechanism is
designed for passing RMS keys and a minimal number are implemented.
Tested on x86_64-pc-linux-gnu, committed on trunk
2013-04-12 Doug Rupp <r...@adacore.com>
* s-crtl.ads (fopen, freopen): Add vms_form parameter
* i-cstrea.ads (fopen, freopen): Likewise.
* adaint.h (__gnat_fopen, __gnat_freopen): Likewise.
* adaint.c (__gnat_fopen, __gnat_freopen): Likewise.
[VMS]: Split out RMS keys and call CRTL function appropriately.
* s-fileio.adb (Form_VMS_RMS_Keys, Form_RMS_Context_Key): New
subprograms.
(Open, Reset): Call Form_VMS_RMS_Keys. Call fopen,freopen with
vms_form
* gnat_rm.texi: Document implemented RMS keys.
Index: gnat_rm.texi
===================================================================
--- gnat_rm.texi (revision 197899)
+++ gnat_rm.texi (working copy)
@@ -14261,6 +14261,25 @@
unrecognized keyword appears in a form string, it is silently ignored
and not considered invalid.
+@noindent
+For OpenVMS additional FORM string keywords are available for use with
+RMS services. The syntax is:
+
+@smallexample
+VMS_RMS_Keys=(keyword=value,@dots{},keyword=value)
+@end smallexample
+
+@noindent
+The following RMS keywords and values are currently defined:
+
+@smallexample
+Context=Force_Stream_Mode|Force_Record_Mode
+@end smallexample
+
+@noindent
+VMS RMS keys are silently ignored on non-VMS systems. On OpenVMS
+unimplented RMS keywords, values, or invalid syntax will raise Use_Error.
+
@node Direct_IO
@section Direct_IO
Index: s-crtl.ads
===================================================================
--- s-crtl.ads (revision 197899)
+++ s-crtl.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2003-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2013, 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- --
@@ -97,7 +97,8 @@
function fopen
(filename : chars;
mode : chars;
- encoding : Filename_Encoding := Unspecified) return FILEs;
+ encoding : Filename_Encoding := Unspecified;
+ vms_form : chars := System.Null_Address) return FILEs;
pragma Import (C, fopen, "__gnat_fopen");
function fputc (C : int; stream : FILEs) return int;
@@ -113,7 +114,8 @@
(filename : chars;
mode : chars;
stream : FILEs;
- encoding : Filename_Encoding := Unspecified) return FILEs;
+ encoding : Filename_Encoding := Unspecified;
+ vms_form : chars := System.Null_Address) return FILEs;
pragma Import (C, freopen, "__gnat_freopen");
function fseek
Index: i-cstrea.ads
===================================================================
--- i-cstrea.ads (revision 197899)
+++ i-cstrea.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2013, 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- --
@@ -107,8 +107,8 @@
function fopen
(filename : chars;
mode : chars;
- encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8)
- return FILEs
+ encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8;
+ vms_form : chars := System.Null_Address) return FILEs
renames System.CRTL.fopen;
-- Note: to maintain target independence, use text_translation_required,
-- a boolean variable defined in sysdep.c to deal with the target
@@ -144,8 +144,8 @@
(filename : chars;
mode : chars;
stream : FILEs;
- encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8)
- return FILEs
+ encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8;
+ vms_form : chars := System.Null_Address) return FILEs
renames System.CRTL.freopen;
function fseek
Index: adaint.c
===================================================================
--- adaint.c (revision 197899)
+++ adaint.c (working copy)
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2012, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2013, 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- *
@@ -213,6 +213,8 @@
#define SYI$_ACTIVECPU_CNT 0x111e
extern int LIB$GETSYI (int *, unsigned int *);
+extern unsigned int LIB$CALLG_64
+ ( unsigned long long argument_list [], int (*user_procedure)(void));
#else
#include <utime.h>
@@ -820,7 +822,8 @@
}
FILE *
-__gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED)
+__gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED,
+ char *vms_form ATTRIBUTE_UNUSED)
{
#if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
TCHAR wpath[GNAT_MAX_PATH_LEN];
@@ -837,7 +840,37 @@
return _tfopen (wpath, wmode);
#elif defined (VMS)
- return decc$fopen (path, mode);
+ if (vms_form == 0)
+ return decc$fopen (path, mode);
+ else
+ {
+ char *local_form = (char *) alloca (strlen (vms_form) + 1);
+ /* Allocate an argument list of guaranteed ample length. */
+ unsigned long long *arg_list =
+ (unsigned long long *) alloca (strlen (vms_form) + 3);
+ char *ptrb, *ptre;
+ int i;
+
+ arg_list [1] = (unsigned long long) path;
+ arg_list [2] = (unsigned long long) mode;
+ strcpy (local_form, vms_form);
+
+ /* Given a string such as "\"rfm=udf\",\"rat=cr\""
+ Split it into an argument list as "rfm=udf","rat=cr". */
+ ptrb = local_form;
+ for (i = 0; *ptrb; i++)
+ {
+ ptrb = strchr (ptrb, '"');
+ ptre = strchr (ptrb + 1, '"');
+ *ptre = 0;
+ arg_list [i + 3] = (unsigned long long) (ptrb + 1);
+ ptrb = ptre + 1;
+ }
+ arg_list [0] = i + 2;
+ /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
+ always a 32bit pointer. */
+ return LIB$CALLG_64 (arg_list, &decc$fopen);
+ }
#else
return GNAT_FOPEN (path, mode);
#endif
@@ -847,7 +880,8 @@
__gnat_freopen (char *path,
char *mode,
FILE *stream,
- int encoding ATTRIBUTE_UNUSED)
+ int encoding ATTRIBUTE_UNUSED,
+ char *vms_form ATTRIBUTE_UNUSED)
{
#if defined (_WIN32) && ! defined (__vxworks) && ! defined (IS_CROSS)
TCHAR wpath[GNAT_MAX_PATH_LEN];
@@ -864,7 +898,38 @@
return _tfreopen (wpath, wmode, stream);
#elif defined (VMS)
- return decc$freopen (path, mode, stream);
+ if (vms_form == 0)
+ return decc$freopen (path, mode, stream);
+ else
+ {
+ char *local_form = (char *) alloca (strlen (vms_form) + 1);
+ /* Allocate an argument list of guaranteed ample length. */
+ unsigned long long *arg_list =
+ (unsigned long long *) alloca (strlen (vms_form) + 4);
+ char *ptrb, *ptre;
+ int i;
+
+ arg_list [1] = (unsigned long long) path;
+ arg_list [2] = (unsigned long long) mode;
+ arg_list [3] = (unsigned long long) stream;
+ strcpy (local_form, vms_form);
+
+ /* Given a string such as "\"rfm=udf\",\"rat=cr\""
+ Split it into an argument list as "rfm=udf","rat=cr". */
+ ptrb = local_form;
+ for (i = 0; *ptrb; i++)
+ {
+ ptrb = strchr (ptrb, '"');
+ ptre = strchr (ptrb + 1, '"');
+ *ptre = 0;
+ arg_list [i + 4] = (unsigned long long) (ptrb + 1);
+ ptrb = ptre + 1;
+ }
+ arg_list [0] = i + 3;
+ /* CALLG_64 returns int , fortunately (FILE *) on VMS is a
+ always a 32bit pointer. */
+ return LIB$CALLG_64 (arg_list, &decc$freopen);
+ }
#else
return freopen (path, mode, stream);
#endif
Index: adaint.h
===================================================================
--- adaint.h (revision 197899)
+++ adaint.h (working copy)
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2012, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2013, 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- *
@@ -128,9 +128,10 @@
extern int __gnat_chdir (char *);
extern int __gnat_rmdir (char *);
-extern FILE *__gnat_fopen (char *, char *, int);
+extern FILE *__gnat_fopen (char *, char *, int,
+ char *);
extern FILE *__gnat_freopen (char *, char *, FILE *,
- int);
+ int, char *);
extern int __gnat_open_read (char *, int);
extern int __gnat_open_rw (char *, int);
extern int __gnat_open_create (char *, int);
Index: s-fileio.adb
===================================================================
--- s-fileio.adb (revision 197899)
+++ s-fileio.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, 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- --
@@ -52,6 +52,11 @@
use type Interfaces.C.int;
use type CRTL.size_t;
+ subtype String_Access is System.OS_Lib.String_Access;
+ procedure Free (X : in out String_Access) renames System.OS_Lib.Free;
+ function "=" (X, Y : String_Access) return Boolean
+ renames System.OS_Lib."=";
+
----------------------
-- Global Variables --
----------------------
@@ -98,6 +103,9 @@
(C, text_translation_required, "__gnat_text_translation_required");
-- If true, add appropriate suffix to control string for Open
+ VMS_Formstr : String_Access := null;
+ -- For special VMS RMS keywords and values.
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -132,11 +140,20 @@
-- with Name includes that file name in the message.
procedure Raise_Device_Error
- (File : AFCB_Ptr; Errno : Integer := OS_Lib.Errno);
+ (File : AFCB_Ptr;
+ Errno : Integer := OS_Lib.Errno);
pragma No_Return (Raise_Device_Error);
-- Clear error indication on File and raise Device_Error with an exception
-- message providing errno information.
+ procedure Form_VMS_RMS_Keys (Form : String; VMS_Form : out String_Access);
+ -- Parse the RMS Keys
+
+ function Form_RMS_Context_Key
+ (Form : String;
+ VMS_Form : String_Access) return Natural;
+ -- Parse the RMS Context Key
+
----------------
-- Append_Set --
----------------
@@ -640,6 +657,191 @@
Stop := 0;
end Form_Parameter;
+ --------------------------
+ -- Form_RMS_Context_Key --
+ --------------------------
+
+ function Form_RMS_Context_Key
+ (Form : String;
+ VMS_Form : String_Access) return Natural
+ is
+ type Context_Parms is
+ (Binary_Data, Convert_Fortran_Carriage_Control, Force_Record_Mode,
+ Force_Stream_Mode, Explicit_Write);
+ -- Ada-fied list of all possible Context keyword values.
+
+ Pos : Natural := 0;
+ Klen : Natural := 0;
+ Index : Natural;
+
+ begin
+ -- Find the end of the occupation
+
+ for J in VMS_Form'First .. VMS_Form'Last loop
+ if VMS_Form (J) = ASCII.NUL then
+ Pos := J;
+ exit;
+ end if;
+ end loop;
+
+ Index := Form'First;
+ while Index < Form'Last loop
+ if Form (Index) = '=' then
+ Index := Index + 1;
+
+ -- Loop through the context values and look for a match
+
+ for Parm in Context_Parms loop
+ declare
+ KImage : String := Context_Parms'Image (Parm);
+
+ begin
+ Klen := KImage'Length;
+ To_Lower (KImage);
+
+ if Form (Index .. Index + Klen - 1) = KImage then
+ case Parm is
+ when Force_Record_Mode =>
+ VMS_Form (Pos) := '"';
+ Pos := Pos + 1;
+ VMS_Form (Pos .. Pos + 7) := "ctx=rec";
+ Pos := Pos + 7;
+ VMS_Form (Pos) := '"';
+ Pos := Pos + 1;
+ VMS_Form (Pos) := ',';
+ return Index + Klen;
+
+ when Force_Stream_Mode =>
+ VMS_Form (Pos) := '"';
+ Pos := Pos + 1;
+ VMS_Form (Pos .. Pos + 7) := "ctx=stm";
+ Pos := Pos + 7;
+ VMS_Form (Pos) := '"';
+ Pos := Pos + 1;
+ VMS_Form (Pos) := ',';
+ return Index + Klen;
+
+ when others =>
+ raise Use_Error
+ with "unimplemented RMS Context Value";
+ end case;
+ end if;
+ end;
+ end loop;
+
+ raise Use_Error with "unrecognized RMS Context Value";
+ end if;
+ end loop;
+
+ raise Use_Error with "malformed RMS Context Value";
+ end Form_RMS_Context_Key;
+
+ -----------------------
+ -- Form_VMS_RMS_Keys --
+ -----------------------
+
+ procedure Form_VMS_RMS_Keys (Form : String; VMS_Form : out String_Access)
+ is
+ VMS_RMS_Keys_Token : constant String := "vms_rms_keys";
+ Klen : Natural := VMS_RMS_Keys_Token'Length;
+ Index : Natural;
+
+ -- Ada-fied list of all RMS keywords, translated from the
+ -- HP C Run-Time Library Reference Manual, Table REF-3:
+ -- RMS Valid Keywords and Values
+
+ type RMS_Keys is
+ (Access_Callback, Allocation_Quantity, Block_Size, Context,
+ Default_Extension_Quantity, Default_File_Name_String, Error_Callback,
+ File_Processing_Options, Fixed_Header_Size, Global_Buffer_Count,
+ Multiblock_Count, Multibuffer_Count, Maximum_Record_Size,
+ Terminal_Input_Prompt, Record_Attributes, Record_Format,
+ Record_Processing_Options, Retrieval_Pointer_Count, Sharing_Options,
+ Timeout_IO_Value);
+
+ begin
+ Index := Form'First + Klen - 1;
+ while Index < Form'Last loop
+ Index := Index + 1;
+
+ -- Scan for the token signalling VMS RMS Keys ahead. Should
+ -- whitespace be eaten???
+
+ if Form (Index - Klen .. Index - 1) = VMS_RMS_Keys_Token then
+
+ -- Allocate the VMS form string that will contain the cryptic
+ -- CRTL RMS strings and initialize it to all nulls. Since the
+ -- CRTL strings are always shorter than the Ada-fied strings,
+ -- it follows that an allocation of the original size will be
+ -- more than adequate.
+ VMS_Form := new String'(Form (Form'First .. Form'Last));
+ VMS_Form.all := (others => ASCII.NUL);
+
+ if Form (Index) = '=' then
+ Index := Index + 1;
+ if Form (Index) = '(' then
+ while Index < Form'Last loop
+ Index := Index + 1;
+
+ -- Loop through the RMS Keys and dispatch.
+
+ for Key in RMS_Keys loop
+ declare
+ KImage : String := RMS_Keys'Image (Key);
+ begin
+ Klen := KImage'Length;
+ To_Lower (KImage);
+ if Form (Index .. Index + Klen - 1) = KImage then
+ case Key is
+
+ when Context =>
+ Index := Form_RMS_Context_Key
+ (Form (Index + Klen .. Form'Last),
+ VMS_Form);
+ exit;
+
+ when others =>
+ raise Use_Error
+ with "unimplemented VMS RMS Form Key";
+ end case;
+ end if;
+ end;
+ end loop;
+
+ if Form (Index) = ')' then
+
+ -- Done, erase the unneeded trailing comma and
+ -- return.
+
+ for J in reverse VMS_Form'First .. VMS_Form'Last loop
+ if VMS_Form (J) = ',' then
+ VMS_Form (J) := ASCII.NUL;
+ return;
+ end if;
+ end loop;
+
+ -- Shouldn't be possible to get here
+ raise Use_Error;
+
+ elsif Form (Index) = ',' then
+
+ -- Another key ahead, exit inner loop
+ null;
+ else
+
+ -- Keyword value not terminated correctly
+ raise Use_Error with "malformed VMS RMS Form";
+ end if;
+ end loop;
+ end if;
+ end if;
+
+ -- Found the keyword, but not followed by correct syntax
+ raise Use_Error with "malformed VMS RMS Form";
+ end if;
+ end loop;
+ end Form_VMS_RMS_Keys;
+
-------------
-- Is_Open --
-------------
@@ -868,6 +1070,17 @@
Form_Boolean (Formstr, "text_translation", Default => True);
end if;
+ -- Acquire settings of target specific form parameters on VMS. Only
+ -- Context is currently implemented, for forcing a byte stream mode
+ -- read. On non-VMS systems, the settings are ultimately ignored in
+ -- the implementation of __gnat_fopen.
+
+ -- Should a warning be issued on non-VMS systems? That's not possible
+ -- without testing System.OpenVMS boolean which isn't present in most
+ -- non-VMS versions of package System.
+
+ Form_VMS_RMS_Keys (Formstr, VMS_Formstr);
+
-- If we were given a stream (call from xxx.C_Streams.Open), then set
-- the full name to the given one, and skip to end of processing.
@@ -1030,8 +1243,20 @@
-- since by the time of the delete, the current working directory
-- may have changed and we do not want to delete a different file!
- Stream := fopen (Namestr'Address, Fopstr'Address, Encoding);
+ if VMS_Formstr = null then
+ Stream := fopen (Namestr'Address, Fopstr'Address, Encoding,
+ Null_Address);
+ else
+ Stream := fopen (Namestr'Address, Fopstr'Address, Encoding,
+ VMS_Formstr.all'Address);
+ end if;
+ -- No need to keep this around
+
+ if VMS_Formstr /= null then
+ Free (VMS_Formstr);
+ end if;
+
if Stream = NULL_Stream then
-- Raise Name_Error if trying to open a non-existent file.
@@ -1042,15 +1267,15 @@
declare
function Is_File_Not_Found_Error
(Errno_Value : Integer) return Integer;
- -- Non-zero when the given errno value indicates a non-
- -- existing file.
-
pragma Import
(C, Is_File_Not_Found_Error,
"__gnat_is_file_not_found_error");
+ -- Non-zero when the given errno value indicates a non-
+ -- existing file.
- Errno : constant Integer := OS_Lib.Errno;
+ Errno : constant Integer := OS_Lib.Errno;
Message : constant String := Errno_Message (Name, Errno);
+
begin
if Is_File_Not_Found_Error (Errno) /= 0 then
raise Name_Error with Message;
@@ -1196,9 +1421,22 @@
Fopen_Mode
(Mode, File.Is_Text_File, False, File.Access_Method, Fopstr);
- File.Stream := freopen
- (File.Name.all'Address, Fopstr'Address, File.Stream, File.Encoding);
+ Form_VMS_RMS_Keys (File.Form.all, VMS_Formstr);
+ if VMS_Formstr = null then
+ File.Stream := freopen
+ (File.Name.all'Address, Fopstr'Address, File.Stream,
+ File.Encoding, Null_Address);
+ else
+ File.Stream := freopen
+ (File.Name.all'Address, Fopstr'Address, File.Stream,
+ File.Encoding, VMS_Formstr.all'Address);
+ end if;
+
+ if VMS_Formstr /= null then
+ Free (VMS_Formstr);
+ end if;
+
if File.Stream = NULL_Stream then
Close (File_Ptr);
raise Use_Error;
