mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-04-05 13:51:00 +08:00
[multiple changes]
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. From-SVN: r197902
This commit is contained in:
Arnaud Charlet
parent
0c68c6135f
commit
7f18b29a17
@ -1,3 +1,27 @@
|
||||
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):
|
||||
|
||||
@ -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 @@ struct vstring
|
||||
|
||||
#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 @@ __gnat_rmdir (char *path)
|
||||
}
|
||||
|
||||
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 @@ __gnat_fopen (char *path, char *mode, int encoding ATTRIBUTE_UNUSED)
|
||||
|
||||
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 @@ FILE *
|
||||
__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 @@ __gnat_freopen (char *path,
|
||||
|
||||
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
|
||||
|
||||
@ -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_rename (char *, char *);
|
||||
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);
|
||||
|
||||
@ -14261,6 +14261,25 @@ The use of these parameters is described later in this section. If an
|
||||
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
|
||||
|
||||
|
||||
@ -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 @@ package Interfaces.C_Streams is
|
||||
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 @@ package Interfaces.C_Streams is
|
||||
(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
|
||||
|
||||
@ -1267,7 +1267,15 @@ package Opt is
|
||||
-- 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
|
||||
|
||||
@ -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 @@ package System.CRTL is
|
||||
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 @@ package System.CRTL is
|
||||
(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
|
||||
|
||||
@ -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 @@ package body System.File_IO is
|
||||
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 @@ package body System.File_IO is
|
||||
(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 @@ package body System.File_IO is
|
||||
-- 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 @@ package body System.File_IO is
|
||||
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 @@ package body System.File_IO is
|
||||
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,7 +1243,19 @@ package body System.File_IO is
|
||||
-- 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
|
||||
|
||||
@ -1042,15 +1267,15 @@ package body System.File_IO is
|
||||
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,8 +1421,21 @@ package body System.File_IO is
|
||||
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);
|
||||
|
||||
@ -1311,6 +1311,7 @@ package body Sem is
|
||||
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)))
|
||||
@ -1318,6 +1319,10 @@ package body Sem is
|
||||
-- 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.
|
||||
@ -1386,9 +1391,6 @@ package body Sem is
|
||||
-- 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
|
||||
@ -1423,12 +1425,28 @@ package body Sem is
|
||||
-- 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
|
||||
@ -1482,6 +1500,7 @@ package body Sem is
|
||||
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);
|
||||
|
||||
|
||||
@ -2457,14 +2457,6 @@ package body Sem_Ch10 is
|
||||
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
|
||||
|
||||
@ -751,6 +751,7 @@ package body Switch.C is
|
||||
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
|
||||
@ -1173,6 +1174,7 @@ package body Switch.C is
|
||||
|
||||
when 'y' =>
|
||||
Ptr := Ptr + 1;
|
||||
Style_Check_Main := True;
|
||||
|
||||
if Ptr > Max then
|
||||
Set_Default_Style_Check_Options;
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user