mirror of
git://gcc.gnu.org/git/gcc.git
synced 2025-04-10 18:20:51 +08:00
snames.ads-tmpl, [...]: Remove VMS-specific code.
2014-08-01 Robert Dewar <dewar@adacore.com> * snames.ads-tmpl, s-os_lib.adb, s-os_lib.ads, s-fileio.adb: Remove VMS-specific code. * prj-conf.adb: Minor reformatting. * xr_tabls.adb (Read_File): Restore code which was enabled on non VMS platforms before. * prj-env.adb (Initialize_Default_Project_Path): Ditto. * sem_ch5.adb: Minor reformatting. * lib-writ.adb, lib-writ.ads, bindgen.adb, sem_vfpt.adb, sem_vfpt.ads, ali.adb, ali.ads, opt.ads, bcheck.adb, exp_strm.adb: Remove VMS-specific code. From-SVN: r213432
This commit is contained in:
Robert Dewar
Arnaud Charlet
parent
7a5b62b0c7
commit
78f8727c3a
@ -1,3 +1,16 @@
|
||||
2014-08-01 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* snames.ads-tmpl, s-os_lib.adb, s-os_lib.ads, s-fileio.adb: Remove
|
||||
VMS-specific code.
|
||||
* prj-conf.adb: Minor reformatting.
|
||||
* xr_tabls.adb (Read_File): Restore code which was enabled on
|
||||
non VMS platforms before.
|
||||
* prj-env.adb (Initialize_Default_Project_Path): Ditto.
|
||||
* sem_ch5.adb: Minor reformatting.
|
||||
* lib-writ.adb, lib-writ.ads, bindgen.adb, sem_vfpt.adb,
|
||||
sem_vfpt.ads, ali.adb, ali.ads, opt.ads, bcheck.adb, exp_strm.adb:
|
||||
Remove VMS-specific code.
|
||||
|
||||
2014-08-01 Vincent Celier <celier@adacore.com>
|
||||
|
||||
* make.adb (Await_Compile): Remove loop that was only needed
|
||||
|
||||
@ -108,7 +108,6 @@ package body ALI is
|
||||
-- ALI files that are read for a given processing run in gnatbind.
|
||||
|
||||
Dynamic_Elaboration_Checks_Specified := False;
|
||||
Float_Format_Specified := ' ';
|
||||
Locking_Policy_Specified := ' ';
|
||||
No_Normalize_Scalars_Specified := False;
|
||||
No_Object_Specified := False;
|
||||
@ -876,7 +875,6 @@ package body ALI is
|
||||
First_Sdep => No_Sdep_Id,
|
||||
First_Specific_Dispatching => Specific_Dispatching.Last + 1,
|
||||
First_Unit => No_Unit_Id,
|
||||
Float_Format => 'I',
|
||||
Last_Interrupt_State => Interrupt_States.Last,
|
||||
Last_Sdep => No_Sdep_Id,
|
||||
Last_Specific_Dispatching => Specific_Dispatching.Last,
|
||||
@ -1091,12 +1089,6 @@ package body ALI is
|
||||
ALIs.Table (Id).Partition_Elaboration_Policy :=
|
||||
Partition_Elaboration_Policy_Specified;
|
||||
|
||||
-- Processing for FD/FG/FI
|
||||
|
||||
elsif C = 'F' then
|
||||
Float_Format_Specified := Getc;
|
||||
ALIs.Table (Id).Float_Format := Float_Format_Specified;
|
||||
|
||||
-- Processing for Lx
|
||||
|
||||
elsif C = 'L' then
|
||||
|
||||
@ -176,10 +176,6 @@ package ALI is
|
||||
-- always be set as well in this case. Not set if 'P' appears in
|
||||
-- Ignore_Lines.
|
||||
|
||||
Float_Format : Character;
|
||||
-- Set to float format (set to I if no float-format given). Not set if
|
||||
-- 'P' appears in Ignore_Lines.
|
||||
|
||||
No_Object : Boolean;
|
||||
-- Set to True if no object file generated. Not set if 'P' appears in
|
||||
-- Ignore_Lines.
|
||||
@ -469,11 +465,6 @@ package ALI is
|
||||
-- Set to False by Initialize_ALI. Set to True if Scan_ALI reads
|
||||
-- a unit for which dynamic elaboration checking is enabled.
|
||||
|
||||
Float_Format_Specified : Character := ' ';
|
||||
-- Set to blank by Initialize_ALI. Set to appropriate float format
|
||||
-- character (V or I, see Opt.Float_Format) if an ali file that
|
||||
-- is read contains an F line setting the floating point format.
|
||||
|
||||
Initialize_Scalars_Used : Boolean := False;
|
||||
-- Set True if an ali file contains the Initialize_Scalars flag
|
||||
|
||||
|
||||
@ -47,7 +47,6 @@ package body Bcheck is
|
||||
|
||||
procedure Check_Consistent_Dispatching_Policy;
|
||||
procedure Check_Consistent_Dynamic_Elaboration_Checking;
|
||||
procedure Check_Consistent_Floating_Point_Format;
|
||||
procedure Check_Consistent_Interrupt_States;
|
||||
procedure Check_Consistent_Locking_Policy;
|
||||
procedure Check_Consistent_Normalize_Scalars;
|
||||
@ -73,10 +72,6 @@ package body Bcheck is
|
||||
|
||||
procedure Check_Configuration_Consistency is
|
||||
begin
|
||||
if Float_Format_Specified /= ' ' then
|
||||
Check_Consistent_Floating_Point_Format;
|
||||
end if;
|
||||
|
||||
if Queuing_Policy_Specified /= ' ' then
|
||||
Check_Consistent_Queuing_Policy;
|
||||
end if;
|
||||
@ -526,41 +521,6 @@ package body Bcheck is
|
||||
end if;
|
||||
end Check_Consistent_Dynamic_Elaboration_Checking;
|
||||
|
||||
--------------------------------------------
|
||||
-- Check_Consistent_Floating_Point_Format --
|
||||
--------------------------------------------
|
||||
|
||||
-- The rule is that all files must be compiled with the same setting
|
||||
-- for the floating-point format.
|
||||
|
||||
procedure Check_Consistent_Floating_Point_Format is
|
||||
begin
|
||||
-- First search for a unit specifying a floating-point format and then
|
||||
-- check all remaining units against it.
|
||||
|
||||
Find_Format : for A1 in ALIs.First .. ALIs.Last loop
|
||||
if ALIs.Table (A1).Float_Format /= ' ' then
|
||||
Check_Format : declare
|
||||
Format : constant Character := ALIs.Table (A1).Float_Format;
|
||||
begin
|
||||
for A2 in A1 + 1 .. ALIs.Last loop
|
||||
if ALIs.Table (A2).Float_Format /= Format then
|
||||
Error_Msg_File_1 := ALIs.Table (A1).Sfile;
|
||||
Error_Msg_File_2 := ALIs.Table (A2).Sfile;
|
||||
|
||||
Consistency_Error_Msg
|
||||
("{ and { compiled with different " &
|
||||
"floating-point representations");
|
||||
exit Find_Format;
|
||||
end if;
|
||||
end loop;
|
||||
end Check_Format;
|
||||
|
||||
exit Find_Format;
|
||||
end if;
|
||||
end loop Find_Format;
|
||||
end Check_Consistent_Floating_Point_Format;
|
||||
|
||||
---------------------------------------
|
||||
-- Check_Consistent_Interrupt_States --
|
||||
---------------------------------------
|
||||
|
||||
@ -159,10 +159,6 @@ package body Bindgen is
|
||||
-- A value of zero indicates that time slicing should be suppressed. If no
|
||||
-- pragma is present, and no -T switch was used, the value is -1.
|
||||
|
||||
-- Float_Format is the float representation in use. Currently the only
|
||||
-- valid value is 'I' for IEEE. We needed this field in the past for other
|
||||
-- floating-point formats, and it is retained for possible future use.
|
||||
|
||||
-- WC_Encoding shows the wide character encoding method used for the main
|
||||
-- program. This is one of the encoding letters defined in
|
||||
-- System.WCh_Con.WC_Encoding_Letters.
|
||||
|
||||
@ -620,11 +620,14 @@ package body Exp_Strm is
|
||||
-- and we are in the body of the default implementation of a 'Read
|
||||
-- attribute, set target type to force a constraint check (13.13.2(35)).
|
||||
-- If the type of the discriminant is currently private, add another
|
||||
-- unchecked conversion from the full view.
|
||||
-- unchecked conversion from the full view. We also do this check if
|
||||
-- this is an elementary read call in the source program (as opposed
|
||||
-- to one generated as part of a composite read).
|
||||
|
||||
if Nkind (Targ) = N_Identifier
|
||||
and then Is_Internal_Name (Chars (Targ))
|
||||
and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read)
|
||||
if (Nkind (Targ) = N_Identifier
|
||||
and then Is_Internal_Name (Chars (Targ))
|
||||
and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read))
|
||||
or else Comes_From_Source (N)
|
||||
then
|
||||
Res :=
|
||||
Unchecked_Convert_To (Base_Type (U_Type),
|
||||
|
||||
@ -1133,20 +1133,6 @@ package body Lib.Writ is
|
||||
Write_Info_Str (" DB");
|
||||
end if;
|
||||
|
||||
if Opt.Float_Format /= ' ' then
|
||||
Write_Info_Str (" F");
|
||||
|
||||
if Opt.Float_Format = 'I' then
|
||||
Write_Info_Char ('I');
|
||||
|
||||
elsif Opt.Float_Format_Long = 'D' then
|
||||
Write_Info_Char ('D');
|
||||
|
||||
else
|
||||
Write_Info_Char ('G');
|
||||
end if;
|
||||
end if;
|
||||
|
||||
if Tasking_Used
|
||||
and then not Is_Predefined_File_Name (Unit_File_Name (Main_Unit))
|
||||
then
|
||||
|
||||
@ -192,18 +192,6 @@ package Lib.Writ is
|
||||
-- the units in this file, where x is the first character
|
||||
-- (upper case) of the policy name (e.g. 'C' for Concurrent).
|
||||
|
||||
-- FD Configuration pragmas apply to all the units in this file
|
||||
-- specifying a possibly non-standard floating point format
|
||||
-- (VAX float with Long_Float using D_Float).
|
||||
|
||||
-- FG Configuration pragmas apply to all the units in this file
|
||||
-- specifying a possibly non-standard floating point format
|
||||
-- (VAX float with Long_Float using G_Float).
|
||||
|
||||
-- FI Configuration pragmas apply to all the units in this file
|
||||
-- specifying a possibly non-standard floating point format
|
||||
-- (IEEE Float).
|
||||
|
||||
-- Lx A valid Locking_Policy pragma applies to all the units in
|
||||
-- this file, where x is the first character (upper case) of
|
||||
-- the policy name (e.g. 'C' for Ceiling_Locking).
|
||||
|
||||
@ -639,19 +639,6 @@ package Opt is
|
||||
-- Indicates the current setting of Fast_Math mode, as set by the use
|
||||
-- of a Fast_Math pragma (set True by Fast_Math (On)).
|
||||
|
||||
Float_Format : Character := ' ';
|
||||
-- GNAT
|
||||
-- A non-blank value indicates that a Float_Format pragma has been
|
||||
-- processed, in which case this variable is set to 'I' for IEEE or to
|
||||
-- 'V' for VAX. The setting of 'V' is only possible on OpenVMS versions
|
||||
-- of GNAT.
|
||||
|
||||
Float_Format_Long : Character := ' ';
|
||||
-- GNAT
|
||||
-- A non-blank value indicates that a Long_Float pragma has been processed
|
||||
-- (this pragma is recognized only in OpenVMS versions of GNAT), in which
|
||||
-- case this variable is set to D or G for D_Float or G_Float.
|
||||
|
||||
Force_ALI_Tree_File : Boolean := False;
|
||||
-- GNAT
|
||||
-- Force generation of ALI file even if errors are encountered. Also forces
|
||||
|
||||
@ -1418,7 +1418,7 @@ package body Prj.Conf is
|
||||
|
||||
-- This might raise an Invalid_Config exception
|
||||
|
||||
Do_Autoconf;
|
||||
Do_Autoconf;
|
||||
|
||||
-- If the config file is not auto-generated, warn if there is any --RTS
|
||||
-- switch, but not when the config file is generated in memory.
|
||||
|
||||
@ -2040,6 +2040,32 @@ package body Prj.Env is
|
||||
-- directory correctly.
|
||||
|
||||
Last := Last - 1;
|
||||
|
||||
else
|
||||
declare
|
||||
New_Dir : constant String :=
|
||||
Normalize_Pathname
|
||||
(Name_Buffer (First .. Last),
|
||||
Resolve_Links => Opt.Follow_Links_For_Dirs);
|
||||
New_Len : Natural;
|
||||
New_Last : Natural;
|
||||
|
||||
begin
|
||||
-- If the absolute path was resolved and is different from
|
||||
-- the original, replace original with the resolved path.
|
||||
|
||||
if New_Dir /= Name_Buffer (First .. Last)
|
||||
and then New_Dir'Length /= 0
|
||||
then
|
||||
New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
|
||||
New_Last := First + New_Dir'Length - 1;
|
||||
Name_Buffer (New_Last + 1 .. New_Len) :=
|
||||
Name_Buffer (Last + 1 .. Name_Len);
|
||||
Name_Buffer (First .. New_Last) := New_Dir;
|
||||
Name_Len := New_Len;
|
||||
Last := New_Last;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
|
||||
First := Last + 1;
|
||||
|
||||
@ -50,12 +50,6 @@ package body System.File_IO is
|
||||
use type CRTL.size_t;
|
||||
use type Interfaces.C.int;
|
||||
|
||||
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 --
|
||||
----------------------
|
||||
@ -102,9 +96,6 @@ 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 --
|
||||
-----------------------
|
||||
@ -139,14 +130,6 @@ package body System.File_IO is
|
||||
-- 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 --
|
||||
----------------
|
||||
@ -630,197 +613,6 @@ 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 Index + Klen - 1 <= Form'Last
|
||||
and then Form (Index .. Index + Klen - 1) = KImage
|
||||
then
|
||||
case Parm is
|
||||
when Force_Record_Mode =>
|
||||
VMS_Form (Pos) := '"';
|
||||
Pos := Pos + 1;
|
||||
VMS_Form (Pos .. Pos + 6) := "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 + 6) := "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 --
|
||||
-------------
|
||||
@ -1104,17 +896,6 @@ package body System.File_IO is
|
||||
end;
|
||||
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.
|
||||
|
||||
@ -1286,19 +1067,8 @@ 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.
|
||||
|
||||
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;
|
||||
Stream :=
|
||||
fopen (Namestr'Address, Fopstr'Address, Encoding, Null_Address);
|
||||
|
||||
if Stream = NULL_Stream then
|
||||
|
||||
@ -1450,21 +1220,9 @@ package body System.File_IO is
|
||||
(Mode, File.Text_Encoding in Text_Content_Encoding,
|
||||
False, File.Access_Method, Fopstr);
|
||||
|
||||
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;
|
||||
File.Stream := freopen
|
||||
(File.Name.all'Address, Fopstr'Address, File.Stream,
|
||||
File.Encoding, Null_Address);
|
||||
|
||||
if File.Stream = NULL_Stream then
|
||||
Close (File_Ptr);
|
||||
@ -1483,9 +1241,9 @@ package body System.File_IO is
|
||||
procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
|
||||
begin
|
||||
-- Note: for most purposes, the Siz and 1 parameters in the fwrite call
|
||||
-- could be reversed, but on VMS, this is a better choice, since for
|
||||
-- some file formats, reversing the parameters results in records of one
|
||||
-- byte each.
|
||||
-- could be reversed, but we have encountered systems where this is a
|
||||
-- better choice, since for some file formats, reversing the parameters
|
||||
-- results in records of one byte each.
|
||||
|
||||
SSL.Abort_Defer.all;
|
||||
|
||||
|
||||
@ -96,8 +96,8 @@ package body System.OS_Lib is
|
||||
Stdout : Boolean);
|
||||
-- Internal routine to implement two Create_Temp_File routines. If Stdout
|
||||
-- is set to True the created descriptor is stdout-compatible, otherwise
|
||||
-- it might not be depending on the OS (VMS is one example). The first two
|
||||
-- parameters are as in Create_Temp_File.
|
||||
-- it might not be depending on the OS. The first two parameters are as
|
||||
-- in Create_Temp_File.
|
||||
|
||||
function C_String_Length (S : Address) return Integer;
|
||||
-- Returns the length of C (null-terminated) string at S, or 0 for
|
||||
@ -416,8 +416,8 @@ package body System.OS_Lib is
|
||||
loop
|
||||
R := Read (From, Buffer (1)'Address, Buf_Size);
|
||||
|
||||
-- For VMS, the buffer may not be full. So, we need to try again
|
||||
-- until there is nothing to read.
|
||||
-- On some systems, the buffer may not be full. So, we need to try
|
||||
-- again until there is nothing to read.
|
||||
|
||||
exit when R = 0;
|
||||
|
||||
@ -2019,12 +2019,7 @@ package body System.OS_Lib is
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
-- Resolve directory names for Windows (formerly also VMS)
|
||||
|
||||
-- On VMS, if we have a Unix path such as /temp/..., and TEMP is a
|
||||
-- logical name, we must not try to resolve this logical name, because
|
||||
-- it may have multiple equivalences and if resolved we will only
|
||||
-- get the first one.
|
||||
-- Resolve directory names for Windows
|
||||
|
||||
if On_Windows then
|
||||
|
||||
|
||||
@ -368,7 +368,7 @@ package System.OS_Lib is
|
||||
-- effect of "cp -p" on Unix systems, and None corresponds to the typical
|
||||
-- effect of "cp" on Unix systems.
|
||||
|
||||
-- Note: Time_Stamps and Full are not supported on VMS and VxWorks 5
|
||||
-- Note: Time_Stamps and Full are not supported on VxWorks 5
|
||||
|
||||
procedure Copy_File
|
||||
(Name : String;
|
||||
@ -384,20 +384,14 @@ package System.OS_Lib is
|
||||
-- True or False indicating if the copy is successful (depending on the
|
||||
-- specified Mode).
|
||||
--
|
||||
-- Note: this procedure is only supported to a very limited extent on VMS.
|
||||
-- The only supported mode is Overwrite, and the only supported value for
|
||||
-- Preserve is None, resulting in the default action which for Overwrite
|
||||
-- is to leave attributes unchanged. Furthermore, the copy only works for
|
||||
-- simple text files.
|
||||
|
||||
procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean);
|
||||
-- Copy Source file time stamps (last modification and last access time
|
||||
-- stamps) to Dest file. Source and Dest must be valid filenames,
|
||||
-- furthermore Dest must be writable. Success will be set to True if the
|
||||
-- operation was successful and False otherwise.
|
||||
--
|
||||
-- Note: this procedure is not supported on VMS and VxWorks 5. On these
|
||||
-- platforms, Success is always set to False.
|
||||
-- Note: this procedure is not supported on VxWorks 5. On this platform,
|
||||
-- Success is always set to False.
|
||||
|
||||
procedure Set_File_Last_Modify_Time_Stamp (Name : String; Time : OS_Time);
|
||||
-- Given the name of a file or directory, Name, set the last modification
|
||||
@ -484,17 +478,13 @@ package System.OS_Lib is
|
||||
-- e.g. A is a symbolic link for B, and B is a symbolic link for A), then
|
||||
-- Normalize_Pathname returns an empty string.
|
||||
--
|
||||
-- In VMS, if Name follows the VMS syntax file specification, it is first
|
||||
-- converted into Unix syntax. If the conversion fails, Normalize_Pathname
|
||||
-- returns an empty string.
|
||||
--
|
||||
-- For case-sensitive file systems, the value of Case_Sensitive parameter
|
||||
-- is ignored. For file systems that are not case-sensitive, such as
|
||||
-- Windows and OpenVMS, if this parameter is set to False, then the file
|
||||
-- and directory names are folded to lower case. This allows checking
|
||||
-- whether two files are the same by applying this function to their names
|
||||
-- and comparing the results. If Case_Sensitive is set to True, this
|
||||
-- function does not change the casing of file and directory names.
|
||||
-- Windows, if this parameter is set to False, then the file and directory
|
||||
-- names are folded to lower case. This allows checking whether two files
|
||||
-- are the same by applying this function to their names and comparing the
|
||||
-- results. If Case_Sensitive is set to True, this function does not change
|
||||
-- the casing of file and directory names.
|
||||
|
||||
function Is_Absolute_Path (Name : String) return Boolean;
|
||||
-- Returns True if Name is an absolute path name, i.e. it designates a
|
||||
@ -894,7 +884,7 @@ package System.OS_Lib is
|
||||
|
||||
-- On Solaris: fork1, followed in the child process by execv
|
||||
|
||||
-- On other Unix-like systems, and on VMS: fork, followed in the child
|
||||
-- On other Unix-like systems: fork, followed in the child
|
||||
-- process by execv.
|
||||
|
||||
-- On vxworks, nucleus, and RTX, spawning of processes is not supported
|
||||
@ -960,7 +950,7 @@ package System.OS_Lib is
|
||||
-- set an explicit null as the value, or to remove the entry, this is
|
||||
-- operating system dependent). Note that any following calls to Spawn
|
||||
-- will pass an environment to the spawned process that includes the
|
||||
-- changes made by Setenv calls. This procedure is not available on VMS.
|
||||
-- changes made by Setenv calls.
|
||||
|
||||
procedure OS_Exit (Status : Integer);
|
||||
pragma No_Return (OS_Exit);
|
||||
|
||||
@ -1753,8 +1753,9 @@ package body Sem_Ch5 is
|
||||
if not Is_Array_Type (Etype (Iter_Name)) then
|
||||
declare
|
||||
Iterator : constant Entity_Id :=
|
||||
Find_Value_Of_Aspect
|
||||
(Etype (Iter_Name), Aspect_Default_Iterator);
|
||||
Find_Value_Of_Aspect
|
||||
(Etype (Iter_Name), Aspect_Default_Iterator);
|
||||
|
||||
I : Interp_Index;
|
||||
It : Interp;
|
||||
|
||||
@ -1852,11 +1853,11 @@ package body Sem_Ch5 is
|
||||
|
||||
-- The name in the renaming declaration may be a function call.
|
||||
-- Indicate that it does not come from source, to suppress
|
||||
-- spurious warnings on renamings of parameterless functions,
|
||||
-- a common enough idiom in user-defined iterators.
|
||||
-- The entity of the renaming must be a variable, because user-
|
||||
-- defined Iterate function may have in-out parameters, even
|
||||
-- if predefined ones do not.
|
||||
-- spurious warnings on renamings of parameterless functions, a
|
||||
-- common enough idiom in user-defined iterators. The entity of
|
||||
-- the renaming must be a variable, because user- defined Iterate
|
||||
-- function may have in-out parameters, even if predefined ones do
|
||||
-- not.
|
||||
|
||||
Decl :=
|
||||
Make_Object_Renaming_Declaration (Loc,
|
||||
|
||||
@ -23,11 +23,9 @@
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with CStand; use CStand;
|
||||
with Einfo; use Einfo;
|
||||
with Opt; use Opt;
|
||||
with Stand; use Stand;
|
||||
with Targparm; use Targparm;
|
||||
with CStand; use CStand;
|
||||
with Einfo; use Einfo;
|
||||
with Stand; use Stand;
|
||||
|
||||
package body Sem_VFpt is
|
||||
|
||||
@ -134,32 +132,9 @@ package body Sem_VFpt is
|
||||
|
||||
procedure Set_Standard_Fpt_Formats is
|
||||
begin
|
||||
-- IEEE case
|
||||
|
||||
if Opt.Float_Format = 'I' then
|
||||
Set_IEEE_Short (Standard_Float);
|
||||
Set_IEEE_Long (Standard_Long_Float);
|
||||
Set_IEEE_Long (Standard_Long_Long_Float);
|
||||
|
||||
-- Vax float case
|
||||
|
||||
else
|
||||
Set_F_Float (Standard_Float);
|
||||
|
||||
if Opt.Float_Format_Long = 'D' then
|
||||
Set_D_Float (Standard_Long_Float);
|
||||
else
|
||||
Set_G_Float (Standard_Long_Float);
|
||||
end if;
|
||||
|
||||
-- Note: Long_Long_Float gets set only in the real VMS case,
|
||||
-- because this gives better results for testing out the use
|
||||
-- of VAX float on non-VMS environments with the -gnatdm switch.
|
||||
|
||||
if OpenVMS_On_Target then
|
||||
Set_G_Float (Standard_Long_Long_Float);
|
||||
end if;
|
||||
end if;
|
||||
Set_IEEE_Short (Standard_Float);
|
||||
Set_IEEE_Long (Standard_Long_Float);
|
||||
Set_IEEE_Long (Standard_Long_Long_Float);
|
||||
end Set_Standard_Fpt_Formats;
|
||||
|
||||
end Sem_VFpt;
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- Copyright (C) 1997-2007, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1997-2014, 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- --
|
||||
|
||||
@ -499,7 +499,7 @@ package Snames is
|
||||
Name_External : constant Name_Id := N + $; -- GNAT
|
||||
Name_Finalize_Storage_Only : constant Name_Id := N + $; -- GNAT
|
||||
Name_Global : constant Name_Id := N + $; -- GNAT
|
||||
Name_Ident : constant Name_Id := N + $; -- VMS
|
||||
Name_Ident : constant Name_Id := N + $; -- GNAT
|
||||
Name_Implementation_Defined : constant Name_Id := N + $; -- GNAT
|
||||
Name_Implemented : constant Name_Id := N + $; -- Ada 12
|
||||
Name_Import : constant Name_Id := N + $;
|
||||
@ -801,7 +801,6 @@ package Snames is
|
||||
Name_Variant : constant Name_Id := N + $;
|
||||
Name_VAX_Float : constant Name_Id := N + $;
|
||||
Name_Vector : constant Name_Id := N + $;
|
||||
Name_VMS : constant Name_Id := N + $;
|
||||
Name_Vtable_Ptr : constant Name_Id := N + $;
|
||||
Name_Warn : constant Name_Id := N + $;
|
||||
Name_Working_Storage : constant Name_Id := N + $;
|
||||
@ -814,9 +813,6 @@ package Snames is
|
||||
-- implemented in all Ada modes. Full descriptions of these implementation
|
||||
-- dependent attributes may be found in the appropriate Sem_Attr section.
|
||||
|
||||
-- The entries marked VMS are recognized only in OpenVMS implementations
|
||||
-- of GNAT, and are treated as illegal in all other contexts.
|
||||
|
||||
First_Attribute_Name : constant Name_Id := N + $;
|
||||
Name_Abort_Signal : constant Name_Id := N + $; -- GNAT
|
||||
Name_Access : constant Name_Id := N + $;
|
||||
|
||||
@ -1135,6 +1135,11 @@ package body Xr_Tabls is
|
||||
|
||||
Buffer (Read_Ptr) := EOF;
|
||||
Contents := new String'(Buffer (1 .. Read_Ptr));
|
||||
|
||||
if Read_Ptr /= Length + 1 then
|
||||
raise Ada.Text_IO.End_Error;
|
||||
end if;
|
||||
|
||||
Close (FD);
|
||||
end;
|
||||
end Read_File;
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user