+2013-04-12 Robert Dewar <dewar@adacore.com>
+
+ * opt.ads (Style_Check_Main): New switch.
+ * sem.adb (Semantics): Set Style_Check flag properly for new
+ unit to be analyzed.
+ * sem_ch10.adb (Analyze_With_Clause): Don't reset Style_Check,
+ the proper setting of this flag is now part of the Semantics
+ procedure.
+ * switch-c.adb (Scan_Front_End_Switches): Set Style_Check_Main
+ for -gnatg and -gnaty
+
+2013-04-12 Doug Rupp <rupp@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.
+
2013-04-12 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications):
* *
* 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- *
#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>
}
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];
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
__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];
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
* *
* 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- *
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);
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
-- --
-- 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- --
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
(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
-- GNAT
-- Set True to perform style checks. Activates checks carried out in
-- package Style (see body of this package for details of checks). This
- -- flag is set True by either the -gnatg or -gnaty switches.
+ -- flag is set True by use of either the -gnatg or -gnaty switches, or
+ -- by the Style_Check pragma.
+
+ Style_Check_Main : Boolean := False;
+ -- GNAT
+ -- Set True if Style_Check was set for the main unit. This is used to
+ -- renable style checks for units in the mail extended source that get
+ -- with'ed indirectly. It is set on by use of either the -gnatg or -gnaty
+ -- switches, but not by use of the Style_Checks pragma.
Suppress_All_Inlining : Boolean := False;
-- GNAT
-- --
-- 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- --
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;
(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
-- --
-- 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- --
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 --
----------------------
(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 --
-----------------------
-- 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 --
----------------
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 --
-------------
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.
-- 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
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;
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);
S_In_Spec_Expr : constant Boolean := In_Spec_Expression;
S_Inside_A_Generic : constant Boolean := Inside_A_Generic;
S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope;
+ S_Style_Check : constant Boolean := Style_Check;
Generic_Main : constant Boolean :=
Nkind (Unit (Cunit (Main_Unit)))
-- If the main unit is generic, every compiled unit, including its
-- context, is compiled with expansion disabled.
+ Ext_Main_Source_Unit : constant Boolean :=
+ In_Extended_Main_Source_Unit (Comp_Unit);
+ -- Determine if unit is in extended main source unit
+
Save_Config_Switches : Config_Switches_Type;
-- Variable used to save values of config switches while we analyze the
-- new unit, to be restored on exit for proper recursive behavior.
-- Sequential_IO) as this would prevent pragma Extend_System from being
-- taken into account, for example when Text_IO is renaming DEC.Text_IO.
- -- Cleaner might be to do the kludge at the point of excluding the
- -- pragma (do not exclude for renamings ???)
-
if Is_Predefined_File_Name
(Unit_File_Name (Current_Sem_Unit), Renamings_Included => False)
then
-- For unit in main extended unit, we reset the configuration values
-- for the non-partition-wide restrictions. For other units reset them.
- if In_Extended_Main_Source_Unit (Comp_Unit) then
+ if Ext_Main_Source_Unit then
Restore_Config_Cunit_Boolean_Restrictions;
else
Reset_Cunit_Boolean_Restrictions;
end if;
+ -- Turn off style checks for unit that is not in the extended main
+ -- source unit. This improves processing efficiency for such units
+ -- (for which we don't want style checks anyway, and where they will
+ -- get suppressed), and is definitely needed to stop some style checks
+ -- from invading the run-time units (e.g. overriding checks).
+
+ if not Ext_Main_Source_Unit then
+ Style_Check := False;
+
+ -- If this is part of the extended main source unit, set style check
+ -- mode to match the style check mode of the main source unit itself.
+
+ else
+ Style_Check := Style_Check_Main;
+ end if;
+
-- Only do analysis of unit that has not already been analyzed
if not Analyzed (Comp_Unit) then
In_Spec_Expression := S_In_Spec_Expr;
Inside_A_Generic := S_Inside_A_Generic;
Outer_Generic_Scope := S_Outer_Gen_Scope;
+ Style_Check := S_Style_Check;
Restore_Opt_Config_Switches (Save_Config_Switches);
return;
end if;
- -- We reset ordinary style checking during the analysis of a with'ed
- -- unit, but we do NOT reset GNAT special analysis mode (the latter
- -- definitely *does* apply to with'ed units).
-
- if not GNAT_Mode then
- Style_Check := False;
- end if;
-
-- If the library unit is a predefined unit, and we are in high
-- integrity mode, then temporarily reset Configurable_Run_Time_Mode
-- for the analysis of the with'ed unit. This mode does not prevent
Identifier_Character_Set := 'n';
System_Extend_Unit := Empty;
Warning_Mode := Treat_As_Error;
+ Style_Check_Main := True;
-- Set Ada 2012 mode explicitly. We don't want to rely on the
-- implicit setting here, since for example, we want
when 'y' =>
Ptr := Ptr + 1;
+ Style_Check_Main := True;
if Ptr > Max then
Set_Default_Style_Check_Options;
OSDN Git Service
