OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

snames.ads-tmpl, [...]: Remove VMS-specific code.

Browse Source 
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 2014-08-01 09:41:55 +00:00 committed by Arnaud Charlet
parent 7a5b62b0c7
commit 78f8727c3a
19 changed files with 91 additions and 429 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gcc/ada/ChangeLog
View File

@ -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> 2014-08-01 Vincent Celier <celier@adacore.com>
* make.adb (Await_Compile): Remove loop that was only needed * make.adb (Await_Compile): Remove loop that was only needed

8
gcc/ada/ali.adb
View File

@ -108,7 +108,6 @@ package body ALI is
-- ALI files that are read for a given processing run in gnatbind. -- ALI files that are read for a given processing run in gnatbind.
Dynamic_Elaboration_Checks_Specified := False; Dynamic_Elaboration_Checks_Specified := False;
Float_Format_Specified := ' ';
Locking_Policy_Specified := ' '; Locking_Policy_Specified := ' ';
No_Normalize_Scalars_Specified := False; No_Normalize_Scalars_Specified := False;
No_Object_Specified := False; No_Object_Specified := False;
@ -876,7 +875,6 @@ package body ALI is
First_Sdep => No_Sdep_Id, First_Sdep => No_Sdep_Id,
First_Specific_Dispatching => Specific_Dispatching.Last + 1, First_Specific_Dispatching => Specific_Dispatching.Last + 1,
First_Unit => No_Unit_Id, First_Unit => No_Unit_Id,
Float_Format => 'I',
Last_Interrupt_State => Interrupt_States.Last, Last_Interrupt_State => Interrupt_States.Last,
Last_Sdep => No_Sdep_Id, Last_Sdep => No_Sdep_Id,
Last_Specific_Dispatching => Specific_Dispatching.Last, Last_Specific_Dispatching => Specific_Dispatching.Last,
@ -1091,12 +1089,6 @@ package body ALI is
ALIs.Table (Id).Partition_Elaboration_Policy := ALIs.Table (Id).Partition_Elaboration_Policy :=
Partition_Elaboration_Policy_Specified; 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 -- Processing for Lx
elsif C = 'L' then elsif C = 'L' then

9
gcc/ada/ali.ads
View File

@ -176,10 +176,6 @@ package ALI is
-- always be set as well in this case. Not set if 'P' appears in -- always be set as well in this case. Not set if 'P' appears in
-- Ignore_Lines. -- 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; No_Object : Boolean;
-- Set to True if no object file generated. Not set if 'P' appears in -- Set to True if no object file generated. Not set if 'P' appears in
-- Ignore_Lines. -- Ignore_Lines.
@ -469,11 +465,6 @@ package ALI is
-- Set to False by Initialize_ALI. Set to True if Scan_ALI reads -- Set to False by Initialize_ALI. Set to True if Scan_ALI reads
-- a unit for which dynamic elaboration checking is enabled. -- 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; Initialize_Scalars_Used : Boolean := False;
-- Set True if an ali file contains the Initialize_Scalars flag -- Set True if an ali file contains the Initialize_Scalars flag

40
gcc/ada/bcheck.adb
View File

@ -47,7 +47,6 @@ package body Bcheck is
procedure Check_Consistent_Dispatching_Policy; procedure Check_Consistent_Dispatching_Policy;
procedure Check_Consistent_Dynamic_Elaboration_Checking; procedure Check_Consistent_Dynamic_Elaboration_Checking;
procedure Check_Consistent_Floating_Point_Format;
procedure Check_Consistent_Interrupt_States; procedure Check_Consistent_Interrupt_States;
procedure Check_Consistent_Locking_Policy; procedure Check_Consistent_Locking_Policy;
procedure Check_Consistent_Normalize_Scalars; procedure Check_Consistent_Normalize_Scalars;
@ -73,10 +72,6 @@ package body Bcheck is
procedure Check_Configuration_Consistency is procedure Check_Configuration_Consistency is
begin begin
if Float_Format_Specified /= ' ' then
Check_Consistent_Floating_Point_Format;
end if;
if Queuing_Policy_Specified /= ' ' then if Queuing_Policy_Specified /= ' ' then
Check_Consistent_Queuing_Policy; Check_Consistent_Queuing_Policy;
end if; end if;
@ -526,41 +521,6 @@ package body Bcheck is
end if; end if;
end Check_Consistent_Dynamic_Elaboration_Checking; 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 -- -- Check_Consistent_Interrupt_States --
--------------------------------------- ---------------------------------------

4
gcc/ada/bindgen.adb
View File

