FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

[multiple changes]

Browse source 
2014-08-01  Vincent Celier  <celier@adacore.com>

	* make.adb (Await_Compile): Remove loop that was only needed
	for VMS.

2014-08-01  Robert Dewar  <dewar@adacore.com>

	* a-calcon.ads, a-direct.adb, a-dirval-mingw.adb, a-dirval.adb,
	a-dirval.ads, a-except-2005.adb, a-excpol-abort.adb,
	a-numaux-darwin.ads, a-numaux.ads, bindgen.adb, bindusg.adb,
	einfo.adb, einfo.ads, err_vars.ads, errout.ads, errutil.adb,
	exp_ch3.adb, exp_ch4.adb, exp_ch7.adb, exp_ch7.ads, fname-uf.adb,
	fname.adb, fname.ads, freeze.adb, g-debpoo.adb, g-dirope.ads,
	g-excact.ads, g-expect.ads, g-socket.adb, g-socket.ads, g-sothco.ads,
	g-traceb.ads, gnat_rm.texi, gnatlink.adb, gnatls.adb, i-cstrea.adb,
	krunch.adb, krunch.ads, layout.adb, lib-util.adb, make.adb,
	mlib.adb, osint-b.adb, osint-b.ads, osint-c.adb, osint.adb,
	osint.ads, output.ads, par.adb, prj-conf.adb, prj-env.adb,
	prj-makr.adb, prj-nmsc.adb, prj.adb, prj.ads, repinfo.adb, rtsfind.adb,
	rtsfind.ads, s-excmac-gcc.ads, s-fatgen.adb, s-mastop.ads,
	s-parame-ae653.ads, s-parame-hpux.ads, s-parame-vxworks.ads,
	s-parame.ads, s-soflin.ads, s-stoele.adb, s-tasini.adb,
	s-taspri-dummy.ads, s-taspri-hpux-dce.ads, s-taspri-mingw.ads,
	s-taspri-posix-noaltstack.ads, s-taspri-posix.ads,
	s-taspri-solaris.ads, s-taspri-vxworks.ads, s-trasym.ads,
	sem_ch12.adb, sem_ch4.adb, sem_eval.adb, sem_intr.adb, sem_mech.adb,
	sem_mech.ads, sem_prag.adb, sem_res.adb, sem_util.adb, sem_util.ads,
	sinfo.adb, sinfo.ads, sinput-c.adb, symbols.ads, targparm.adb,
	treepr.adb, types.ads, xr_tabls.adb, xr_tabls.ads: Remove VMS
	specific code and comments.

2014-08-01  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch5.adb (Analyze_Iterator_Specification): New procedure
	Check_Reverse_Iteration, to verify the legality of the Reverse
	indicator on various container types, and to detect illegal
	reverse iterations on containers that only supoort forward
	iteration.

From-SVN: r213431
This commit is contained in:
Arnaud Charlet 2014-08-01 11:38:48 +02:00
parent 935a9145c6
commit 7a5b62b0c7
96 changed files with 514 additions and 1325 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

39
gcc/ada/ChangeLog
View file

@ -1,3 +1,42 @@
2014-08-01 Vincent Celier <celier@adacore.com>
* make.adb (Await_Compile): Remove loop that was only needed
for VMS.
2014-08-01 Robert Dewar <dewar@adacore.com>
* a-calcon.ads, a-direct.adb, a-dirval-mingw.adb, a-dirval.adb,
a-dirval.ads, a-except-2005.adb, a-excpol-abort.adb,
a-numaux-darwin.ads, a-numaux.ads, bindgen.adb, bindusg.adb,
einfo.adb, einfo.ads, err_vars.ads, errout.ads, errutil.adb,
exp_ch3.adb, exp_ch4.adb, exp_ch7.adb, exp_ch7.ads, fname-uf.adb,
fname.adb, fname.ads, freeze.adb, g-debpoo.adb, g-dirope.ads,
g-excact.ads, g-expect.ads, g-socket.adb, g-socket.ads, g-sothco.ads,
g-traceb.ads, gnat_rm.texi, gnatlink.adb, gnatls.adb, i-cstrea.adb,
krunch.adb, krunch.ads, layout.adb, lib-util.adb, make.adb,
mlib.adb, osint-b.adb, osint-b.ads, osint-c.adb, osint.adb,
osint.ads, output.ads, par.adb, prj-conf.adb, prj-env.adb,
prj-makr.adb, prj-nmsc.adb, prj.adb, prj.ads, repinfo.adb, rtsfind.adb,
rtsfind.ads, s-excmac-gcc.ads, s-fatgen.adb, s-mastop.ads,
s-parame-ae653.ads, s-parame-hpux.ads, s-parame-vxworks.ads,
s-parame.ads, s-soflin.ads, s-stoele.adb, s-tasini.adb,
s-taspri-dummy.ads, s-taspri-hpux-dce.ads, s-taspri-mingw.ads,
s-taspri-posix-noaltstack.ads, s-taspri-posix.ads,
s-taspri-solaris.ads, s-taspri-vxworks.ads, s-trasym.ads,
sem_ch12.adb, sem_ch4.adb, sem_eval.adb, sem_intr.adb, sem_mech.adb,
sem_mech.ads, sem_prag.adb, sem_res.adb, sem_util.adb, sem_util.ads,
sinfo.adb, sinfo.ads, sinput-c.adb, symbols.ads, targparm.adb,
treepr.adb, types.ads, xr_tabls.adb, xr_tabls.ads: Remove VMS
specific code and comments.
2014-08-01 Ed Schonberg <schonberg@adacore.com>
* sem_ch5.adb (Analyze_Iterator_Specification): New procedure
Check_Reverse_Iteration, to verify the legality of the Reverse
indicator on various container types, and to detect illegal
reverse iterations on containers that only supoort forward
iteration.
2014-08-01 Vincent Celier <celier@adacore.com>
* gnatcmd.adb: Remove the VMS specific stuff. Integrate in