@ -159,10 +159,6 @@ package body Bindgen is
-- A value of zero indicates that time slicing should be suppressed. If no -- 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. -- 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 -- WC_Encoding shows the wide character encoding method used for the main
-- program. This is one of the encoding letters defined in -- program. This is one of the encoding letters defined in
-- System.WCh_Con.WC_Encoding_Letters. -- System.WCh_Con.WC_Encoding_Letters.

11
gcc/ada/exp_strm.adb
View File

@ -620,11 +620,14 @@ package body Exp_Strm is
-- and we are in the body of the default implementation of a 'Read -- 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)). -- attribute, set target type to force a constraint check (13.13.2(35)).
-- If the type of the discriminant is currently private, add another -- 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 if (Nkind (Targ) = N_Identifier
and then Is_Internal_Name (Chars (Targ)) and then Is_Internal_Name (Chars (Targ))
and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read) and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read))
or else Comes_From_Source (N)
then then
Res := Res :=
Unchecked_Convert_To (Base_Type (U_Type), Unchecked_Convert_To (Base_Type (U_Type),

14
gcc/ada/lib-writ.adb
View File

@ -1133,20 +1133,6 @@ package body Lib.Writ is
Write_Info_Str (" DB"); Write_Info_Str (" DB");
end if; 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 if Tasking_Used
and then not Is_Predefined_File_Name (Unit_File_Name (Main_Unit)) and then not Is_Predefined_File_Name (Unit_File_Name (Main_Unit))
then then

12
gcc/ada/lib-writ.ads
View File

@ -192,18 +192,6 @@ package Lib.Writ is
-- the units in this file, where x is the first character -- the units in this file, where x is the first character
-- (upper case) of the policy name (e.g. 'C' for Concurrent). -- (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 -- Lx A valid Locking_Policy pragma applies to all the units in
-- this file, where x is the first character (upper case) of -- this file, where x is the first character (upper case) of
-- the policy name (e.g. 'C' for Ceiling_Locking). -- the policy name (e.g. 'C' for Ceiling_Locking).

13
gcc/ada/opt.ads
View File

@ -639,19 +639,6 @@ package Opt is
-- Indicates the current setting of Fast_Math mode, as set by the use -- Indicates the current setting of Fast_Math mode, as set by the use
-- of a Fast_Math pragma (set True by Fast_Math (On)). -- 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; Force_ALI_Tree_File : Boolean := False;
-- GNAT -- GNAT
-- Force generation of ALI file even if errors are encountered. Also forces -- Force generation of ALI file even if errors are encountered. Also forces

2
gcc/ada/prj-conf.adb
View File

@ -1418,7 +1418,7 @@ package body Prj.Conf is
-- This might raise an Invalid_Config exception -- 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 -- 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. -- switch, but not when the config file is generated in memory.

26
gcc/ada/prj-env.adb
View File

@ -2040,6 +2040,32 @@ package body Prj.Env is
-- directory correctly. -- directory correctly.
Last := Last - 1; 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; end if;
First := Last + 1; First := Last + 1;

258
gcc/ada/s-fileio.adb
View File

@ -50,12 +50,6 @@ package body System.File_IO is
use type CRTL.size_t; use type CRTL.size_t;
use type Interfaces.C.int; 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 -- -- Global Variables --
---------------------- ----------------------
@ -102,9 +96,6 @@ package body System.File_IO is
(C, text_translation_required, "__gnat_text_translation_required"); (C, text_translation_required, "__gnat_text_translation_required");
-- If true, add appropriate suffix to control string for Open -- If true, add appropriate suffix to control string for Open
VMS_Formstr : String_Access := null;
-- For special VMS RMS keywords and values
----------------------- -----------------------
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
@ -139,14 +130,6 @@ package body System.File_IO is
-- Clear error indication on File and raise Device_Error with an exception -- Clear error indication on File and raise Device_Error with an exception
-- message providing errno information. -- 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 -- -- Append_Set --
---------------- ----------------
@ -630,197 +613,6 @@ package body System.File_IO is
Stop := 0; Stop := 0;
end Form_Parameter; 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 -- -- Is_Open --
------------- -------------
@ -1104,17 +896,6 @@ package body System.File_IO is
end; end;
end if; 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 -- 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. -- 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 -- since by the time of the delete, the current working directory
-- may have changed and we do not want to delete a different file. -- may have changed and we do not want to delete a different file.
if VMS_Formstr = null then Stream :=
Stream := fopen (Namestr'Address, Fopstr'Address, Encoding, fopen (Namestr'Address, Fopstr'Address, Encoding, Null_Address);
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 if Stream = NULL_Stream then
@ -1450,21 +1220,9 @@ package body System.File_IO is
(Mode, File.Text_Encoding in Text_Content_Encoding, (Mode, File.Text_Encoding in Text_Content_Encoding,
False, File.Access_Method, Fopstr); False, File.Access_Method, Fopstr);
Form_VMS_RMS_Keys (File.Form.all, VMS_Formstr); File.Stream := freopen
(File.Name.all'Address, Fopstr'Address, File.Stream,
if VMS_Formstr = null then File.Encoding, Null_Address);
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 if File.Stream = NULL_Stream then
Close (File_Ptr); 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 procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is
begin begin
-- Note: for most purposes, the Siz and 1 parameters in the fwrite call -- 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 -- could be reversed, but we have encountered systems where this is a
-- some file formats, reversing the parameters results in records of one -- better choice, since for some file formats, reversing the parameters
-- byte each. -- results in records of one byte each.
SSL.Abort_Defer.all; SSL.Abort_Defer.all;

15
gcc/ada/s-os_lib.adb
View File

@ -96,8 +96,8 @@ package body System.OS_Lib is
Stdout : Boolean); Stdout : Boolean);
-- Internal routine to implement two Create_Temp_File routines. If Stdout -- Internal routine to implement two Create_Temp_File routines. If Stdout
-- is set to True the created descriptor is stdout-compatible, otherwise -- 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 -- it might not be depending on the OS. The first two parameters are as
-- parameters are as in Create_Temp_File. -- in Create_Temp_File.
function C_String_Length (S : Address) return Integer; function C_String_Length (S : Address) return Integer;
-- Returns the length of C (null-terminated) string at S, or 0 for -- Returns the length of C (null-terminated) string at S, or 0 for
@ -416,8 +416,8 @@ package body System.OS_Lib is
loop loop
R := Read (From, Buffer (1)'Address, Buf_Size); R := Read (From, Buffer (1)'Address, Buf_Size);
-- For VMS, the buffer may not be full. So, we need to try again -- On some systems, the buffer may not be full. So, we need to try
-- until there is nothing to read. -- again until there is nothing to read.
exit when R = 0; exit when R = 0;
@ -2019,12 +2019,7 @@ package body System.OS_Lib is
end loop; end loop;
end if; end if;
-- Resolve directory names for Windows (formerly also VMS) -- Resolve directory names for Windows
-- 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.
if On_Windows then if On_Windows then

30
gcc/ada/s-os_lib.ads
View File

@ -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 -p" on Unix systems, and None corresponds to the typical
-- effect of "cp" on Unix systems. -- 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 procedure Copy_File
(Name : String; (Name : String;
@ -384,20 +384,14 @@ package System.OS_Lib is
-- True or False indicating if the copy is successful (depending on the -- True or False indicating if the copy is successful (depending on the
-- specified Mode). -- 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); procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean);
-- Copy Source file time stamps (last modification and last access time -- Copy Source file time stamps (last modification and last access time
-- stamps) to Dest file. Source and Dest must be valid filenames, -- stamps) to Dest file. Source and Dest must be valid filenames,
-- furthermore Dest must be writable. Success will be set to True if the -- furthermore Dest must be writable. Success will be set to True if the
-- operation was successful and False otherwise. -- operation was successful and False otherwise.
-- --
-- Note: this procedure is not supported on VMS and VxWorks 5. On these -- Note: this procedure is not supported on VxWorks 5. On this platform,
-- platforms, Success is always set to False. -- Success is always set to False.
procedure Set_File_Last_Modify_Time_Stamp (Name : String; Time : OS_Time); 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 -- 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 -- e.g. A is a symbolic link for B, and B is a symbolic link for A), then
-- Normalize_Pathname returns an empty string. -- 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 -- For case-sensitive file systems, the value of Case_Sensitive parameter
-- is ignored. For file systems that are not case-sensitive, such as -- 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 -- Windows, if this parameter is set to False, then the file and directory
-- and directory names are folded to lower case. This allows checking -- names are folded to lower case. This allows checking whether two files
-- whether two files are the same by applying this function to their names -- are the same by applying this function to their names and comparing the
-- and comparing the results. If Case_Sensitive is set to True, this -- results. If Case_Sensitive is set to True, this function does not change
-- function does not change the casing of file and directory names. -- the casing of file and directory names.
function Is_Absolute_Path (Name : String) return Boolean; function Is_Absolute_Path (Name : String) return Boolean;
-- Returns True if Name is an absolute path name, i.e. it designates a -- 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 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. -- process by execv.
-- On vxworks, nucleus, and RTX, spawning of processes is not supported -- 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 -- set an explicit null as the value, or to remove the entry, this is
-- operating system dependent). Note that any following calls to Spawn -- operating system dependent). Note that any following calls to Spawn
-- will pass an environment to the spawned process that includes the -- 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); procedure OS_Exit (Status : Integer);
pragma No_Return (OS_Exit); pragma No_Return (OS_Exit);

15
gcc/ada/sem_ch5.adb
View File

@ -1753,8 +1753,9 @@ package body Sem_Ch5 is
if not Is_Array_Type (Etype (Iter_Name)) then if not Is_Array_Type (Etype (Iter_Name)) then
declare declare
Iterator : constant Entity_Id := Iterator : constant Entity_Id :=
Find_Value_Of_Aspect Find_Value_Of_Aspect
(Etype (Iter_Name), Aspect_Default_Iterator); (Etype (Iter_Name), Aspect_Default_Iterator);
I : Interp_Index; I : Interp_Index;
It : Interp; It : Interp;
@ -1852,11 +1853,11 @@ package body Sem_Ch5 is
-- The name in the renaming declaration may be a function call. -- The name in the renaming declaration may be a function call.
-- Indicate that it does not come from source, to suppress -- Indicate that it does not come from source, to suppress
-- spurious warnings on renamings of parameterless functions, -- spurious warnings on renamings of parameterless functions, a
-- a common enough idiom in user-defined iterators. -- common enough idiom in user-defined iterators. The entity of
-- The entity of the renaming must be a variable, because user- -- the renaming must be a variable, because user- defined Iterate
-- defined Iterate function may have in-out parameters, even -- function may have in-out parameters, even if predefined ones do
-- if predefined ones do not. -- not.
Decl := Decl :=
Make_Object_Renaming_Declaration (Loc, Make_Object_Renaming_Declaration (Loc,

37
gcc/ada/sem_vfpt.adb
View File

@ -23,11 +23,9 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with CStand; use CStand; with CStand; use CStand;
with Einfo; use Einfo; with Einfo; use Einfo;
with Opt; use Opt; with Stand; use Stand;
with Stand; use Stand;
with Targparm; use Targparm;
package body Sem_VFpt is package body Sem_VFpt is
@ -134,32 +132,9 @@ package body Sem_VFpt is
procedure Set_Standard_Fpt_Formats is procedure Set_Standard_Fpt_Formats is
begin begin
-- IEEE case Set_IEEE_Short (Standard_Float);
Set_IEEE_Long (Standard_Long_Float);
if Opt.Float_Format = 'I' then Set_IEEE_Long (Standard_Long_Long_Float);
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;
end Set_Standard_Fpt_Formats; end Set_Standard_Fpt_Formats;
end Sem_VFpt; end Sem_VFpt;

2
gcc/ada/sem_vfpt.ads
View File

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --

6
gcc/ada/snames.ads-tmpl
View File

@ -499,7 +499,7 @@ package Snames is
Name_External : constant Name_Id := N + $; -- GNAT Name_External : constant Name_Id := N + $; -- GNAT
Name_Finalize_Storage_Only : constant Name_Id := N + $; -- GNAT Name_Finalize_Storage_Only : constant Name_Id := N + $; -- GNAT
Name_Global : 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_Implementation_Defined : constant Name_Id := N + $; -- GNAT
Name_Implemented : constant Name_Id := N + $; -- Ada 12 Name_Implemented : constant Name_Id := N + $; -- Ada 12
Name_Import : constant Name_Id := N + $; Name_Import : constant Name_Id := N + $;
@ -801,7 +801,6 @@ package Snames is
Name_Variant : constant Name_Id := N + $; Name_Variant : constant Name_Id := N + $;
Name_VAX_Float : constant Name_Id := N + $; Name_VAX_Float : constant Name_Id := N + $;
Name_Vector : constant Name_Id := N + $; Name_Vector : constant Name_Id := N + $;
Name_VMS : constant Name_Id := N + $;
Name_Vtable_Ptr : constant Name_Id := N + $; Name_Vtable_Ptr : constant Name_Id := N + $;
Name_Warn : constant Name_Id := N + $; Name_Warn : constant Name_Id := N + $;
Name_Working_Storage : 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 -- implemented in all Ada modes. Full descriptions of these implementation
-- dependent attributes may be found in the appropriate Sem_Attr section. -- 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 + $; First_Attribute_Name : constant Name_Id := N + $;
Name_Abort_Signal : constant Name_Id := N + $; -- GNAT Name_Abort_Signal : constant Name_Id := N + $; -- GNAT
Name_Access : constant Name_Id := N + $; Name_Access : constant Name_Id := N + $;

5
gcc/ada/xr_tabls.adb
View File

@ -1135,6 +1135,11 @@ package body Xr_Tabls is
Buffer (Read_Ptr) := EOF; Buffer (Read_Ptr) := EOF;
Contents := new String'(Buffer (1 .. Read_Ptr)); Contents := new String'(Buffer (1 .. Read_Ptr));
if Read_Ptr /= Length + 1 then
raise Ada.Text_IO.End_Error;
end if;
Close (FD); Close (FD);
end; end;
end Read_File; end Read_File;