11
gcc/ada/a-calcon.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2008-2009 Free Software Foundation, Inc. --
-- Copyright (C) 2008-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- --
@ -37,11 +37,10 @@ with Interfaces.C;
package Ada.Calendar.Conversions is
function To_Ada_Time (Unix_Time : Interfaces.C.long) return Time;
-- Convert a time value represented as number of seconds since the Unix
-- Epoch to a time value relative to an Ada implementation-defined Epoch.
-- The units of the result are 100 nanoseconds on VMS and nanoseconds on
-- all other targets. Raises Time_Error if the result cannot fit into a
-- Time value.
-- Convert a time value represented as number of seconds since the
-- Unix Epoch to a time value relative to an Ada implementation-defined
-- Epoch. The units of the result are nanoseconds on all targets. Raises
-- Time_Error if the result cannot fit into a Time value.
function To_Ada_Time
(tm_year : Interfaces.C.int;

19
gcc/ada/a-direct.adb
View file

@ -982,7 +982,6 @@ package body Ada.Directories is
Hour : Hour_Type;
Minute : Minute_Type;
Second : Second_Type;
Result : Time;
begin
-- First, the invalid cases
@ -999,25 +998,11 @@ package body Ada.Directories is
GM_Split (Date, Year, Month, Day, Hour, Minute, Second);
-- On OpenVMS, the resulting time value must be in the local time
-- zone. Ada.Calendar.Time_Of is exactly what we need. Note that
-- in both cases, the sub seconds are set to zero (0.0) because the
-- time stamp does not store them in its value.
if OpenVMS then
Result :=
Ada.Calendar.Time_Of
(Year, Month, Day, Seconds_Of (Hour, Minute, Second, 0.0));
-- On Unix and Windows, the result must be in GMT. Ada.Calendar.
-- The result must be in GMT. Ada.Calendar.
-- Formatting.Time_Of with default time zone of zero (0) is the
-- routine of choice.
else
Result := Time_Of (Year, Month, Day, Hour, Minute, Second, 0.0);
end if;
return Result;
return Time_Of (Year, Month, Day, Hour, Minute, Second, 0.0);
end if;
end Modification_Time;

11
gcc/ada/a-dirval-mingw.adb
View file

@ -7,7 +7,7 @@
-- B o d y --
-- (Windows Version) --
-- --
-- Copyright (C) 2004-2012, Free Software Foundation, Inc. --
-- Copyright (C) 2004-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- --
@ -161,15 +161,6 @@ package body Ada.Directories.Validity is
end if;
end Is_Valid_Simple_Name;
-------------
-- OpenVMS --
-------------
function OpenVMS return Boolean is
begin
return False;
end OpenVMS;
-------------
-- Windows --
-------------

11
gcc/ada/a-dirval.adb
View file

@ -7,7 +7,7 @@
-- B o d y --
-- (POSIX Version) --
-- --
-- Copyright (C) 2004-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2004-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- --
@ -92,15 +92,6 @@ package body Ada.Directories.Validity is
return True;
end Is_Valid_Simple_Name;
-------------
-- OpenVMS --
-------------
function OpenVMS return Boolean is
begin
return False;
end OpenVMS;
-------------
-- Windows --
-------------

5
gcc/ada/a-dirval.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2004-2009, Free Software Foundation, Inc. --
-- Copyright (C) 2004-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- --
@ -43,9 +43,6 @@ private package Ada.Directories.Validity is
function Is_Path_Name_Case_Sensitive return Boolean;
-- Returns True if file and path names are case-sensitive
function OpenVMS return Boolean;
-- Return True when OS is OpenVMS
function Windows return Boolean;
-- Return True when OS is Windows

19
gcc/ada/a-except-2005.adb
View file

@ -672,24 +672,23 @@ package body Ada.Exceptions is
-- perform periodic but not systematic operations.
procedure Poll is separate;
-- The actual polling routine is separate, so that it can easily
-- be replaced with a target dependent version.
-- The actual polling routine is separate, so that it can easily be
-- replaced with a target dependent version.
--------------------------
-- Code_Address_For_AAA --
--------------------------
-- This function gives us the start of the PC range for addresses
-- within the exception unit itself. We hope that gigi/gcc keep all the
-- procedures in their original order.
-- This function gives us the start of the PC range for addresses within
-- the exception unit itself. We hope that gigi/gcc keep all the procedures
-- in their original order.
function Code_Address_For_AAA return System.Address is
begin
-- We are using a label instead of merely using
-- Code_Address_For_AAA'Address because on some platforms the latter
-- does not yield the address we want, but the address of a stub or of
-- a descriptor instead. This is the case at least on Alpha-VMS and
-- PA-HPUX.
-- We are using a label instead of Code_Address_For_AAA'Address because
-- on some platforms the latter does not yield the address we want, but
-- the address of a stub or of a descriptor instead. This is the case at
-- least on PA-HPUX.
<<Start_Of_AAA>>
return Start_Of_AAA'Address;

4
gcc/ada/a-excpol-abort.adb
View file

@ -7,7 +7,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -35,7 +35,7 @@
-- that activates periodic polling. Then in the body of the polling routine
-- we test for asynchronous abort.
-- Windows, HPUX 10 and VMS currently use this file
-- Windows and HPUX 10 currently use this file
pragma Warnings (Off);
-- Allow withing of non-Preelaborated units in Ada 2005 mode where this

13
gcc/ada/a-numaux-darwin.ads
View file

@ -7,7 +7,7 @@
-- S p e c --
-- (Apple OS X Version) --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -31,12 +31,11 @@
------------------------------------------------------------------------------
-- This version is for use with normal Unix math functions, except for
-- sine/cosine which have been implemented directly in Ada to get
-- the required accuracy in OS X. Alternative packages are used
-- on OpenVMS (different import names), VxWorks (no need for the
-- -lm Linker_Options), and on the x86 (where we have two
-- versions one using inline ASM, and one importing from the C long
-- routines that take 80-bit arguments).
-- sine/cosine which have been implemented directly in Ada to get the required
-- accuracy in OS X. Alternative packages are used on VxWorks (no need for the
-- -lm Linker_Options), and on the x86 (where we have two versions one using
-- inline ASM, and one importing from the C long routines that take 80-bit
-- arguments).
package Ada.Numerics.Aux is
pragma Pure;

11
gcc/ada/a-numaux.ads
View file

@ -7,7 +7,7 @@
-- S p e c --
-- (C Library Version, non-x86) --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -37,11 +37,10 @@
-- One advantage of using this package is that it will interface directly to
-- hardware instructions, such as the those provided on the Intel x86.
-- This version is for use with normal Unix math functions. Alternative
-- packages are used on OpenVMS (different import names), VxWorks (no
-- need for the -lm Linker_Options), and on the x86 (where we have two
-- versions one using inline ASM, and one importing from the C long
-- routines that take 80-bit arguments).
-- This version here is for use with normal Unix math functions. Alternative
-- packages are used VxWorks (no need for the -lm Linker_Options), and on the
-- x86 (where we have two versions one using inline ASM, and one importing
-- from the C long routines that take 80-bit arguments).
package Ada.Numerics.Aux is
pragma Pure;

20
gcc/ada/bindgen.adb
View file

@ -159,12 +159,9 @@ 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.
-- Heap_Size is the heap to use for memory allocations set by use of a
-- -Hnn parameter for the binder or by the GNAT$NO_MALLOC_64 logical.
-- Valid values are 32 and 64. This switch is only effective on VMS.
-- Float_Format is the float representation in use. Valid values are
-- 'I' for IEEE and 'V' for VAX Float. This is only for VMS.
-- 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
@ -2046,10 +2043,10 @@ package body Bindgen is
-- files. The reason for this decision is that libraries referenced
-- by internal routines may reference these standard library entries.
-- Note that we do not insert anything when pragma No_Run_Time has been
-- specified or when the standard libraries are not to be used,
-- otherwise on some platforms, such as VMS, we may get duplicate
-- symbols when linking.
-- Note that we do not insert anything when pragma No_Run_Time has
-- been specified or when the standard libraries are not to be used,
-- otherwise on some platforms, we may get duplicate symbols when
-- linking (not clear if this is still the case, but it is harmless).
if not (Opt.No_Run_Time_Mode or else Opt.No_Stdlib) then
Name_Len := 0;
@ -2212,8 +2209,7 @@ package body Bindgen is
Resolve_Binder_Options;
-- Usually, adafinal is called using a pragma Import C. Since Import C
-- doesn't have the same semantics for VMs or CodePeer use standard Ada.
-- Generate standard with's
if not Suppress_Standard_Library_On_Target then
if CodePeer_Mode then

7
gcc/ada/bindusg.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -120,11 +120,6 @@ package body Bindusg is
Write_Line (" -h Output this usage (help) information");
-- Line for -H switch
Write_Line (" -Hnn Use nn bit heap where nn is 32 or 64 " &
"(VMS Only)");
-- Lines for -I switch
Write_Line (" -Idir Specify library and source files search path");

20
gcc/ada/einfo.adb
View file

@ -411,7 +411,6 @@ package body Einfo is
-- Is_Generic_Instance Flag130
-- No_Pool_Assigned Flag131
-- Is_Optional_Parameter Flag134
-- Has_Aliased_Components Flag135
-- No_Strict_Aliasing Flag136
-- Is_Machine_Code_Subprogram Flag137
@ -573,6 +572,12 @@ package body Einfo is
-- (unused) Flag2
-- (unused) Flag3
-- (unused) Flag132
-- (unused) Flag133
-- (unused) Flag134
-- (unused) Flag275
-- (unused) Flag276
-- (unused) Flag277
-- (unused) Flag278
-- (unused) Flag279
@ -2202,12 +2207,6 @@ package body Einfo is
return Flag226 (Id);
end Is_Only_Out_Parameter;
function Is_Optional_Parameter (Id : E) return B is
begin
pragma Assert (Is_Formal (Id));
return Flag134 (Id);
end Is_Optional_Parameter;
function Is_Package_Body_Entity (Id : E) return B is
begin
return Flag160 (Id);
@ -4993,12 +4992,6 @@ package body Einfo is
Set_Flag226 (Id, V);
end Set_Is_Only_Out_Parameter;
procedure Set_Is_Optional_Parameter (Id : E; V : B := True) is
begin
pragma Assert (Is_Formal (Id));
Set_Flag134 (Id, V);
end Set_Is_Optional_Parameter;
procedure Set_Is_Package_Body_Entity (Id : E; V : B := True) is
begin
Set_Flag160 (Id, V);
@ -8405,7 +8398,6 @@ package body Einfo is
W ("Is_Null_Init_Proc", Flag178 (Id));
W ("Is_Obsolescent", Flag153 (Id));
W ("Is_Only_Out_Parameter", Flag226 (Id));
W ("Is_Optional_Parameter", Flag134 (Id));
W ("Is_Package_Body_Entity", Flag160 (Id));
W ("Is_Packed", Flag51 (Id));
W ("Is_Packed_Array_Impl_Type", Flag138 (Id));

27
gcc/ada/einfo.ads
View file

@ -2328,7 +2328,7 @@ package Einfo is
-- Defined in all entities. Set if the entity is exported. For now we
-- only allow the export of constants, exceptions, functions, procedures
-- and variables, but that may well change later on. Exceptions can only
-- be exported in the OpenVMS and Java VM implementations of GNAT.
-- be exported in the Java VM implementation of GNAT.
-- Is_External_State (synthesized)
-- Applies to all entities, true for abstract states that are subject to
@ -2447,9 +2447,8 @@ package Einfo is
-- Is_Imported (Flag24)
-- Defined in all entities. Set if the entity is imported. For now we
-- only allow the import of exceptions, functions, procedures, packages.
-- and variables. Exceptions can only be imported in the OpenVMS and
-- Java VM implementations of GNAT. Packages and types can only be
-- imported in the Java VM implementation.
-- and variables. Exceptions, packages and types can only be imported in
-- the Java VM implementation.
-- Is_Incomplete_Or_Private_Type (synthesized)
-- Applies to all entities, true for private and incomplete types
@ -2697,11 +2696,6 @@ package Einfo is
-- out parameter, or if there is some other IN OUT parameter then this
-- flag is not set in any of them. Used in generation of warnings.
-- Is_Optional_Parameter (Flag134)
-- Defined in parameter entities. Set if the parameter is specified as
-- optional by use of a First_Optional_Parameter argument to one of the
-- extended Import pragmas. Can only be set for OpenVMS versions of GNAT.
-- Is_Ordinary_Fixed_Point_Type (synthesized)
-- Applies to all entities, true for ordinary fixed point types and
-- subtypes.
@ -3348,8 +3342,9 @@ package Einfo is
-- types which have a convention of C, C++ or Fortran.
-- No_Dynamic_Predicate_On_Actual (Flag276)
-- Defined on generic formal types that are used in loops and quantified
-- expressions. The corresponing actual cannot have dynamic predicates.
-- Defined in discrete types. Set for generic formal types that are used
-- in loops and quantified expressions. The corresponing actual cannot
-- have dynamic predicates.
-- No_Pool_Assigned (Flag131) [root type only]
-- Defined in access types. Set if a storage size clause applies to the
@ -3359,8 +3354,9 @@ package Einfo is
-- derived types must have the same pool.
-- No_Predicate_On_Actual (Flag275)
-- Defined on generic formal types that are used in the spec of a generic
-- package, in constructs that forbid discrete types with predicates.
-- Defined in discrete types. Set for generic formal types that are used
-- in the spec of a generic package, in constructs that forbid discrete
-- types with predicates.
-- No_Return (Flag113)
-- Defined in all entities. Always false except in the case of procedures
@ -5751,7 +5747,6 @@ package Einfo is
-- Has_Initial_Value (Flag219)
-- Is_Controlling_Formal (Flag97)
-- Is_Only_Out_Parameter (Flag226)
-- Is_Optional_Parameter (Flag134)
-- Low_Bound_Tested (Flag205)
-- Is_Return_Object (Flag209)
-- Parameter_Mode (synth)
@ -6703,7 +6698,6 @@ package Einfo is
function Is_Null_Init_Proc (Id : E) return B;
function Is_Obsolescent (Id : E) return B;
function Is_Only_Out_Parameter (Id : E) return B;
function Is_Optional_Parameter (Id : E) return B;
function Is_Package_Body_Entity (Id : E) return B;
function Is_Packed (Id : E) return B;
function Is_Packed_Array_Impl_Type (Id : E) return B;
@ -7343,7 +7337,6 @@ package Einfo is
procedure Set_Is_Null_Init_Proc (Id : E; V : B := True);
procedure Set_Is_Obsolescent (Id : E; V : B := True);
procedure Set_Is_Only_Out_Parameter (Id : E; V : B := True);
procedure Set_Is_Optional_Parameter (Id : E; V : B := True);
procedure Set_Is_Package_Body_Entity (Id : E; V : B := True);
procedure Set_Is_Packed (Id : E; V : B := True);
procedure Set_Is_Packed_Array_Impl_Type (Id : E; V : B := True);
@ -8119,7 +8112,6 @@ package Einfo is
pragma Inline (Is_Object);
pragma Inline (Is_Obsolescent);
pragma Inline (Is_Only_Out_Parameter);
pragma Inline (Is_Optional_Parameter);
pragma Inline (Is_Ordinary_Fixed_Point_Type);
pragma Inline (Is_Overloadable);
pragma Inline (Is_Package_Body_Entity);
@ -8570,7 +8562,6 @@ package Einfo is
pragma Inline (Set_Is_Null_Init_Proc);
pragma Inline (Set_Is_Obsolescent);
pragma Inline (Set_Is_Only_Out_Parameter);
pragma Inline (Set_Is_Optional_Parameter);
pragma Inline (Set_Is_Package_Body_Entity);
pragma Inline (Set_Is_Packed);
pragma Inline (Set_Is_Packed_Array_Impl_Type);

3
gcc/ada/err_vars.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -93,7 +93,6 @@ package Err_Vars is
-- are active (see errout.ads for details). If this switch is False, then
-- these sequences are ignored (i.e. simply equivalent to a single ?). The
-- -gnatw.d switch sets this flag True, -gnatw.D sets this flag False.
-- Note: always ignored on VMS, where we do not provide this capability.
----------------------------------------
-- Error Message Insertion Parameters --

62
gcc/ada/errout.ads
View file

@ -413,68 +413,6 @@ package Errout is
-- are continuations that are not printed using the -gnatj switch they
-- will also have this prefix.
----------------------------------------
-- Specialization of Messages for VMS --
----------------------------------------
-- Some messages mention gcc-style switch names. When using an OpenVMS
-- host, such switch names must be converted to their corresponding VMS
-- qualifer. The following table controls this translation. In each case
-- the original message must contain the string "-xxx switch", where xxx
-- is the Gname? entry from below, and this string will be replaced by
-- "/yyy qualifier", where yyy is the corresponding Vname? entry.
Gname1 : aliased constant String := "fno-strict-aliasing";
Vname1 : aliased constant String := "OPTIMIZE=NO_STRICT_ALIASING";
Gname2 : aliased constant String := "gnatX";
Vname2 : aliased constant String := "EXTENSIONS_ALLOWED";
Gname3 : aliased constant String := "gnatW";
Vname3 : aliased constant String := "WIDE_CHARACTER_ENCODING";
Gname4 : aliased constant String := "gnatf";
Vname4 : aliased constant String := "REPORT_ERRORS=FULL";
Gname5 : aliased constant String := "gnat05";
Vname5 : aliased constant String := "05";
Gname6 : aliased constant String := "gnat2005";
Vname6 : aliased constant String := "2005";
Gname7 : aliased constant String := "gnat12";
Vname7 : aliased constant String := "12";
Gname8 : aliased constant String := "gnat2012";
Vname8 : aliased constant String := "2012";
Gname9 : aliased constant String := "gnateinn";
Vname9 : aliased constant String := "MAX_INSTANTIATIONS=nn";
type Cstring_Ptr is access constant String;
Gnames : array (Nat range <>) of Cstring_Ptr :=
(Gname1'Access,
Gname2'Access,
Gname3'Access,
Gname4'Access,
Gname5'Access,
Gname6'Access,
Gname7'Access,
Gname8'Access,
Gname9'Access);
Vnames : array (Nat range <>) of Cstring_Ptr :=
(Vname1'Access,
Vname2'Access,
Vname3'Access,
Vname4'Access,
Vname5'Access,
Vname6'Access,
Vname7'Access,
Vname8'Access,
Vname9'Access);
-----------------------------------------------------
-- Global Values Used for Error Message Insertions --
-----------------------------------------------------

8
gcc/ada/errutil.adb
View file

@ -502,10 +502,10 @@ package body Errutil is
-- error to make sure that *something* appears on standard error in
-- an error situation.
-- Formerly, only the "# errors" suffix was sent to stderr, whereas
-- "# lines:" appeared on stdout. This caused problems on VMS when
-- the stdout buffer was flushed, giving an extra line feed after
-- the prefix.
-- Historical note: Formerly, only the "# errors" suffix was sent
-- to stderr, whereas "# lines:" appeared on stdout. This caused
-- some problems on now-obsolete ports, but there seems to be no
-- reason to revert this page since it would be incompatible.
if Total_Errors_Detected + Warnings_Detected /= 0
and then not Brief_Output

20
gcc/ada/exp_ch3.adb
View file

@ -1701,18 +1701,6 @@ package body Exp_Ch3 is
end if;
end if;
-- When the object is either protected or a task, create static strings
-- which denote the names of entries and families. Associate the strings
-- with the concurrent object's Protection_Entries or ATCB. This is a
-- VMS Debug feature.
if OpenVMS_On_Target
and then Is_Concurrent_Type (Typ)
and then Entry_Names_OK
then
Build_Entry_Names (Id_Ref, Typ, Res);
end if;
return Res;
exception
@ -7212,8 +7200,8 @@ package body Exp_Ch3 is
-- All anonymous access-to-controlled types allocate
-- on the global pool.
Set_Associated_Storage_Pool (Comp_Typ,
Get_Global_Pool_For_Access_Type (Comp_Typ));
Set_Associated_Storage_Pool
(Comp_Typ, RTE (RE_Global_Pool_Object));
Build_Finalization_Master
(Typ => Comp_Typ,
@ -7229,8 +7217,8 @@ package body Exp_Ch3 is
-- All anonymous access-to-controlled types allocate
-- on the global pool.
Set_Associated_Storage_Pool (Comp_Typ,
Get_Global_Pool_For_Access_Type (Comp_Typ));
Set_Associated_Storage_Pool
(Comp_Typ, RTE (RE_Global_Pool_Object));
-- Shared the master among multiple components

70
gcc/ada/exp_ch4.adb
View file

@ -4313,11 +4313,11 @@ package body Exp_Ch4 is
if No (Associated_Storage_Pool (PtrT)) and then VM_Target = No_VM then
if Present (Rel_Typ) then
Set_Associated_Storage_Pool (PtrT,
Associated_Storage_Pool (Rel_Typ));
Set_Associated_Storage_Pool
(PtrT, Associated_Storage_Pool (Rel_Typ));
else
Set_Associated_Storage_Pool (PtrT,
Get_Global_Pool_For_Access_Type (PtrT));
Set_Associated_Storage_Pool
(PtrT, RTE (RE_Global_Pool_Object));
end if;
end if;
@ -8537,17 +8537,18 @@ package body Exp_Ch4 is
---------------------
-- If the argument is other than a Boolean array type, there is no special
-- expansion required, except for VMS operations on signed integers.
-- expansion required, except for dealing with validity checks, and non-
-- standard boolean representations.
-- For the packed case, we call the special routine in Exp_Pakd, except
-- that if the component size is greater than one, we use the standard
-- routine generating a gruesome loop (it is so peculiar to have packed
-- arrays with non-standard Boolean representations anyway, so it does not
-- matter that we do not handle this case efficiently).
-- For the packed array case, we call the special routine in Exp_Pakd,
-- except that if the component size is greater than one, we use the
-- standard routine generating a gruesome loop (it is so peculiar to have
-- packed arrays with non-standard Boolean representations anyway, so it
-- does not matter that we do not handle this case efficiently).
-- For the unpacked case (and for the special packed case where we have non
-- standard Booleans, as discussed above), we generate and insert into the
-- tree the following function definition:
-- For the unpacked array case (and for the special packed case where we
-- have non standard Booleans, as discussed above), we generate and insert
-- into the tree the following function definition:
-- function Nnnn (A : arr) is
-- B : arr;
@ -8587,49 +8588,6 @@ package body Exp_Ch4 is
return;
end if;
-- For the VMS "not" on signed integer types, use conversion to and from
-- a predefined modular type.
if Is_VMS_Operator (Entity (N)) then
declare
Rtyp : Entity_Id;
Utyp : Entity_Id;
begin
-- If this is a derived type, retrieve original VMS type so that
-- the proper sized type is used for intermediate values.
if Is_Derived_Type (Typ) then
Rtyp := First_Subtype (Etype (Typ));
else
Rtyp := Typ;
end if;
-- The proper unsigned type must have a size compatible with the
-- operand, to prevent misalignment.
if RM_Size (Rtyp) <= 8 then
Utyp := RTE (RE_Unsigned_8);
elsif RM_Size (Rtyp) <= 16 then
Utyp := RTE (RE_Unsigned_16);
elsif RM_Size (Rtyp) = RM_Size (Standard_Unsigned) then
Utyp := RTE (RE_Unsigned_32);
else
Utyp := RTE (RE_Long_Long_Unsigned);
end if;
Rewrite (N,
Unchecked_Convert_To (Typ,
Make_Op_Not (Loc,
Unchecked_Convert_To (Utyp, Right_Opnd (N)))));
Analyze_And_Resolve (N, Typ);
return;
end;
end if;
-- Only array types need any other processing
if not Is_Array_Type (Typ) then

21
gcc/ada/exp_ch7.adb
View file

@ -936,7 +936,7 @@ package body Exp_Ch7 is
-- The default choice is the global pool
else
Pool_Id := Get_Global_Pool_For_Access_Type (Ptr_Typ);
Pool_Id := RTE (RE_Global_Pool_Object);
Set_Associated_Storage_Pool (Ptr_Typ, Pool_Id);
end if;
@ -4486,25 +4486,6 @@ package body Exp_Ch7 is
end loop;
end Find_Node_To_Be_Wrapped;
-------------------------------------
-- Get_Global_Pool_For_Access_Type --
-------------------------------------
function Get_Global_Pool_For_Access_Type (T : Entity_Id) return Entity_Id is
begin
-- Access types whose size is smaller than System.Address size can exist
-- only on VMS. We can't use the usual global pool which returns an
-- object of type Address as truncation will make it invalid. To handle
-- this case, VMS has a dedicated global pool that returns addresses
-- that fit into 32 bit accesses.
if Opt.True_VMS_Target and then Esize (T) = 32 then
return RTE (RE_Global_Pool_32_Object);
else
return RTE (RE_Global_Pool_Object);
end if;
end Get_Global_Pool_For_Access_Type;
----------------------------------
-- Has_New_Controlled_Component --
----------------------------------

5
gcc/ada/exp_ch7.ads
View file

@ -151,11 +151,6 @@ package Exp_Ch7 is
-- when pragma Restrictions (No_Finalization) applies, in which case we
-- know that class-wide objects do not contain controlled parts.
function Get_Global_Pool_For_Access_Type (T : Entity_Id) return Entity_Id;
-- Return the pool id for access type T. This is generally the node
-- corresponding to System.Global_Pool.Global_Pool_Object except on
-- VMS if the access size is 32.
function Has_New_Controlled_Component (E : Entity_Id) return Boolean;
-- E is a type entity. Give the same result as Has_Controlled_Component
-- except for tagged extensions where the result is True only if the

6
gcc/ada/fname-uf.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -30,7 +30,6 @@ with Krunch;
with Opt; use Opt;
with Osint; use Osint;
with Table;
with Targparm; use Targparm;
with Uname; use Uname;
with Widechar; use Widechar;
@ -410,8 +409,7 @@ package body Fname.UF is
(Name_Buffer,
Name_Len,
Integer (Maximum_File_Name_Length),
Debug_Flag_4,
OpenVMS_On_Target);
Debug_Flag_4);
-- Replace extension

12
gcc/ada/fname.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -30,9 +30,8 @@
------------------------------------------------------------------------------
with Alloc;
with Hostparm; use Hostparm;
with Table;
with Types; use Types;
with Types; use Types;
package body Fname is
@ -78,13 +77,6 @@ package body Fname is
then
return True;
elsif OpenVMS
and then
(Name_Buffer (1 .. 4) = "dec-"
or else Name_Buffer (1 .. 8) = "dec ")
then
return True;
else
return False;
end if;

5
gcc/ada/fname.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -83,8 +83,7 @@ package Fname is
(Fname : File_Name_Type;
Renamings_Included : Boolean := True) return Boolean;
-- Similar to Is_Predefined_File_Name. The internal file set is a superset
-- of the predefined file set including children of GNAT, and also children
-- of DEC for the VMS case.
-- of the predefined file set including children of GNAT.
procedure Tree_Read;
-- Dummy procedure (reads dummy table values from tree file)

44
gcc/ada/freeze.adb
View file

@ -7038,11 +7038,7 @@ package body Freeze is
else
Set_Mechanisms (E);
-- For foreign conventions, warn about return of an
-- unconstrained array.
-- Note: we *do* allow a return by descriptor for the VMS case,
-- though here there is probably more to be done ???
-- For foreign conventions, warn about return of unconstrained array
if Ekind (E) = E_Function then
Retype := Underlying_Type (Etype (E));
@ -7065,11 +7061,6 @@ package body Freeze is
elsif Is_Array_Type (Retype)
and then not Is_Constrained (Retype)
-- Exclude cases where descriptor mechanism is set, since the
-- VMS descriptor mechanisms allow such unconstrained returns.
and then Mechanism (E) not in Descriptor_Codes
-- Check appropriate warning is enabled (should we check for
-- Warnings (Off) on specific entities here, probably so???)
@ -7107,39 +7098,6 @@ package body Freeze is
end if;
end if;
-- For VMS, descriptor mechanisms for parameters are allowed only for
-- imported/exported subprograms. Moreover, the NCA descriptor is not
-- allowed for parameters of exported subprograms.
if OpenVMS_On_Target then
if Is_Exported (E) then
F := First_Formal (E);
while Present (F) loop
if Mechanism (F) = By_Descriptor_NCA then
Error_Msg_N
("'N'C'A' descriptor for parameter not permitted", F);
Error_Msg_N
("\can only be used for imported subprogram", F);
end if;
Next_Formal (F);
end loop;
elsif not Is_Imported (E) then
F := First_Formal (E);
while Present (F) loop
if Mechanism (F) in Descriptor_Codes then
Error_Msg_N
("descriptor mechanism for parameter not permitted", F);
Error_Msg_N
("\can only be used for imported/exported subprogram", F);
end if;
Next_Formal (F);
end loop;
end if;
end if;
-- Pragma Inline_Always is disallowed for dispatching subprograms
-- because the address of such subprograms is saved in the dispatch
-- table to support dispatching calls, and dispatching calls cannot

4
gcc/ada/g-debpoo.adb
View file

@ -305,8 +305,8 @@ package body GNAT.Debug_Pools is
Code_Address_For_Deallocate_End : System.Address;
Code_Address_For_Dereference_End : System.Address;
-- Taking the address of the above procedures will not work on some
-- architectures (HPUX and VMS for instance). Thus we do the same thing
-- that is done in a-except.adb, and get the address of labels instead
-- architectures (HPUX for instance). Thus we do the same thing that
-- is done in a-except.adb, and get the address of labels instead.
procedure Skip_Levels
(Depth : Natural;

53
gcc/ada/g-dirope.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1998-2010, AdaCore --
-- Copyright (C) 1998-2014, AdaCore --
-- --
-- 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- --
@ -37,10 +37,6 @@
-- See also child package GNAT.Directory_Operations.Iteration
-- Note: support on OpenVMS is limited to the support of Unix-style
-- directory names (OpenVMS native directory format is not supported).
-- Read individual entries for more specific notes on OpenVMS support.
with System;
with Ada.Strings.Maps;
@ -54,8 +50,6 @@ package GNAT.Directory_Operations is
-- '\' character. It can also include drive letters if the operating
-- system provides for this. The final '/' or '\' in a Dir_Name_Str is
-- optional when passed as a procedure or function in parameter.
-- On OpenVMS, only Unix style path names are supported, not VMS style,
-- but the directory and file names are not case sensitive.
type Dir_Type is limited private;
-- A value used to reference a directory. Conceptually this value includes
@ -117,7 +111,7 @@ package GNAT.Directory_Operations is
-- returned. Note that the contents of Path is case-sensitive on
-- systems that have case-sensitive file names (like Unix), and
-- non-case-sensitive on systems where the file system is also non-
-- case-sensitive (such as Windows, and OpenVMS).
-- case-sensitive (such as Windows).
function Base_Name
(Path : Path_Name;
@ -133,8 +127,8 @@ package GNAT.Directory_Operations is
-- 'Path' and 'Dir_Name (Path) & Dir_Separator & Base_Name (Path)'
-- represent the same file.
--
-- The comparison of Suffix is case-insensitive on systems such as Windows
-- and VMS where the file search is case-insensitive (e.g. on such systems,
-- The comparison of Suffix is case-insensitive on systems like Windows
-- where the file search is case-insensitive (e.g. on such systems,
-- Base_Name ("/Users/AdaCore/BB12.patch", ".Patch") returns "BB12").
--
-- Note that the index bounds of the result match the corresponding indexes
@ -165,12 +159,11 @@ package GNAT.Directory_Operations is
--
-- The Style argument indicates the syntax to be used for path names:
--
-- UNIX
-- Use '/' as the directory separator. The default on Unix systems
-- and on OpenVMS.
--
-- DOS
-- Use '\' as the directory separator. The default on Windows.
-- Use '\' as the directory separator (default on Windows)
--
-- UNIX
-- Use '/' as the directory separator (default on all other systems)
--
-- System_Default
-- Use the default style for the current system
@ -179,24 +172,24 @@ package GNAT.Directory_Operations is
function Expand_Path
(Path : Path_Name;
Mode : Environment_Style := System_Default) return Path_Name;
-- Returns Path with environment variables (or logical names on OpenVMS)
-- replaced by the current environment variable value. For example,
-- $HOME/mydir will be replaced by /home/joe/mydir if $HOME environment
-- variable is set to /home/joe and Mode is UNIX. If an environment
-- variable does not exists the variable will be replaced by the empty
-- string. Two dollar or percent signs are replaced by a single
-- dollar/percent sign. Note that a variable must start with a letter.
-- Returns Path with environment variables replaced by the current
-- environment variable value. For example, $HOME/mydir will be replaced
-- by /home/joe/mydir if $HOME environment variable is set to /home/joe and
-- Mode is UNIX. If an environment variable does not exists the variable
-- will be replaced by the empty string. Two dollar or percent signs are
-- replaced by a single dollar/percent sign. Note that a variable must
-- start with a letter.
--
-- The Mode argument indicates the recognized syntax for environment
-- variables as follows:
--
-- UNIX
-- Environment variables and OpenVMS logical names use $ as prefix and
-- can use curly brackets as in ${HOME}/mydir. If there is no closing
-- curly bracket for an opening one then no translation is done, so for
-- example ${VAR/toto is returned as ${VAR/toto. The use of {} brackets
-- is required if the environment variable name contains other than
-- alphanumeric characters.
-- Environment variables use $ as prefix and can use curly brackets
-- as in ${HOME}/mydir. If there is no closing curly bracket for an
-- opening one then no translation is done, so for example ${VAR/toto
-- is returned as ${VAR/toto. The use of {} brackets is required if
-- the environment variable name contains other than alphanumeric
-- characters.
--
-- DOS
-- Environment variables uses % as prefix and suffix (e.g. %HOME%/dir).
@ -207,8 +200,8 @@ package GNAT.Directory_Operations is
-- Recognize both forms described above.
--
-- System_Default
-- Uses either UNIX on Unix and OpenVMS systems, or DOS on Windows,
-- depending on the running environment. What about other OS's???
-- Uses either DOS on Windows, and UNIX on all other systems, depending
-- on the running environment.
---------------
-- Iterators --

8
gcc/ada/g-excact.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2012, Free Software Foundation, Inc. --
-- Copyright (C) 2002-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- --
@ -111,8 +111,8 @@ package GNAT.Exception_Actions is
procedure Core_Dump (Occurrence : Exception_Occurrence);
-- Dump memory (called a core dump in some systems) if supported by the
-- OS (most unix systems and VMS), and abort execution of the application.
-- Under Windows this procedure will not dump the memory, it will only
-- abort execution.
-- OS (most unix systems), and abort execution of the application. Under
-- Windows this procedure will not dump the memory, it will only abort
-- execution.
end GNAT.Exception_Actions;

8
gcc/ada/g-expect.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2000-2010, AdaCore --
-- Copyright (C) 2000-2014, AdaCore --
-- --
-- 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- --
@ -29,9 +29,9 @@
-- --
------------------------------------------------------------------------------
-- Currently this package is implemented on all native GNAT ports except
-- for VMS. It is not yet implemented for any of the cross-ports (e.g. it
-- is not available for VxWorks or LynxOS).
-- Currently this package is implemented on all native GNAT ports. It is not
-- yet implemented for any of the cross-ports (e.g. it is not available for
-- VxWorks or LynxOS).
-- -----------
-- -- Usage --

3
gcc/ada/g-socket.adb
View file

@ -172,8 +172,7 @@ package body GNAT.Sockets is
-- Conversion function
function Value (S : System.Address) return String;
-- Same as Interfaces.C.Strings.Value but taking a System.Address (on VMS,
-- chars_ptr is a 32-bit pointer, and here we need a 64-bit version).
-- Same as Interfaces.C.Strings.Value but taking a System.Address
function To_Timeval (Val : Timeval_Duration) return Timeval;
-- Separate Val in seconds and microseconds

3
gcc/ada/g-socket.ads
View file

@ -39,9 +39,6 @@
-- feature, so it is not available if Multicast is not supported, or not
-- installed.
-- The VMS implementation was implemented using the DECC RTL Socket API,
-- and is thus subject to limitations in the implementation of this API.
-- VxWorks cross ports fully implement this package
-- This package is not yet implemented on LynxOS or other cross ports

7
gcc/ada/g-sothco.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2008-2012, AdaCore --
-- Copyright (C) 2008-2014, AdaCore --
-- --
-- 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- --
@ -212,11 +212,6 @@ package GNAT.Sockets.Thin_Common is
pragma Convention (C, Hostent_Access);
-- Access to host entry
-- Note: the hostent and servent accessors that return char*
-- values are compiled with GCC, and on VMS they always return
-- 64-bit pointers, so we can't use C.Strings.chars_ptr, which
-- on VMS is 32 bits.
function Hostent_H_Name
(E : Hostent_Access) return System.Address;

4
gcc/ada/g-traceb.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1999-2012, AdaCore --
-- Copyright (C) 1999-2014, AdaCore --
-- --
-- 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- --
@ -63,8 +63,6 @@
-- LynxOS x86
-- Solaris x86
-- Solaris sparc
-- OpenVMS/Alpha
-- OpenVMS/ia64
-- VxWorks PowerPC
-- VxWorks x86
-- Windows NT/XP

56
gcc/ada/gnat_rm.texi
View file

@ -3633,10 +3633,6 @@ MECHANISM_ASSOCIATION ::=
MECHANISM_NAME ::=
Value
| Reference
| Descriptor [([Class =>] CLASS_NAME)]
| Short_Descriptor [([Class =>] CLASS_NAME)]
CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
@end smallexample
@noindent
@ -3665,21 +3661,6 @@ parameter by parameter basis using either positional or named
notation. If the mechanism is not specified, the default mechanism
is used.
@cindex OpenVMS
@cindex Passing by descriptor
Passing by descriptor is supported only on the OpenVMS ports of GNAT@.
The default behavior for Import_Function is to pass a 64bit descriptor
unless short_descriptor is specified, then a 32bit descriptor is passed.
@code{First_Optional_Parameter} applies only to OpenVMS ports of GNAT@.
It specifies that the designated parameter and all following parameters
are optional, meaning that they are not passed at the generated code
level (this is distinct from the notion of optional parameters in Ada
where the parameters are passed anyway with the designated optional
parameters). All optional parameters must be of mode @code{IN} and have
default parameter values that are either known at compile time
expressions, or uses of the @code{'Null_Parameter} attribute.
@node Pragma Import_Object
@unnumberedsec Pragma Import_Object
@findex Import_Object
@ -3739,13 +3720,7 @@ MECHANISM ::=
MECHANISM_ASSOCIATION ::=
[formal_parameter_NAME =>] MECHANISM_NAME
MECHANISM_NAME ::=
Value
| Reference
| Descriptor [([Class =>] CLASS_NAME)]
| Short_Descriptor [([Class =>] CLASS_NAME)]
CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
MECHANISM_NAME ::= Value | Reference
@end smallexample
@noindent
@ -3786,14 +3761,7 @@ MECHANISM ::=
MECHANISM_ASSOCIATION ::=
[formal_parameter_NAME =>] MECHANISM_NAME
MECHANISM_NAME ::=
Value
| Reference
| Descriptor [([Class =>] CLASS_NAME)]
| Short_Descriptor [([Class =>] CLASS_NAME)]
CLASS_NAME ::= ubs | ubsb | uba | s | sb | a | nca
@end smallexample
MECHANISM_NAME ::= Value | Reference
@noindent
This pragma is identical to @code{Import_Procedure} except that the
@ -9260,28 +9228,8 @@ meaning the first parameter) of @var{subprogram}. The code returned is:
by copy (value)
@item 2
by reference
@item 3
by descriptor (default descriptor class)
@item 4
by descriptor (UBS: unaligned bit string)
@item 5
by descriptor (UBSB: aligned bit string with arbitrary bounds)
@item 6
by descriptor (UBA: unaligned bit array)
@item 7
by descriptor (S: string, also scalar access type parameter)
@item 8
by descriptor (SB: string with arbitrary bounds)
@item 9
by descriptor (A: contiguous array)
@item 10
by descriptor (NCA: non-contiguous array)
@end table
@noindent
Values from 3 through 10 are only relevant to Digital OpenVMS implementations.
@cindex OpenVMS
@node Attribute Null_Parameter
@unnumberedsec Attribute Null_Parameter
@cindex Zero address, passing

22
gcc/ada/gnatlink.adb
View file

@ -630,8 +630,7 @@ procedure Gnatlink is
Linker_Objects.Table (Linker_Objects.Last) :=
new String'(Arg);
-- If host object file, record object file e.g. accept foo.o
-- as well as foo.obj on VMS target.
-- If host object file, record object file
elsif Arg'Length > Get_Object_Suffix.all'Length
and then Arg
@ -730,18 +729,17 @@ procedure Gnatlink is
-- Save state of -shared option
Xlinker_Was_Previous : Boolean := False;
-- Indicate that "-Xlinker" was the option preceding the current
-- option. If True, then the current option is never suppressed.
-- Indicate that "-Xlinker" was the option preceding the current option.
-- If True, then the current option is never suppressed.
-- Rollback data
-- These data items are used to store current binder file context.
-- The context is composed of the file descriptor position and the
-- current line together with the slice indexes (first and last
-- position) for this line. The rollback data are used by the
-- Store_File_Context and Rollback_File_Context routines below.
-- The file context mechanism interact only with the Get_Next_Line
-- call. For example:
-- These data items are used to store current binder file context. The
-- context is composed of the file descriptor position and the current
-- line together with the slice indexes (first and last position) for
-- this line. The rollback data are used by the Store_File_Context and
-- Rollback_File_Context routines below. The file context mechanism
-- interact only with the Get_Next_Line call. For example:
-- Store_File_Context;
-- Get_Next_Line;
@ -772,7 +770,7 @@ procedure Gnatlink is
pragma Import
(C, Object_Library_Ext_Ptr, "__gnat_object_library_extension");
-- Pointer to string specifying the default extension for
-- object libraries, e.g. Unix uses ".a", VMS uses ".olb".
-- object libraries, e.g. Unix uses ".a".
Separate_Run_Path_Options : Boolean;
for Separate_Run_Path_Options'Size use Character'Size;

2
gcc/ada/gnatls.adb
View file

@ -1627,7 +1627,7 @@ begin
Osint.Add_Default_Search_Dirs;
-- Get the target parameters, but only if switch -nostdinc was not
-- specified. Likely not strictly needed now that VMS is baselined???
-- specified. May not be needed any more, but is harmless.
if not Opt.No_Stdinc then
Get_Target_Parameters;

6
gcc/ada/i-cstrea.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1996-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- --
@ -29,10 +29,6 @@
-- --
------------------------------------------------------------------------------
-- This is the default version which just calls the C versions directly
-- Note: the reason that we provide for specialization here is that on
-- some systems, notably VMS, we may need to worry about buffering.
with Ada.Unchecked_Conversion;
package body Interfaces.C_Streams is

29
gcc/ada/krunch.adb
View file

@ -33,9 +33,7 @@ procedure Krunch
(Buffer : in out String;
Len : in out Natural;
Maxlen : Natural;
No_Predef : Boolean;
VMS_On_Target : Boolean := False)
No_Predef : Boolean)
is
pragma Assert (Buffer'First = 1);
-- This is a documented requirement; the assert turns off index warnings
@ -118,34 +116,15 @@ begin
-- Special case of a child unit whose parent unit is a single letter that
-- is A, G, I, or S. In order to prevent confusion with krunched names
-- of predefined units use a tilde rather than a minus as the second
-- character of the file name. On VMS a tilde is an illegal character
-- in a file name, two consecutive underlines ("__") are used instead.
-- character of the file name.
elsif Len > 1
and then Buffer (2) = '-'
and then (B1 = 'a' or else B1 = 'g' or else B1 = 'i' or else B1 = 's')
and then Len <= Maxlen
then
if VMS_On_Target then
Len := Len + 1;
Buffer (4 .. Len) := Buffer (3 .. Len - 1);
Buffer (2) := '_';
Buffer (3) := '_';
else
Buffer (2) := '~';
end if;
if Len <= Maxlen then
return;
else
-- Case of VMS when the buffer had exactly the length Maxlen and now
-- has the length Maxlen + 1: krunching after "__" is needed.
Startloc := 4;
Curlen := Len;
Krlen := Maxlen;
end if;
Buffer (2) := '~';
return;
-- Normal case, not a predefined file

7
gcc/ada/krunch.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -121,8 +121,7 @@ procedure Krunch
(Buffer : in out String;
Len : in out Natural;
Maxlen : Natural;
No_Predef : Boolean;
VMS_On_Target : Boolean := False);
No_Predef : Boolean);
pragma Elaborate_Body (Krunch);
-- The full file name is stored in Buffer (1 .. Len) on entry. The file
-- name is crunched in place and on return Len is updated, so that the
@ -131,8 +130,6 @@ pragma Elaborate_Body (Krunch);
-- case it may be possible that Krunch does not modify Buffer. The fourth
-- parameter, No_Predef, is a switch which, if set to True, disables the
-- normal special treatment of predefined library unit file names.
-- VMS_On_Target, when True, indicates to Krunch to apply the VMS treatment
-- to the children of package A, G,I or S.
--
-- Note: the string Buffer must have a lower bound of 1, and may not
-- contain any blanks (in particular, it must not have leading blanks).

28
gcc/ada/layout.adb
View file

@ -2526,31 +2526,6 @@ package body Layout is
Init_Size (E, System_Address_Size);
end if;
-- On VMS, reset size to 32 for convention C access type if no
-- explicit size clause is given and the default size is 64. Really
-- we do not know the size, since depending on options for the VMS
-- compiler, the size of a pointer type can be 32 or 64, but choosing
-- 32 as the default improves compatibility with legacy VMS code.
-- Note: we do not use Has_Size_Clause in the test below, because we
-- want to catch the case of a derived type inheriting a size clause.
-- We want to consider this to be an explicit size clause for this
-- purpose, since it would be weird not to inherit the size in this
-- case.
-- We do NOT do this if we are in -gnatdm mode on a non-VMS target
-- since in that case we want the normal pointer representation.
if Opt.True_VMS_Target
and then (Convention (E) = Convention_C
or else
Convention (E) = Convention_CPP)
and then No (Get_Attribute_Definition_Clause (E, Attribute_Size))
and then Esize (E) = 64
then
Init_Size (E, 32);
end if;
Set_Elem_Alignment (E);
-- Scalar types: set size and alignment
@ -3022,8 +2997,7 @@ package body Layout is
-- If Optimize_Alignment is set to Time, then we reset for odd
-- "in between sizes", for example a 17 bit record is given an
-- alignment of 4. Note that this matches the old VMS behavior
-- in versions of GNAT prior to 6.1.1.
-- alignment of 4.
elsif Optimize_Alignment_Time (E)
and then Siz > System_Storage_Unit

7
gcc/ada/lib-util.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -100,10 +100,9 @@ package body Lib.Util is
procedure Write_Info_EOL is
begin
if Hostparm.OpenVMS
or else Info_Buffer_Len + Max_Line + 1 > Max_Buffer
then
if Info_Buffer_Len + Max_Line + 1 > Max_Buffer then
Write_Info_Terminate;
else
-- Delete any trailing blanks

99
gcc/ada/make.adb
View file

@ -2626,65 +2626,58 @@ package body Make is
Data := No_Compilation_Data;
OK := False;
-- The loop here is a work-around for a problem on VMS; in some
-- circumstances (shared library and several executables, for
-- example), there are child processes other than compilation
-- processes that are received. ??? Revisit now that VMS is no
-- longer supported.
Wait_Process (Pid, OK);
loop
Wait_Process (Pid, OK);
if Pid = Invalid_Pid then
return;
end if;
if Pid = Invalid_Pid then
return;
end if;
-- Look into the running compilation processes for this PID
for J in Running_Compile'First .. Outstanding_Compiles loop
if Pid = Running_Compile (J).Pid then
Data := Running_Compile (J);
Project := Running_Compile (J).Project;
for J in Running_Compile'First .. Outstanding_Compiles loop
if Pid = Running_Compile (J).Pid then
Data := Running_Compile (J);
Project := Running_Compile (J).Project;
if Project /= No_Project then
Queue.Set_Obj_Dir_Free (Project.Object_Directory.Name);
end if;
-- If a mapping file was used by this compilation, get its
-- file name for reuse by a subsequent compilation.
if Running_Compile (J).Mapping_File /= No_Mapping_File then
Comp_Data :=
Project_Compilation_Htable.Get
(Project_Compilation, Project);
Comp_Data.Last_Free_Indexes :=
Comp_Data.Last_Free_Indexes + 1;
Comp_Data.Free_Mapping_File_Indexes
(Comp_Data.Last_Free_Indexes) :=
Running_Compile (J).Mapping_File;
end if;
-- To actually remove this Pid and related info from
-- Running_Compile replace its entry with the last valid
-- entry in Running_Compile.
if J = Outstanding_Compiles then
null;
else
Running_Compile (J) :=
Running_Compile (Outstanding_Compiles);
end if;
Outstanding_Compiles := Outstanding_Compiles - 1;
return;
if Project /= No_Project then
Queue.Set_Obj_Dir_Free (Project.Object_Directory.Name);
end if;
end loop;
-- This child process was not one of our compilation processes;
-- just ignore it for now.
-- If a mapping file was used by this compilation, get its file
-- name for reuse by a subsequent compilation.
-- Why is this commented out code sitting here???
if Running_Compile (J).Mapping_File /= No_Mapping_File then
Comp_Data :=
Project_Compilation_Htable.Get
(Project_Compilation, Project);
Comp_Data.Last_Free_Indexes :=
Comp_Data.Last_Free_Indexes + 1;
Comp_Data.Free_Mapping_File_Indexes
(Comp_Data.Last_Free_Indexes) :=
Running_Compile (J).Mapping_File;
end if;
-- raise Program_Error;
-- To actually remove this Pid and related info from
-- Running_Compile replace its entry with the last valid
-- entry in Running_Compile.
if J = Outstanding_Compiles then
null;
else
Running_Compile (J) :=
Running_Compile (Outstanding_Compiles);
end if;
Outstanding_Compiles := Outstanding_Compiles - 1;
exit;
end if;
end loop;
-- If the PID was not found, return with OK set to False
if Data = No_Compilation_Data then
OK := False;
end if;
end Await_Compile;
---------------------------
@ -4638,11 +4631,13 @@ package body Make is
Library_Projs.Table (Current) := Proj;
end Add_To_Library_Projs;
-- Start of processing for Library_Phase
begin
Library_Projs.Init;
-- Put in Library_Projs table all library project file
-- ids when the library need to be rebuilt.
-- Put in Library_Projs table all library project file ids when the
-- library need to be rebuilt.
Proj1 := Project_Tree.Projects;
while Proj1 /= null loop

7
gcc/ada/mlib.adb
View file

@ -205,8 +205,11 @@ package body MLib is
S := new String (1 .. Len + 3);
-- Read the file. Note that the loop is not necessary
-- since the whole file is read at once except on VMS.
-- Read the file. This loop is probably not necessary
-- since on most (all?) targets, the whole file is
-- read in at once, but we have encountered systems
-- in the past where this was not true, and we retain
-- this loop in case we encounter that in the future.
Curr := S'First;
while Curr <= Len loop

40
gcc/ada/osint-b.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2001-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- --
@ -25,7 +25,6 @@
with Opt; use Opt;
with Output; use Output;
with Targparm; use Targparm;
package body Osint.B is
@ -75,9 +74,8 @@ package body Osint.B is
Findex2 : Natural;
Flength : Natural;
Bind_File_Prefix_Len : Natural := 2;
-- Length of binder file prefix (normally set to 2 for b~, but gets
-- reset to 3 for VMS for b__).
Bind_File_Prefix_Len : constant Natural := 2;
-- Length of binder file prefix (2 for b~)
begin
if Output_File_Name /= "" then
@ -120,10 +118,6 @@ package body Osint.B is
if Maximum_File_Name_Length > 0 then
if OpenVMS_On_Target and then Typ /= 'c' then
Bind_File_Prefix_Len := 3;
end if;
-- Make room for the extra two characters in "b?"
while Int (Flength) >
@ -139,31 +133,15 @@ package body Osint.B is
File_Name (Findex1 .. Findex2 - 1);
Name_Buffer (Flength + Bind_File_Prefix_Len + 1) := '.';
-- C bind file, name is b_xxx.c
if Typ = 'c' then
Name_Buffer (2) := '_';
Name_Buffer (Flength + 4) := 'c';
Name_Buffer (Flength + 5) := ASCII.NUL;
Name_Len := Flength + 4;
-- Ada bind file, name is b~xxx.adb or b~xxx.ads
-- (with __ instead of ~ in VMS)
else
if OpenVMS_On_Target then
Name_Buffer (2) := '_';
Name_Buffer (3) := '_';
else
Name_Buffer (2) := '~';
end if;
Name_Buffer (2) := '~';
Name_Buffer (Flength + Bind_File_Prefix_Len + 2) := 'a';
Name_Buffer (Flength + Bind_File_Prefix_Len + 3) := 'd';
Name_Buffer (Flength + Bind_File_Prefix_Len + 4) := Typ;
Name_Buffer (Flength + Bind_File_Prefix_Len + 5) := ASCII.NUL;
Name_Len := Flength + Bind_File_Prefix_Len + 4;
end if;
Name_Buffer (Flength + Bind_File_Prefix_Len + 2) := 'a';
Name_Buffer (Flength + Bind_File_Prefix_Len + 3) := 'd';
Name_Buffer (Flength + Bind_File_Prefix_Len + 4) := Typ;
Name_Buffer (Flength + Bind_File_Prefix_Len + 5) := ASCII.NUL;
Name_Len := Flength + Bind_File_Prefix_Len + 4;
end if;
Bfile := Name_Find;

10
gcc/ada/osint-b.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2010, Free Software Foundation, Inc. --
-- Copyright (C) 2001-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- --
@ -44,17 +44,15 @@ package Osint.B is
-- Binder Output --
-------------------
-- These routines are used by the binder to generate the C or Ada source
-- files containing the binder output. The format of these files is
-- described in package Bindgen.
-- These routines are used by the binder to generate the Ada source files
-- containing the binder output. The format of these files is described in
-- package Bindgen.
procedure Create_Binder_Output
(Output_File_Name : String;
Typ : Character;
Bfile : out Name_Id);
-- Creates the binder output file. Typ is one of
--
-- 'c' create output file for case of generating C
-- 'b' create body file for case of generating Ada
-- 's' create spec file for case of generating Ada
--

12
gcc/ada/osint-c.adb
View file

@ -23,9 +23,8 @@
-- --
------------------------------------------------------------------------------
with Hostparm;
with Opt; use Opt;
with Tree_IO; use Tree_IO;
with Opt; use Opt;
with Tree_IO; use Tree_IO;
package body Osint.C is
@ -127,12 +126,7 @@ package body Osint.C is
begin
Get_Name_String (Src);
if Hostparm.OpenVMS then
Name_Buffer (Name_Len + 1) := '_';
else
Name_Buffer (Name_Len + 1) := '.';
end if;
Name_Buffer (Name_Len + 1) := '.';
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
Name_Len := Name_Len + Suffix'Length;

88
gcc/ada/osint.adb
View file

@ -365,8 +365,9 @@ package body Osint is
S := new String (1 .. Len);
-- Read the file. Note that the loop is not necessary since the
-- whole file is read at once except on VMS.
-- Read the file. Note that the loop is probably not necessary any
-- more since the whole file is read in at once on all targets. But
-- it is harmless and might be needed in future.
Curr := 1;
Actual_Len := Len;
@ -473,31 +474,21 @@ package body Osint is
Get_Dirs_From_File (Additional_Source_Dir => False);
end if;
-- On VMS, don't expand the logical name (e.g. environment variable),
-- just put it into Unix (e.g. canonical) format. System services
-- will handle the expansion as part of the file processing.
-- Put path name in canonical form
for Additional_Source_Dir in False .. True loop
if Additional_Source_Dir then
Search_Path := Getenv (Ada_Include_Path);
if Search_Path'Length > 0 then
if Hostparm.OpenVMS then
Search_Path := To_Canonical_Path_Spec ("ADA_INCLUDE_PATH:");
else
Search_Path := To_Canonical_Path_Spec (Search_Path.all);
end if;
Search_Path := To_Canonical_Path_Spec (Search_Path.all);
end if;
else
Search_Path := Getenv (Ada_Objects_Path);
if Search_Path'Length > 0 then
if Hostparm.OpenVMS then
Search_Path := To_Canonical_Path_Spec ("ADA_OBJECTS_PATH:");
else
Search_Path := To_Canonical_Path_Spec (Search_Path.all);
end if;
Search_Path := To_Canonical_Path_Spec (Search_Path.all);
end if;
end if;
@ -512,9 +503,7 @@ package body Osint is
-- For the compiler, if --RTS= was specified, add the runtime
-- directories.
if RTS_Src_Path_Name /= null
and then RTS_Lib_Path_Name /= null
then
if RTS_Src_Path_Name /= null and then RTS_Lib_Path_Name /= null then
Add_Search_Dirs (RTS_Src_Path_Name, Include);
Add_Search_Dirs (RTS_Lib_Path_Name, Objects);
@ -853,13 +842,12 @@ package body Osint is
Buffer : String := Name_Buffer (1 .. Name_Len);
begin
-- Get the file name in canonical case to accept as is names
-- ending with ".EXE" on VMS and Windows.
-- Get the file name in canonical case to accept as is. Names
-- end with ".EXE" on Windows.
Canonical_Case_File_Name (Buffer);
-- If Executable does not end with the executable suffix, add
-- it.
-- If Executable doesn't end with the executable suffix, add it
if Buffer'Length <= Exec_Suffix'Length
or else
@ -1183,12 +1171,8 @@ package body Osint is
if T = Config
or else (Debug_Generated_Code
and then Name_Len > 3
and then
(Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg"
or else
(Hostparm.OpenVMS and then
Name_Buffer (Name_Len - 2 .. Name_Len) = "_dg")))
and then Name_Len > 3
and then Name_Buffer (Name_Len - 2 .. Name_Len) = ".dg")
then
Found := N;
Attr.all := Unknown_Attributes;
@ -1292,9 +1276,9 @@ package body Osint is
-- Command_Name(Cindex1 .. Cindex2) is now the equivalent of the
-- POSIX command "basename argv[0]"
-- Strip off any versioning information such as found on VMS.
-- This would take the form of TOOL.exe followed by a ";" or "."
-- and a sequence of one or more numbers.
-- Strip off any versioning information found on some systems. This
-- would take the form of TOOL.exe followed by a ";" or "." and a
-- sequence of one or more numbers.
if Command_Name (Cindex2) in '0' .. '9' then
for J in reverse Cindex1 .. Cindex2 loop
@ -1702,15 +1686,9 @@ package body Osint is
function Is_Directory_Separator (C : Character) return Boolean is
begin
-- In addition to the default directory_separator allow the '/' to
-- act as separator since this is allowed in MS-DOS, Windows 95/NT,
-- and OS2 ports. On VMS, the situation is more complicated because
-- there are two characters to check for.
-- act as separator since this is allowed in MS-DOS and Windows.
return
C = Directory_Separator
or else C = '/'
or else (Hostparm.OpenVMS
and then (C = ']' or else C = ':'));
return C = Directory_Separator or else C = '/';
end Is_Directory_Separator;
-------------------------
@ -2202,11 +2180,7 @@ package body Osint is
function Prep_Suffix return String is
begin
if Hostparm.OpenVMS then
return "_prep";
else
return ".prep";
end if;
return ".prep";
end Prep_Suffix;
------------------
@ -2344,8 +2318,9 @@ package body Osint is
S := new String (1 .. Len + 1);
S (Len + 1) := Path_Separator;
-- Read the file. Note that the loop is not necessary since the
-- whole file is read at once except on VMS.
-- Read the file. Note that the loop is probably not necessary since the
-- whole file is read at once but the loop is harmless and that way we
-- are sure to accomodate systems where this is not the case.
Curr := 1;
Actual_Len := Len;
@ -2565,9 +2540,9 @@ package body Osint is
Text := new Text_Buffer (Lo .. Hi);
-- Some systems (e.g. VMS) have file types that require one
-- read per line, so read until we get the Len bytes or until
-- there are no more characters.
-- Some systems have file types that require one read per line,
-- so read until we get the Len bytes or until there are no more
-- characters.
Hi := Lo;
loop
@ -2698,9 +2673,9 @@ package body Osint is
begin
-- Allocate source buffer, allowing extra character at end for EOF
-- Some systems (e.g. VMS) have file types that require one read per
-- line, so read until we get the Len bytes or until there are no
-- more characters.
-- Some systems have file types that require one read per line,
-- so read until we get the Len bytes or until there are no more
-- characters.
Hi := Lo;
loop
@ -2806,15 +2781,6 @@ package body Osint is
Library (3 .. 2 + Name'Length) := Name;
Library (3 + Name'Length) := '-';
Library (4 + Name'Length .. Library'Last) := Library_Version;
if OpenVMS_On_Target then
for K in Library'First + 2 .. Library'Last loop
if Library (K) = '.' or else Library (K) = '-' then
Library (K) := '_';
end if;
end loop;
end if;
return Library;
end Shared_Lib;

36
gcc/ada/osint.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -43,9 +43,9 @@ pragma Elaborate_All (System.OS_Lib);
package Osint is
Multi_Unit_Index_Character : Character := '~';
Multi_Unit_Index_Character : constant Character := '~';
-- The character before the index of the unit in a multi-unit source in ALI
-- and object file names. Changed to '$' on VMS.
-- and object file names.
Ada_Include_Path : constant String := "ADA_INCLUDE_PATH";
Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH";
@ -201,33 +201,27 @@ package Osint is
function To_Canonical_File_List
(Wildcard_Host_File : String;
Only_Dirs : Boolean) return String_Access_List_Access;
-- Expand a wildcard host syntax file or directory specification (e.g. on
-- a VMS host, any file or directory spec that contains: "*", or "%", or
-- "...") and return a list of valid Unix syntax file or directory specs.
-- If Only_Dirs is True, then only return directories.
-- Expand a wildcard host syntax file or directory specification and return
-- a list of valid Unix syntax file or directory specs. If Only_Dirs is
-- True, then only return directories.
function To_Canonical_Dir_Spec
(Host_Dir : String;
Prefix_Style : Boolean) return String_Access;
-- Convert a host syntax directory specification (e.g. on a VMS host:
-- "SYS$DEVICE:[DIR]") to canonical (Unix) syntax (e.g. "/sys$device/dir").
-- If Prefix_Style then make it a valid file specification prefix. A file
-- specification prefix is a directory specification that can be appended
-- with a simple file specification to yield a valid absolute or relative
-- path to a file. On a conversion to Unix syntax this simply means the
-- spec has a trailing slash ("/").
-- Convert a host syntax directory specification to canonical (Unix)
-- syntax. If Prefix_Style then make it a valid file specification prefix.
-- A file specification prefix is a directory specification that can be
-- appended with a simple file specification to yield a valid absolute
-- or relative path to a file. On a conversion to Unix syntax this simply
-- means the spec has a trailing slash ("/").
function To_Canonical_File_Spec
(Host_File : String) return String_Access;
-- Convert a host syntax file specification (e.g. on a VMS host:
-- "SYS$DEVICE:[DIR]FILE.EXT;69 to canonical (Unix) syntax (e.g.
-- "/sys$device/dir/file.ext.69").
-- Convert a host syntax file specification to canonical (Unix) syntax
function To_Canonical_Path_Spec
(Host_Path : String) return String_Access;
-- Convert a host syntax Path specification (e.g. on a VMS host:
-- "SYS$DEVICE:[BAR],DISK$USER:[FOO] to canonical (Unix) syntax (e.g.
-- "/sys$device/foo:disk$user/foo").
-- Convert a host syntax Path specification to canonical (Unix) syntax
function To_Host_Dir_Spec
(Canonical_Dir : String;
@ -254,7 +248,7 @@ package Osint is
-- Returns the runtime shared library in the form -l<name>-<version> where
-- version is the GNAT runtime library option for the platform. For example
-- this routine called with Name set to "gnat" will return "-lgnat-5.02"
-- on UNIX and Windows and -lgnat_5_02 on VMS.
-- on UNIX and Windows.
---------------------
-- File attributes --

9
gcc/ada/output.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -209,11 +209,8 @@ private
Buffer : String (1 .. Buffer_Max + 1) := (others => '*');
for Buffer'Alignment use 4;
-- Buffer used to build output line. We do line buffering because it
-- is needed for the support of the debug-generated-code option (-gnatD).
-- Historically it was first added because on VMS, line buffering is
-- needed with certain file formats. So in any case line buffering must
-- be retained for this purpose, even if other reasons disappear. Note
-- Buffer used to build output line. We do line buffering because it is
-- needed for the support of the debug-generated-code option (-gnatD). Note
-- any attempt to write more output to a line than can fit in the buffer
-- will be silently ignored. The alignment clause improves the efficiency
-- of the save/restore procedures.

4
gcc/ada/par.adb
View file

@ -1564,9 +1564,7 @@ begin
-- mode, check that language-defined units are compiled in GNAT
-- mode. For this purpose we do NOT consider renamings in annex
-- J as predefined. That allows users to compile their own
-- versions of these files, and in particular, in the VMS
-- implementation, the DEC versions can be substituted for the
-- standard Ada 95 versions. Another exception is System.RPC
-- versions of these files. Another exception is System.RPC
-- and its children. This allows a user to supply their own
-- communication layer.

11
gcc/ada/prj-conf.adb
View file

@ -23,7 +23,6 @@
-- --
------------------------------------------------------------------------------
with Hostparm;
with Makeutl; use Makeutl;
with MLib.Tgt;
with Opt; use Opt;
@ -1416,18 +1415,10 @@ package body Prj.Conf is
<<Process_Config_File>>
if Automatically_Generated then
if Hostparm.OpenVMS then
-- There is no gprconfig on VMS
Raise_Invalid_Config
("could not locate any configuration project file");
else
-- This might raise an Invalid_Config exception
-- This might raise an Invalid_Config exception
Do_Autoconf;
end if;
-- 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.

32
gcc/ada/prj-env.adb
View file

@ -24,7 +24,6 @@
------------------------------------------------------------------------------
with Fmap;
with Hostparm;
with Makeutl; use Makeutl;
with Opt;
with Osint; use Osint;
@ -1905,8 +1904,6 @@ package body Prj.Env is
Add_Default_Dir : Boolean := True;
First : Positive;
Last : Positive;
New_Len : Positive;
New_Last : Positive;
Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
Gpr_Project_Path : constant String := "GPR_PROJECT_PATH";
@ -2043,35 +2040,6 @@ package body Prj.Env is
-- directory correctly.
Last := Last - 1;
elsif not Hostparm.OpenVMS
or else not Is_Absolute_Path (Name_Buffer (First .. Last))
then
-- On VMS, only expand relative path names, as absolute paths
-- may correspond to multi-valued VMS logical names.
declare
New_Dir : constant String :=
Normalize_Pathname
(Name_Buffer (First .. Last),
Resolve_Links => Opt.Follow_Links_For_Dirs);
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;

18
gcc/ada/prj-makr.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2013, Free Software Foundation, Inc. --
-- Copyright (C) 2001-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- --
@ -24,7 +24,6 @@
------------------------------------------------------------------------------
with Csets;
with Hostparm;
with Makeutl; use Makeutl;
with Opt;
with Output;
@ -1058,11 +1057,9 @@ package body Prj.Makr is
Project_File_Extension;
Output_Name_Last := Output_Name_Last + Project_File_Extension'Length;
-- Back up project file if it already exists (not needed in VMS since
-- versioning of files takes care of this requirement on VMS).
-- Back up project file if it already exists
if not Hostparm.OpenVMS
and then not Opt.No_Backup
if not Opt.No_Backup
and then Is_Regular_File (Path_Name (1 .. Path_Last))
then
declare
@ -1280,15 +1277,6 @@ package body Prj.Makr is
new String'(Get_Name_String (Tmp_File));
end if;
-- On VMS, a file created with Create_Temp_File cannot
-- be used to redirect output.
if Hostparm.OpenVMS then
Close (FD);
Delete_File (Temp_File_Name.all, Success);
FD := Create_Output_Text_File (Temp_File_Name.all);
end if;
Args (Args'Last) := new String'
(Dir_Name &
Directory_Separator &

17
gcc/ada/prj-nmsc.adb
View file

@ -34,7 +34,6 @@ with Prj.Tree; use Prj.Tree;
with Prj.Util; use Prj.Util;
with Sinput.P;
with Snames; use Snames;
with Targparm; use Targparm;
with Ada; use Ada;
with Ada.Characters.Handling; use Ada.Characters.Handling;
@ -5222,22 +5221,6 @@ package body Prj.Nmsc is
Name_Len := The_Name'Length;
Name_Buffer (1 .. Name_Len) := The_Name;
-- Special cases of children of packages A, G, I and S on VMS
if OpenVMS_On_Target
and then Name_Len > 3
and then Name_Buffer (2 .. 3) = "__"
and then
(Name_Buffer (1) = 'a' or else
Name_Buffer (1) = 'g' or else
Name_Buffer (1) = 'i' or else
Name_Buffer (1) = 's')
then
Name_Buffer (2) := '.';
Name_Buffer (3 .. Name_Len - 1) := Name_Buffer (4 .. Name_Len);
Name_Len := Name_Len - 1;
end if;
Real_Name := Name_Find;
if Is_Reserved (Real_Name) then

3
gcc/ada/prj.adb
View file

@ -276,8 +276,7 @@ package body Prj is
-- If any of the environment variables ADA_PRJ_INCLUDE_FILE or
-- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
-- the empty string. On VMS, this has the effect of deassigning
-- the logical names.
-- the empty string.
if Shared.Private_Part.Current_Source_Path_File /= No_Path then
Setenv (Project_Include_Path_File, "");

14
gcc/ada/prj.ads
View file

@ -441,10 +441,8 @@ package Prj is
No_Source : constant Source_Id := null;
type Path_Syntax_Kind is
(Canonical,
-- Unix style
Host);
-- Host specific syntax, for example on VMS (the default)
(Canonical, -- Unix style
Host); -- Host specific syntax
-- The following record describes the configuration of a language
@ -484,8 +482,7 @@ package Prj is
-- unit in a multi-source file, in the object file name.
Path_Syntax : Path_Syntax_Kind := Host;
-- Value may be Canonical (Unix style) or Host (host syntax, for example
-- on VMS for DEC C).
-- Value may be Canonical (Unix style) or Host (host syntax)
Source_File_Switches : Name_List_Index := No_Name_List;
-- Optional switches to be put before the source file. The source file
@ -2012,9 +2009,8 @@ private
Current_Source_Path_File : Path_Name_Type := No_Path;
-- Current value of project source path file env var. Used to avoid
-- setting the env var to the same value. When different from No_Path,
-- this indicates that logical names (VMS) or environment variables were
-- created and should be deassigned to avoid polluting the environment
-- on VMS. This is for gnatmake only.
-- this indicates that environment variables were created and should be
-- deassigned to avoid polluting the environment. For gnatmake only.
Current_Object_Path_File : Path_Name_Type := No_Path;
-- Current value of project object path file env var. Used to avoid

24
gcc/ada/repinfo.adb
View file

@ -1477,30 +1477,6 @@ package body Repinfo is
when -2 =>
Write_Str ("reference");
when -3 =>
Write_Str ("descriptor");
when -4 =>
Write_Str ("descriptor (UBS)");
when -5 =>
Write_Str ("descriptor (UBSB)");
when -6 =>
Write_Str ("descriptor (UBA)");
when -7 =>
Write_Str ("descriptor (S)");
when -8 =>
Write_Str ("descriptor (SB)");
when -9 =>
Write_Str ("descriptor (A)");
when -10 =>
Write_Str ("descriptor (NCA)");
when others =>
raise Program_Error;
end case;

8
gcc/ada/rtsfind.adb
View file

@ -1126,10 +1126,10 @@ package body Rtsfind is
procedure Check_RPC;
-- Reject programs that make use of distribution features not supported
-- on the current target. Also check that the PCS is compatible with
-- the code generator version. On such targets (VMS, Vxworks, others?)
-- we provide a minimal body for System.Rpc that only supplies an
-- implementation of Partition_Id.
-- on the current target. Also check that the PCS is compatible with the
-- code generator version. On such targets (Vxworks, others?) we provide
-- a minimal body for System.Rpc that only supplies an implementation of
-- Partition_Id.
function Find_Local_Entity (E : RE_Id) return Entity_Id;
-- This function is used when entity E is in this compilation's main

5
gcc/ada/rtsfind.ads
View file

@ -376,7 +376,6 @@ package Rtsfind is
System_Val_WChar,
System_Vax_Float_Operations,
System_Version_Control,
System_VMS_Exception_Table,
System_WCh_StW,
System_WCh_WtS,
System_Wid_Bool,
@ -1690,8 +1689,6 @@ package Rtsfind is
RE_Version_String, -- System.Version_Control
RE_Get_Version_String, -- System.Version_Control
RE_Register_VMS_Exception, -- System.VMS_Exception_Table
RE_String_To_Wide_String, -- System.WCh_StW
RE_String_To_Wide_Wide_String, -- System.WCh_StW
@ -2977,8 +2974,6 @@ package Rtsfind is
RE_Version_String => System_Version_Control,
RE_Get_Version_String => System_Version_Control,
RE_Register_VMS_Exception => System_VMS_Exception_Table,
RE_String_To_Wide_String => System_WCh_StW,
RE_String_To_Wide_Wide_String => System_WCh_StW,

5
gcc/ada/s-excmac-gcc.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2013, Free Software Foundation, Inc. --
-- Copyright (C) 2013-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- --
@ -147,8 +147,7 @@ package System.Exceptions.Machine is
-- maintain anyway.
type GCC_Exception_Access is access all Unwind_Exception;
-- Pointer to a GCC exception. Do not use convention C as on VMS this
-- would imply the use of 32-bits pointers.
-- Pointer to a GCC exception
procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access);
pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException");

3
gcc/ada/s-fatgen.adb
View file

@ -823,8 +823,7 @@ package body System.Fat_Gen is
Most_Significant_Word : constant Rep_Index :=
Rep_Last * Standard'Default_Bit_Order;
-- Finding the location of the Exponent_Word is a bit tricky. In general
-- we assume Word_Order = Bit_Order. This expression needs to be refined
-- for VMS.
-- we assume Word_Order = Bit_Order.
Exponent_Factor : constant Float_Word :=
2**(Float_Word'Size - 1) /

45
gcc/ada/s-mastop.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1999-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1999-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- --
@ -40,10 +40,10 @@ with System.Storage_Elements;
package System.Machine_State_Operations is
subtype Code_Loc is System.Address;
-- Code location used in building exception tables and for call
-- addresses when propagating an exception (also traceback table)
-- Values of this type are created by using Label'Address or
-- extracted from machine states using Get_Code_Loc.
-- Code location used in building exception tables and for call addresses
-- when propagating an exception (also traceback table) Values of this
-- type are created by using Label'Address or extracted from machine
-- states using Get_Code_Loc.
type Machine_State is new System.Address;
-- The table based exception handling approach (see a-except.adb) isolates
@ -66,31 +66,28 @@ package System.Machine_State_Operations is
-- The initial value of type Machine_State is created by the low level
-- routine that actually raises an exception using the special builtin
-- _builtin_machine_state. This value will typically encode the value
-- of the program counter, and relevant registers. The following
-- operations are defined on Machine_State values:
-- _builtin_machine_state. This value will typically encode the value of
-- the program counter, and relevant registers. The following operations
-- are defined on Machine_State values:
function Get_Code_Loc (M : Machine_State) return Code_Loc;
-- This function extracts the program counter value from a machine
-- state, which the caller uses for searching the exception tables,
-- and also for recording entries in the traceback table. The call
-- returns a value of Null_Loc if the machine state represents the
-- outer level, or some other frame for which no information can be
-- provided.
-- This function extracts the program counter value from a machine state,
-- which the caller uses for searching the exception tables, and also for
-- recording entries in the traceback table. The call returns a value of
-- Null_Loc if the machine state represents the outer level, or some other
-- frame for which no information can be provided.
procedure Pop_Frame (M : Machine_State);
-- This procedure pops the machine state M so that it represents the
-- call point, as though the current subprogram had returned. It
-- changes only the value referenced by M, and does not affect
-- the current stack environment.
-- call point, as though the current subprogram had returned. It changes
-- only the value referenced by M, and does not affect the current stack
-- environment.
function Fetch_Code (Loc : Code_Loc) return Code_Loc;
-- Some architectures (notably VMS) use a descriptor to describe
-- a subprogram address. This function computes the actual starting
-- Some architectures (notably HPUX) use a descriptor to describe a
-- subprogram address. This function computes the actual starting
-- address of the code from Loc.
--
-- ??? This function will go away when 'Code_Address is fixed on VMS.
--
-- Do not add pragma Inline to this function: there is a curious
-- interaction between rtsfind and front-end inlining. The exception
-- declaration in s-auxdec calls rtsfind, which forces several other system
@ -98,10 +95,10 @@ package System.Machine_State_Operations is
-- compile the corresponding bodies so that inlining can take place. One
-- of these packages is s-mastop, which depends on s-auxdec, which is still
-- being compiled: we have not seen all the declarations in it yet, so we
-- get confused semantic errors.
-- get confused semantic errors ???
procedure Set_Machine_State (M : Machine_State);
-- This routine sets M from the current machine state. It is called
-- when an exception is initially signalled to initialize the state.
-- This routine sets M from the current machine state. It is called when an
-- exception is initially signalled to initialize the state.
end System.Machine_State_Operations;

8
gcc/ada/s-parame-ae653.ads
View file

@ -109,14 +109,12 @@ package System.Parameters is
long_bits : constant := Long_Integer'Size;
-- Number of bits in type long and unsigned_long. The normal convention
-- is that this is the same as type Long_Integer, but this is not true
-- of all targets. For example, in OpenVMS long /= Long_Integer.
-- is that this is the same as type Long_Integer, but this may not be true
-- of all targets.
ptr_bits : constant := Standard'Address_Size;
subtype C_Address is System.Address;
-- Number of bits in Interfaces.C pointers, normally a standard address,
-- except on 64-bit VMS where they are 32-bit addresses, for compatibility
-- with legacy code.
-- Number of bits in Interfaces.C pointers, normally a standard address
C_Malloc_Linkname : constant String := "__gnat_malloc";
-- Name of runtime function used to allocate such a pointer

8
gcc/ada/s-parame-hpux.ads
View file

@ -107,14 +107,12 @@ package System.Parameters is
long_bits : constant := Long_Integer'Size;
-- Number of bits in type long and unsigned_long. The normal convention
-- is that this is the same as type Long_Integer, but this is not true
-- of all targets. For example, in OpenVMS long /= Long_Integer.
-- is that this is the same as type Long_Integer, but this may not be true
-- of all targets.
ptr_bits : constant := Standard'Address_Size;
subtype C_Address is System.Address;
-- Number of bits in Interfaces.C pointers, normally a standard address,
-- except on 64-bit VMS where they are 32-bit addresses, for compatibility
-- with legacy code.
-- Number of bits in Interfaces.C pointers, normally a standard address
C_Malloc_Linkname : constant String := "__gnat_malloc";
-- Name of runtime function used to allocate such a pointer

8
gcc/ada/s-parame-vxworks.ads
View file

@ -109,14 +109,12 @@ package System.Parameters is
long_bits : constant := Long_Integer'Size;
-- Number of bits in type long and unsigned_long. The normal convention
-- is that this is the same as type Long_Integer, but this is not true
-- of all targets. For example, in OpenVMS long /= Long_Integer.
-- is that this is the same as type Long_Integer, but this may not be true
-- of all targets.
ptr_bits : constant := Standard'Address_Size;
subtype C_Address is System.Address;
-- Number of bits in Interfaces.C pointers, normally a standard address,
-- except on 64-bit VMS where they are 32-bit addresses, for compatibility
-- with legacy code.
-- Number of bits in Interfaces.C pointers, normally a standard address
C_Malloc_Linkname : constant String := "__gnat_malloc";
-- Name of runtime function used to allocate such a pointer

8
gcc/ada/s-parame.ads
View file

@ -109,14 +109,12 @@ package System.Parameters is
long_bits : constant := Long_Integer'Size;
-- Number of bits in type long and unsigned_long. The normal convention
-- is that this is the same as type Long_Integer, but this is not true
-- of all targets. For example, in OpenVMS long /= Long_Integer.
-- is that this is the same as type Long_Integer, but this may not be true
-- of all targets.
ptr_bits : constant := Standard'Address_Size;
subtype C_Address is System.Address;
-- Number of bits in Interfaces.C pointers, normally a standard address,
-- except on 64-bit VMS where they are 32-bit addresses, for compatibility
-- with legacy code.
-- Number of bits in Interfaces.C pointers, normally a standard address
C_Malloc_Linkname : constant String := "__gnat_malloc";
-- Name of runtime function used to allocate such a pointer

6
gcc/ada/s-soflin.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -140,8 +140,8 @@ package System.Soft_Links is
-- Undefer task abort (non-tasking case, does nothing)
procedure Abort_Handler_NT;
-- Handle task abort (non-tasking case, does nothing). Currently, only VMS
-- uses this.
-- Handle task abort (non-tasking case, does nothing). Currently, no port
-- makes use of this, but we retain the interface for possible future use.
procedure Update_Exception_NT (X : EO := Current_Target_Exception);
-- Handle exception setting. This routine is provided for targets that

5
gcc/ada/s-stoele.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -39,7 +39,8 @@ package body System.Storage_Elements is
-- Conversion to/from address
-- Note qualification below of To_Address to avoid ambiguities on VMS
-- Note qualification below of To_Address to avoid ambiguities systems
-- where Address is a visible integer type.
function To_Address is
new Ada.Unchecked_Conversion (Storage_Offset, Address);

2
gcc/ada/s-tasini.adb
View file

@ -510,7 +510,7 @@ package body System.Tasking.Initialization is
-- The task is blocked on a system call waiting for the
-- completion event. In this case Abort_Task may need to take
-- special action in order to succeed. Example system: VMS.
-- special action in order to succeed.
then
Abort_Task (T);

9
gcc/ada/s-taspri-dummy.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1991-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1991-2014, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -53,13 +53,8 @@ package System.Task_Primitives is
end record;
subtype Task_Address is System.Address;
-- In some versions of Task_Primitives, notably for VMS, Task_Address is
-- the short version of address defined in System.Aux_DEC. To avoid
-- dragging Aux_DEC into tasking packages a tasking specific subtype is
-- defined here.
Task_Address_Size : constant := Standard'Address_Size;
-- The size of Task_Address
-- Type used for task addresses and its size
Alternate_Stack_Size : constant := 0;
-- No alternate signal stack is used on this platform

9
gcc/ada/s-taspri-hpux-dce.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1991-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1991-2014, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -63,13 +63,8 @@ package System.Task_Primitives is
-- Ada_Task_Control_Block.
subtype Task_Address is System.Address;
-- In some versions of Task_Primitives, notably for VMS, Task_Address is
-- the short version of address defined in System.Aux_DEC. To avoid
-- dragging Aux_DEC into tasking packages a tasking specific subtype is
-- defined here.
Task_Address_Size : constant := Standard'Address_Size;
-- The size of Task_Address
-- Type used for task addresses and its size
Alternate_Stack_Size : constant := 0;
-- No alternate signal stack is used on this platform

9
gcc/ada/s-taspri-mingw.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1991-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1991-2014, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -62,13 +62,8 @@ package System.Task_Primitives is
-- Ada_Task_Control_Block.
subtype Task_Address is System.Address;
-- In some versions of Task_Primitives, notably for VMS, Task_Address is
-- the short version of address defined in System.Aux_DEC. To avoid
-- dragging Aux_DEC into tasking packages a tasking specific subtype is
-- defined here.
Task_Address_Size : constant := Standard'Address_Size;
-- The size of Task_Address
-- Type used for task addresses and its size
Alternate_Stack_Size : constant := 0;
-- No alternate signal stack is used on this platform

9
gcc/ada/s-taspri-posix-noaltstack.ads
View file

@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2011, AdaCore --
-- Copyright (C) 1995-2014, AdaCore --
-- --
-- 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- --
@ -65,13 +65,8 @@ package System.Task_Primitives is
-- Ada_Task_Control_Block.
subtype Task_Address is System.Address;
-- In some versions of Task_Primitives, notably for VMS, Task_Address is
-- the short version of address defined in System.Aux_DEC. To avoid
-- dragging Aux_DEC into tasking packages a tasking specific subtype is
-- defined here.
Task_Address_Size : constant := Standard'Address_Size;
-- The size of Task_Address
-- Type used for task addresses and its size
Alternate_Stack_Size : constant := 0;
-- No alternate signal stack is used on this platform

7
gcc/ada/s-taspri-posix.ads
View file

@ -64,13 +64,8 @@ package System.Task_Primitives is
-- Ada_Task_Control_Block.
subtype Task_Address is System.Address;
-- In some versions of Task_Primitives, notably for VMS, Task_Address is
-- the short version of address defined in System.Aux_DEC. To avoid
-- dragging Aux_DEC into tasking packages a tasking specific subtype is
-- defined here.
Task_Address_Size : constant := Standard'Address_Size;
-- The size of Task_Address
-- Type used for task addresses and its size
Alternate_Stack_Size : constant := System.OS_Interface.Alternate_Stack_Size;
-- Import value from System.OS_Interface

9
gcc/ada/s-taspri-solaris.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -70,13 +70,8 @@ package System.Task_Primitives is
-- Ada_Task_Control_Block.
subtype Task_Address is System.Address;
-- In some versions of Task_Primitives, notably for VMS, Task_Address is
-- the short version of address defined in System.Aux_DEC. To avoid
-- dragging Aux_DEC into tasking packages a tasking specific subtype is
-- defined here.
Task_Address_Size : constant := Standard'Address_Size;
-- The size of Task_Address
-- Type used for task addresses and its size
Alternate_Stack_Size : constant := 0;
-- No alternate signal stack is used on this platform

9
gcc/ada/s-taspri-vxworks.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2011, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -61,13 +61,8 @@ package System.Task_Primitives is
-- Ada_Task_Control_Block.
subtype Task_Address is System.Address;
-- In some versions of Task_Primitives, notably for VMS, Task_Address is
-- the short version of address defined in System.Aux_DEC. To avoid
-- dragging Aux_DEC into tasking packages a tasking specific subtype is
-- defined here.
Task_Address_Size : constant := Standard'Address_Size;
-- The size of Task_Address
-- Type used for task addresses and its size
Alternate_Stack_Size : constant := 0;
-- No alternate signal stack is used on this platform

8
gcc/ada/sem_ch12.adb
View file

@ -1140,9 +1140,7 @@ package body Sem_Ch12 is
-- Propagate visible entity to operator node, either from a
-- given actual or from a default.
if Is_Entity_Name (Actual)
and then Nkind (Expr) in N_Op
then
if Is_Entity_Name (Actual) and then Nkind (Expr) in N_Op then
Set_Entity (Expr, Entity (Actual));
end if;
@ -1681,7 +1679,6 @@ package body Sem_Ch12 is
if Present (Match)
and then Nkind (Match) = N_Operator_Symbol
then
-- If the name is a default, find its visible
-- entity at the point of instantiation.
@ -10400,8 +10397,7 @@ package body Sem_Ch12 is
-- to be compiled with checks off.
-- Note that we do NOT apply this criterion to children of GNAT
-- (or on VMS, children of DEC). The latter units must suppress
-- checks explicitly if this is needed.
-- The latter units must suppress checks explicitly if needed.
if Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Gen_Decl)))

12
gcc/ada/sem_ch4.adb
View file

@ -3187,10 +3187,9 @@ package body Sem_Ch4 is
then
-- The actual can be compatible with the formal, but we must
-- also check that the context is not an address type that is
-- visibly an integer type, as is the case in VMS_64. In this
-- case the use of literals is illegal, except in the body of
-- descendents of system, where arithmetic operations on
-- address are of course used.
-- visibly an integer type. In this case the use of literals is
-- illegal, except in the body of descendents of system, where
-- arithmetic operations on address are of course used.
if Has_Compatible_Type (Actual, Etype (Formal))
and then
@ -6807,9 +6806,8 @@ package body Sem_Ch4 is
-- Remove interpretations that treat literals as addresses. This
-- is never appropriate, even when Address is defined as a visible
-- Integer type. The reason is that we would really prefer Address
-- to behave as a private type, even in this case, which is there
-- only to accommodate oddities of VMS address sizes. If Address
-- is a visible integer type, we get lots of overload ambiguities.
-- to behave as a private type, even in this case. If Address is a
-- visible integer type, we get lots of overload ambiguities.
if Nkind (N) in N_Binary_Op then
declare

73
gcc/ada/sem_ch5.adb
View file

@ -1698,6 +1698,28 @@ package body Sem_Ch5 is
Typ : Entity_Id;
Bas : Entity_Id;
procedure Check_Reverse_Iteration (Typ : Entity_Id);
-- For an iteration over a container, if the loop carries the Reverse
-- indicator, verify that the container type has an Iterate aspect that
-- implements the reversible iterator interface.
-----------------------------
-- Check_Reverse_Iteration --
-----------------------------
procedure Check_Reverse_Iteration (Typ : Entity_Id) is
begin
if Reverse_Present (N)
and then not Is_Array_Type (Typ)
and then not Is_Reversible_Iterator (Typ)
then
Error_Msg_NE
("container type does not support reverse iteration", N, Typ);
end if;
end Check_Reverse_Iteration;
-- Start of processing for Analyze_iterator_Specification
begin
Enter_Name (Def_Id);
@ -1725,6 +1747,45 @@ package body Sem_Ch5 is
if Of_Present (N) then
Set_Related_Expression (Def_Id, Iter_Name);
-- For a container, the iterator is specified through the aspect.
if not Is_Array_Type (Etype (Iter_Name)) then
declare
Iterator : constant Entity_Id :=
Find_Value_Of_Aspect
(Etype (Iter_Name), Aspect_Default_Iterator);
I : Interp_Index;
It : Interp;
begin
if No (Iterator) then
null; -- error reported below.
elsif not Is_Overloaded (Iterator) then
Check_Reverse_Iteration (Etype (Iterator));
-- If Iterator is overloaded, use reversible iterator if
-- one is available.
elsif Is_Overloaded (Iterator) then
Get_First_Interp (Iterator, I, It);
while Present (It.Nam) loop
if Ekind (It.Nam) = E_Function
and then Is_Reversible_Iterator (Etype (It.Nam))
then
Set_Etype (Iterator, It.Typ);
Set_Entity (Iterator, It.Nam);
exit;
end if;
Get_Next_Interp (I, It);
end loop;
Check_Reverse_Iteration (Etype (Iterator));
end if;
end;
end if;
end if;
-- If the domain of iteration is an expression, create a declaration for
@ -1785,10 +1846,17 @@ package body Sem_Ch5 is
return;
end if;
if not Of_Present (N) then
Check_Reverse_Iteration (Typ);
end if;
-- 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.
Decl :=
Make_Object_Renaming_Declaration (Loc,
@ -1801,6 +1869,7 @@ package body Sem_Ch5 is
Rewrite (Name (N), New_Occurrence_Of (Id, Loc));
Set_Etype (Id, Typ);
Set_Etype (Name (N), Typ);
Set_Ekind (Id, E_Variable);
end;
-- Container is an entity or an array with uncontrolled components, or
@ -1846,6 +1915,10 @@ package body Sem_Ch5 is
else
Resolve (Iter_Name, Etype (Iter_Name));
end if;
if not Of_Present (N) then
Check_Reverse_Iteration (Etype (Iter_Name));
end if;
end if;
-- Get base type of container, for proper retrieval of Cursor type

41
gcc/ada/sem_eval.adb
View file

@ -1668,13 +1668,6 @@ package body Sem_Eval is
N_Null)
then
return True;
-- Any reference to Null_Parameter is known at compile time. No
-- other attribute references (that have not already been folded)
-- are known at compile time.
elsif K = N_Attribute_Reference then
return Attribute_Name (Op) = Name_Null_Parameter;
end if;
end if;
@ -2657,11 +2650,7 @@ package body Sem_Eval is
Right_Int : constant Uint := Expr_Value (Right);
begin
-- VMS includes bitwise operations on signed types
if Is_Modular_Integer_Type (Etype (N))
or else Is_VMS_Operator (Entity (N))
then
if Is_Modular_Integer_Type (Etype (N)) then
declare
Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
@ -4035,13 +4024,6 @@ package body Sem_Eval is
pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
return Corresponding_Integer_Value (N);
-- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
elsif Kind = N_Attribute_Reference
and then Attribute_Name (N) = Name_Null_Parameter
then
return Uint_0;
-- Otherwise must be character literal
else
@ -4114,13 +4096,6 @@ package body Sem_Eval is
pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
Val := Corresponding_Integer_Value (N);
-- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
elsif Kind = N_Attribute_Reference
and then Attribute_Name (N) = Name_Null_Parameter
then
Val := Uint_0;
-- Otherwise must be character literal
else
@ -4182,18 +4157,12 @@ package body Sem_Eval is
elsif Kind = N_Integer_Literal then
return UR_From_Uint (Expr_Value (N));
-- Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
-- Here, we have a node that cannot be interpreted as a compile time
-- constant. That is definitely an error.
elsif Kind = N_Attribute_Reference
and then Attribute_Name (N) = Name_Null_Parameter
then
return Ureal_0;
else
raise Program_Error;
end if;
-- If we fall through, we have a node that cannot be interpreted as a
-- compile time constant. That is definitely an error.
raise Program_Error;
end Expr_Value_R;
------------------

7
gcc/ada/sem_intr.adb
View file

@ -38,7 +38,6 @@ with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Targparm; use Targparm;
with Uintp; use Uintp;
package body Sem_Intr is
@ -146,12 +145,6 @@ package body Sem_Intr is
elsif String_Length (Strval (Expr_Value_S (Arg1))) = 0 then
Error_Msg_NE
("call to & does not permit null string", N, Nam);
elsif OpenVMS_On_Target
and then String_Length (Strval (Expr_Value_S (Arg1))) > 31
then
Error_Msg_NE
("argument in call to & must be 31 characters or less", N, Nam);
end if;
-- Check for the case of freeing a non-null object which will raise

47
gcc/ada/sem_mech.adb
View file

@ -23,16 +23,14 @@
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Errout; use Errout;
with Namet; use Namet;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Targparm; use Targparm;
with Atree; use Atree;
with Einfo; use Einfo;
with Errout; use Errout;
with Namet; use Namet;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sinfo; use Sinfo;
with Snames; use Snames;
package body Sem_Mech is
@ -93,18 +91,10 @@ package body Sem_Mech is
Mech : Mechanism_Type;
Enod : Node_Id)
is
pragma Unreferenced (Enod);
begin
-- Right now we only do some checks for functions returning arguments
-- by descriptor. Probably mode checks need to be added here ???
if Mech in Descriptor_Codes and then not Is_Formal (Ent) then
if Is_Record_Type (Etype (Ent)) then
Error_Msg_N ("??records cannot be returned by Descriptor", Enod);
return;
end if;
end if;
-- If we fall through, all checks have passed
-- Right now we don't do any checks, should we do more ???
Set_Mechanism (Ent, Mech);
end Set_Mechanism_With_Checks;
@ -314,23 +304,10 @@ package body Sem_Mech is
when Convention_Fortran =>
-- In OpenVMS, pass character and string types using
-- Short_Descriptor(S)
if OpenVMS_On_Target
and then (Root_Type (Typ) = Standard_Character
or else
(Is_Array_Type (Typ)
and then
Root_Type (Component_Type (Typ)) =
Standard_Character))
then
Set_Mechanism (Formal, By_Short_Descriptor_S);
-- Access types are passed by default (presumably this
-- will mean they are passed by copy)
elsif Is_Access_Type (Typ) then
if Is_Access_Type (Typ) then
null;
-- For now, we pass all other parameters by reference.

39
gcc/ada/sem_mech.ads
View file

@ -87,46 +87,9 @@ package Sem_Mech is
-- special information) is determined by the backend in accordance with
-- requirements imposed by the ABI as interpreted for Ada.
By_Descriptor : constant Mechanism_Type := -3;
By_Descriptor_UBS : constant Mechanism_Type := -4;
By_Descriptor_UBSB : constant Mechanism_Type := -5;
By_Descriptor_UBA : constant Mechanism_Type := -6;
By_Descriptor_S : constant Mechanism_Type := -7;
By_Descriptor_SB : constant Mechanism_Type := -8;
By_Descriptor_A : constant Mechanism_Type := -9;
By_Descriptor_NCA : constant Mechanism_Type := -10;
By_Short_Descriptor : constant Mechanism_Type := -11;
By_Short_Descriptor_UBS : constant Mechanism_Type := -12;
By_Short_Descriptor_UBSB : constant Mechanism_Type := -13;
By_Short_Descriptor_UBA : constant Mechanism_Type := -14;
By_Short_Descriptor_S : constant Mechanism_Type := -15;
By_Short_Descriptor_SB : constant Mechanism_Type := -16;
By_Short_Descriptor_A : constant Mechanism_Type := -17;
By_Short_Descriptor_NCA : constant Mechanism_Type := -18;
-- These values are used only in OpenVMS ports of GNAT. Pass by descriptor
-- is forced, as described in the OpenVMS ABI. The suffix indicates the
-- descriptor type:
--
-- UBS unaligned bit string
-- UBSB aligned bit string with arbitrary bounds
-- UBA unaligned bit array
-- S string, also a scalar or access type parameter
-- SB string with arbitrary bounds
-- A contiguous array
-- NCA non-contiguous array
--
-- Note: the form with no suffix is used if the Import/Export pragma uses
-- the simple form of the mechanism name (no descriptor type is supplied).
-- In this case the back end assigns a descriptor type based on the Ada
-- type in accordance with the OpenVMS ABI.
pragma Assert (Mechanism_Type'First = -18);
pragma Assert (Mechanism_Type'First = -2);
-- Check definition in types is right!
subtype Descriptor_Codes is Mechanism_Type
range By_Short_Descriptor_NCA .. By_Descriptor;
-- Subtype including all descriptor mechanisms
-- All the above special values are non-positive. Positive values for
-- Mechanism_Type values have a special meaning. They are used only in
-- the case of records, as a result of the use of the C_Pass_By_Copy

69
gcc/ada/sem_prag.adb
View file

@ -7312,13 +7312,16 @@ package body Sem_Prag is
Arg_Result_Mechanism : Node_Id := Empty;
Arg_First_Optional_Parameter : Node_Id := Empty)
is
pragma Unreferenced (Arg_First_Optional_Parameter);
-- We ignore the First_Optional_Parameter argument. It was only
-- relevant for VMS anyway, and otherwise ignored.
Ent : Entity_Id;
Def_Id : Entity_Id;
Hom_Id : Entity_Id;
Formal : Entity_Id;
Ambiguous : Boolean;
Match : Boolean;
Dval : Node_Id;
function Same_Base_Type
(Ptype : Node_Id;
@ -7699,63 +7702,6 @@ package body Sem_Prag is
end if;
end;
end if;
-- Process First_Optional_Parameter argument if present. We have
-- already checked that this is only allowed for the Import case.
if Present (Arg_First_Optional_Parameter) then
if Nkind (Arg_First_Optional_Parameter) /= N_Identifier then
Error_Pragma_Arg
("first optional parameter must be formal parameter name",
Arg_First_Optional_Parameter);
end if;
Formal := First_Formal (Ent);
loop
if No (Formal) then
Error_Pragma_Arg
("specified formal parameter& not found",
Arg_First_Optional_Parameter);
end if;
exit when Chars (Formal) =
Chars (Arg_First_Optional_Parameter);
Next_Formal (Formal);
end loop;
Set_First_Optional_Parameter (Ent, Formal);
-- Check specified and all remaining formals have right form
while Present (Formal) loop
if Ekind (Formal) /= E_In_Parameter then
Error_Msg_NE
("optional formal& is not of mode in!",
Arg_First_Optional_Parameter, Formal);
else
Dval := Default_Value (Formal);
if No (Dval) then
Error_Msg_NE
("optional formal& does not have default value!",
Arg_First_Optional_Parameter, Formal);
elsif Compile_Time_Known_Value_Or_Aggr (Dval) then
null;
else
Error_Msg_FE
("default value for optional formal& is non-static!",
Arg_First_Optional_Parameter, Formal);
end if;
end if;
Set_Is_Optional_Parameter (Formal);
Next_Formal (Formal);
end loop;
end if;
end Process_Extended_Import_Export_Subprogram_Pragma;
--------------------------
@ -10847,10 +10793,9 @@ package body Sem_Prag is
Check_Arg_Count (0);
-- If Address is a private type, then set the flag to allow
-- integer address values. If Address is not private, then
-- this pragma has no purpose, so it is simply ignored. Not
-- clear if there are any such targets now (VMS used to be
-- one such, but leave test in for the future anyway).
-- integer address values. If Address is not private, then this
-- pragma has no purpose, so it is simply ignored. Not clear if
-- there are any such targets now.
if Opt.Address_Is_Private then
Opt.Allow_Integer_Address := True;

55
gcc/ada/sem_res.adb
View file

@ -225,8 +225,7 @@ package body Sem_Res is
-- operators, not ones that are intrinsic imports of back-end builtins.
procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id);
-- Ditto, for unary operators (arithmetic ones and "not" on signed
-- integer types for VMS).
-- Ditto, for arithmetic unary operators
procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id);
-- If an operator node resolves to a call to a user-defined operator,
@ -7990,11 +7989,10 @@ package body Sem_Res is
--------------------------------
procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is
Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
Op : Entity_Id;
Orig_Op : constant Entity_Id := Entity (N);
Arg1 : Node_Id;
Arg2 : Node_Id;
Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ));
Op : Entity_Id;
Arg1 : Node_Id;
Arg2 : Node_Id;
function Convert_Operand (Opnd : Node_Id) return Node_Id;
-- If the operand is a literal, it cannot be the expression in a
@ -8074,31 +8072,19 @@ package body Sem_Res is
or else Typ /= Etype (Right_Opnd (N))
then
-- Add explicit conversion where needed, and save interpretations in
-- case operands are overloaded. If the context is a VMS operation,
-- assert that the conversion is legal (the operands have the proper
-- types to select the VMS intrinsic). Note that in rare cases the
-- VMS operators may be visible, but the default System is being used
-- and Address is a private type.
-- case operands are overloaded.
Arg1 := Convert_To (Typ, Left_Opnd (N));
Arg2 := Convert_To (Typ, Right_Opnd (N));
if Nkind (Arg1) = N_Type_Conversion then
Save_Interps (Left_Opnd (N), Expression (Arg1));
if Is_VMS_Operator (Orig_Op) then
Set_Conversion_OK (Arg1);
end if;
else
Save_Interps (Left_Opnd (N), Arg1);
end if;
if Nkind (Arg2) = N_Type_Conversion then
Save_Interps (Right_Opnd (N), Expression (Arg2));
if Is_VMS_Operator (Orig_Op) then
Set_Conversion_OK (Arg2);
end if;
else
Save_Interps (Right_Opnd (N), Arg2);
end if;
@ -8170,18 +8156,13 @@ package body Sem_Res is
B_Typ := Base_Type (Typ);
end if;
-- OK if this is a VMS-specific intrinsic operation
if Is_VMS_Operator (Entity (N)) then
null;
-- The following test is required because the operands of the operation
-- may be literals, in which case the resulting type appears to be
-- compatible with a signed integer type, when in fact it is compatible
-- only with modular types. If the context itself is universal, the
-- operation is illegal.
elsif not Valid_Boolean_Arg (Typ) then
if not Valid_Boolean_Arg (Typ) then
Error_Msg_N ("invalid context for logical operation", N);
Set_Etype (N, Any_Type);
return;
@ -8934,12 +8915,9 @@ package body Sem_Res is
B_Typ := Base_Type (Typ);
end if;
if Is_VMS_Operator (Entity (N)) then
null;
-- Straightforward case of incorrect arguments
elsif not Valid_Boolean_Arg (Typ) then
if not Valid_Boolean_Arg (Typ) then
Error_Msg_N ("invalid operand type for operator&", N);
Set_Etype (N, Any_Type);
return;
@ -11098,15 +11076,15 @@ package body Sem_Res is
if Is_Floating_Point_Type (Opnd_Typ)
and then
(Is_Integer_Type (Target_Typ)
or else (Is_Fixed_Point_Type (Target_Typ)
and then Conversion_OK (N)))
or else (Is_Fixed_Point_Type (Target_Typ)
and then Conversion_OK (N)))
and then Nkind (Operand) = N_Attribute_Reference
and then (Attribute_Name (Operand) = Name_Rounding
or else Attribute_Name (Operand) = Name_Truncation)
and then Nam_In (Attribute_Name (Operand), Name_Rounding,
Name_Truncation)
then
declare
Truncate : constant Boolean :=
Attribute_Name (Operand) = Name_Truncation;
Attribute_Name (Operand) = Name_Truncation;
begin
Rewrite (Operand,
Relocate_Node (First (Expressions (Operand))));
@ -11515,13 +11493,6 @@ package body Sem_Res is
-- this context, but which cannot be removed by type checking,
-- because the context does not impose a type.
-- When compiling for VMS, spurious ambiguities can be produced
-- when arithmetic operations have a literal operand and return
-- System.Address or a descendant of it. These ambiguities are
-- otherwise resolved by the context, but for conversions there
-- is no context type and the removal of the spurious operations
-- must be done explicitly here.
-- The node may be labelled overloaded, but still contain only one
-- interpretation because others were discarded earlier. If this
-- is the case, retain the single interpretation if legal.

22
gcc/ada/sem_util.adb
View file

@ -6022,8 +6022,7 @@ package body Sem_Util is
-- be a static subtype, since otherwise it would have
-- been diagnosed as illegal.
elsif Is_Entity_Name (Choice) and then
Is_Type (Entity (Choice))
elsif Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))
then
exit Search when Is_In_Range (Expr, Etype (Choice),
Assume_Valid => False);
@ -11798,25 +11797,6 @@ package body Sem_Util is
return False;
end Is_Variable_Size_Record;
---------------------
-- Is_VMS_Operator --
---------------------
function Is_VMS_Operator (Op : Entity_Id) return Boolean is
begin
-- The VMS operators are declared in a child of System that is loaded
-- through pragma Extend_System. In some rare cases a program is run
-- with this extension but without indicating that the target is VMS.
return Ekind (Op) = E_Function
and then Is_Intrinsic_Subprogram (Op)
and then
((Present_System_Aux and then Scope (Op) = System_Aux_Id)
or else
(True_VMS_Target
and then Scope (Scope (Op)) = RTU_Entity (System)));
end Is_VMS_Operator;
-----------------
-- Is_Variable --
-----------------

4
gcc/ada/sem_util.ads
View file

@ -1359,10 +1359,6 @@ package Sem_Util is
function Is_Variable_Size_Record (E : Entity_Id) return Boolean;
-- Returns true if E has variable size components
function Is_VMS_Operator (Op : Entity_Id) return Boolean;
-- Determine whether an operator is one of the intrinsics defined
-- in the DEC system extension.
function Is_Variable
(N : Node_Id;
Use_Original_Node : Boolean := True) return Boolean;

18
gcc/ada/sinfo.adb
View file

@ -2488,15 +2488,6 @@ package body Sinfo is
return List3 (N);
end Parameter_Associations;
function Parameter_List_Truncated
(N : Node_Id) return Boolean is
begin
pragma Assert (False
or else NT (N).Nkind = N_Function_Call
or else NT (N).Nkind = N_Procedure_Call_Statement);
return Flag17 (N);
end Parameter_List_Truncated;
function Parameter_Specifications
(N : Node_Id) return List_Id is
begin
@ -5695,15 +5686,6 @@ package body Sinfo is
Set_List3_With_Parent (N, Val);
end Set_Parameter_Associations;
procedure Set_Parameter_List_Truncated
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Function_Call
or else NT (N).Nkind = N_Procedure_Call_Statement);
Set_Flag17 (N, Val);
end Set_Parameter_List_Truncated;
procedure Set_Parameter_Specifications
(N : Node_Id; Val : List_Id) is
begin

25
gcc/ada/sinfo.ads
View file

@ -1888,21 +1888,6 @@ package Sinfo is
-- list of discrete choices, except that of course it cannot contain an
-- N_Others_Choice entry.
-- Parameter_List_Truncated (Flag17-Sem)
-- Present in N_Function_Call and N_Procedure_Call_Statement nodes. Set
-- (for OpenVMS ports of GNAT only) if the parameter list is truncated
-- as a result of a First_Optional_Parameter specification in one of the
-- pragmas Import_Function, Import_Procedure, or Import_Valued_Procedure.
-- The truncation is done by the expander by removing trailing parameters
-- from the argument list, in accordance with the set of rules allowing
-- such parameter removal. In particular, parameters can be removed
-- working from the end of the parameter list backwards up to and
-- including the entry designated by First_Optional_Parameter in the
-- Import pragma. Parameters can be removed if they are implicit and the
-- default value is known at compile time value, including the use of
-- the Null_Parameter attribute, or if explicit parameter values are
-- present that match the corresponding defaults.
-- Parent_Spec (Node4-Sem)
-- For a library unit that is a child unit spec (package or subprogram
-- declaration, generic declaration or instantiation, or library level
@ -5156,7 +5141,6 @@ package Sinfo is
-- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
-- Do_Tag_Check (Flag13-Sem)
-- No_Elaboration_Check (Flag14-Sem)
-- Parameter_List_Truncated (Flag17-Sem)
-- ABE_Is_Certain (Flag18-Sem)
-- plus fields for expression
@ -5188,7 +5172,6 @@ package Sinfo is
-- Is_Expanded_Build_In_Place_Call (Flag11-Sem)
-- Do_Tag_Check (Flag13-Sem)
-- No_Elaboration_Check (Flag14-Sem)
-- Parameter_List_Truncated (Flag17-Sem)
-- ABE_Is_Certain (Flag18-Sem)
-- plus fields for expression
@ -9433,9 +9416,6 @@ package Sinfo is
function Parameter_Associations
(N : Node_Id) return List_Id; -- List3
function Parameter_List_Truncated
(N : Node_Id) return Boolean; -- Flag17
function Parameter_Specifications
(N : Node_Id) return List_Id; -- List3
@ -10456,9 +10436,6 @@ package Sinfo is
procedure Set_Parameter_Associations
(N : Node_Id; Val : List_Id); -- List3
procedure Set_Parameter_List_Truncated
(N : Node_Id; Val : Boolean := True); -- Flag17
procedure Set_Parameter_Specifications
(N : Node_Id; Val : List_Id); -- List3
@ -12719,7 +12696,6 @@ package Sinfo is
pragma Inline (Out_Present);
pragma Inline (Parameter_Associations);
pragma Inline (Parameter_Specifications);
pragma Inline (Parameter_List_Truncated);
pragma Inline (Parameter_Type);
pragma Inline (Parent_Spec);
pragma Inline (Position);
@ -13055,7 +13031,6 @@ package Sinfo is
pragma Inline (Set_Others_Discrete_Choices);
pragma Inline (Set_Out_Present);
pragma Inline (Set_Parameter_Associations);
pragma Inline (Set_Parameter_List_Truncated);
pragma Inline (Set_Parameter_Specifications);
pragma Inline (Set_Parameter_Type);
pragma Inline (Set_Parent_Spec);

16
gcc/ada/sinput-c.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1992-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- --
@ -92,8 +92,8 @@ package body Sinput.C is
Len := Integer (File_Length (Source_File_FD));
-- Set Hi so that length is one more than the physical length,
-- allowing for the extra EOF character at the end of the buffer
-- Set Hi so that length is one more than the physical length, allowing
-- for the extra EOF character at the end of the buffer
Hi := Lo + Source_Ptr (Len);
@ -112,9 +112,9 @@ package body Sinput.C is
begin
-- Allocate source buffer, allowing extra character at end for EOF
-- Some systems (e.g. VMS) have file types that require one
-- read per line, so read until we get the Len bytes or until
-- there are no more characters.
-- Some systems have file types that require one read per line,
-- so read until we get the Len bytes or until there are no more
-- characters.
Hi := Lo;
loop
@ -126,8 +126,8 @@ package body Sinput.C is
Actual_Ptr (Hi) := EOF;
-- Now we need to work out the proper virtual origin pointer to
-- return. This is exactly Actual_Ptr (0)'Address, but we have
-- to be careful to suppress checks to compute this address.
-- return. This is exactly Actual_Ptr (0)'Address, but we have to
-- be careful to suppress checks to compute this address.
declare
pragma Suppress (All_Checks);

9
gcc/ada/symbols.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2003-2007, Free Software Foundation, Inc. --
-- Copyright (C) 2003-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- --
@ -91,10 +91,9 @@ package Symbols is
package Processing is
-- This package, containing a single visible procedure Process, exists so
-- that it can be a subunits, for some platforms (such as VMS Alpha and
-- IA64), the body of package Symbols is common, while the subunit
-- Processing is not.
-- This package, containing a single visible procedure Process, exists
-- so that it can be a subunits, for some platforms, the body of package
-- Symbols is common, while the subunit Processing is not.
procedure Process
(Object_File : String;

7
gcc/ada/targparm.adb
View file

@ -716,13 +716,6 @@ package body Targparm is
end if;
end loop Line_Loop;
-- Now that OpenVMS_On_Target has been given its definitive value,
-- change the multi-unit index character from '~' to '$' for OpenVMS.
if OpenVMS_On_Target then
Multi_Unit_Index_Character := '$';
end if;
if Fatal then
raise Unrecoverable_Error;
end if;

47
gcc/ada/treepr.adb
View file

@ -603,49 +603,18 @@ package body Treepr is
begin
case M is
when Default_Mechanism
=> Write_Str ("Default");
when By_Copy
=> Write_Str ("By_Copy");
when By_Reference
=> Write_Str ("By_Reference");
when By_Descriptor
=> Write_Str ("By_Descriptor");
when By_Descriptor_UBS
=> Write_Str ("By_Descriptor_UBS");
when By_Descriptor_UBSB
=> Write_Str ("By_Descriptor_UBSB");
when By_Descriptor_UBA
=> Write_Str ("By_Descriptor_UBA");
when By_Descriptor_S
=> Write_Str ("By_Descriptor_S");
when By_Descriptor_SB
=> Write_Str ("By_Descriptor_SB");
when By_Descriptor_A
=> Write_Str ("By_Descriptor_A");
when By_Descriptor_NCA
=> Write_Str ("By_Descriptor_NCA");
when By_Short_Descriptor
=> Write_Str ("By_Short_Descriptor");
when By_Short_Descriptor_UBS
=> Write_Str ("By_Short_Descriptor_UBS");
when By_Short_Descriptor_UBSB
=> Write_Str ("By_Short_Descriptor_UBSB");
when By_Short_Descriptor_UBA
=> Write_Str ("By_Short_Descriptor_UBA");
when By_Short_Descriptor_S
=> Write_Str ("By_Short_Descriptor_S");
when By_Short_Descriptor_SB
=> Write_Str ("By_Short_Descriptor_SB");
when By_Short_Descriptor_A
=> Write_Str ("By_Short_Descriptor_A");
when By_Short_Descriptor_NCA
=> Write_Str ("By_Short_Descriptor_NCA");
when Default_Mechanism =>
Write_Str ("Default");
when By_Copy =>
Write_Str ("By_Copy");
when By_Reference =>
Write_Str ("By_Reference");
when 1 .. Mechanism_Type'Last =>
Write_Str ("By_Copy if size <= ");
Write_Int (Int (M));
end case;
end;

4
gcc/ada/types.ads
View file

@ -795,11 +795,11 @@ package Types is
-- mechanism. See specification of Sem_Mech for full details. The following
-- subtype is used to represent values of this type:
subtype Mechanism_Type is Int range -18 .. Int'Last;
subtype Mechanism_Type is Int range -2 .. Int'Last;
-- Type used to represent a mechanism value. This is a subtype rather than
-- a type to avoid some annoying processing problems with certain routines
-- in Einfo (processing them to create the corresponding C). The values in
-- the range -18 .. 0 are used to represent mechanism types declared as
-- the range -2 .. 0 are used to represent mechanism types declared as
-- named constants in the spec of Sem_Mech. Positive values are used for
-- the case of a pragma C_Pass_By_Copy that sets a threshold value for the
-- mechanism to be used. For example if pragma C_Pass_By_Copy (32) is given

14
gcc/ada/xr_tabls.adb
View file

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1998-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- --
@ -25,7 +25,6 @@
with Types; use Types;
with Osint;
with Hostparm;
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
@ -1136,17 +1135,6 @@ package body Xr_Tabls is
Buffer (Read_Ptr) := EOF;
Contents := new String'(Buffer (1 .. Read_Ptr));
-- Things are not simple on VMS due to the plethora of file types
-- and organizations. It seems clear that there shouldn't be more
-- bytes read than are contained in the file though.
if (Hostparm.OpenVMS and then Read_Ptr > Length + 1)
or else (not Hostparm.OpenVMS and then Read_Ptr /= Length + 1)
then
raise Ada.Text_IO.End_Error;
end if;
Close (FD);
end;
end Read_File;

6
gcc/ada/xr_tabls.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1998-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1998-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- --
@ -288,9 +288,7 @@ package Xr_Tabls is
-- character will be added to the returned Contents to simplify parsing.
-- Name_Error is raised if the file was not found. End_Error is raised if
-- the file could not be read correctly. For most systems correct reading
-- means that the number of bytes read is equal to the file size. The
-- exception is OpenVMS where correct reading means that the number of
-- bytes read is less than or equal to the file size.
-- means that the number of bytes read is equal to the file size.
private
type Project_File (Src_Dir_Length, Obj_Dir_Length : Natural) is record