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

[multiple changes] 

2014-07-31  Robert Dewar  <dewar@adacore.com>

	* sem_ch3.adb, sem_ch13.adb: Minor reformatting.

2014-07-31  Arnaud Charlet  <charlet@adacore.com>

	* a-intnam-linux.ads: Minor: update obsolete comments.
	* s-taasde.adb: Minor: fix comment header.

2014-07-31  Arnaud Charlet  <charlet@adacore.com>

	* s-auxdec-vms-ia64.adb, s-parame-vms-alpha.ads, s-asthan-vms-alpha.adb,
	s-tpopde-vms.adb, s-mastop-vms.adb, s-tpopde-vms.ads, s-taprop-vms.adb,
	mlib-tgt-vms_common.adb, mlib-tgt-vms_common.ads, s-inmaop-vms.adb,
	g-enblsp-vms-alpha.adb, s-ransee-vms.adb, s-osprim-vms.adb,
	s-osprim-vms.ads, g-socthi-vms.adb, g-socthi-vms.ads, system-vms_64.ads,
	s-osinte-vms.adb, s-osinte-vms.ads, g-eacodu-vms.adb,
	s-vaflop-vms-alpha.adb, s-parame-vms-ia64.ads, a-dirval-vms.adb,
	a-caldel-vms.adb, mlib-tgt-specific-vms-alpha.adb, s-tasdeb-vms.adb,
	symbols-vms.adb, a-intnam-vms.ads, g-expect-vms.adb,
	symbols-processing-vms-alpha.adb, mlib-tgt-specific-vms-ia64.adb,
	s-traent-vms.adb, s-traent-vms.ads, i-cstrea-vms.adb, a-numaux-vms.ads,
	symbols-processing-vms-ia64.adb, s-interr-vms.adb, s-memory-vms_64.adb,
	s-memory-vms_64.ads, g-enblsp-vms-ia64.adb, s-taspri-vms.ads,
	s-auxdec-vms_64.ads, s-intman-vms.adb, s-intman-vms.ads,
	s-tpopsp-vms.adb, s-asthan-vms-ia64.adb, a-calend-vms.adb,
	a-calend-vms.ads, system-vms-ia64.ads, s-auxdec-vms-alpha.adb: Removed.
	* namet.h (Is_Non_Ada_Error): Remove.

From-SVN: r213368
This commit is contained in:
Arnaud Charlet 2014-07-31 15:40:26 +02:00
parent fec4842dee
commit f9648959b4
56 changed files with 46 additions and 19684 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
gcc/ada/ChangeLog
View File

@ -1,3 +1,32 @@
2014-07-31 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb, sem_ch13.adb: Minor reformatting.
2014-07-31 Arnaud Charlet <charlet@adacore.com>
* a-intnam-linux.ads: Minor: update obsolete comments.
* s-taasde.adb: Minor: fix comment header.
2014-07-31 Arnaud Charlet <charlet@adacore.com>
* s-auxdec-vms-ia64.adb, s-parame-vms-alpha.ads, s-asthan-vms-alpha.adb,
s-tpopde-vms.adb, s-mastop-vms.adb, s-tpopde-vms.ads, s-taprop-vms.adb,
mlib-tgt-vms_common.adb, mlib-tgt-vms_common.ads, s-inmaop-vms.adb,
g-enblsp-vms-alpha.adb, s-ransee-vms.adb, s-osprim-vms.adb,
s-osprim-vms.ads, g-socthi-vms.adb, g-socthi-vms.ads, system-vms_64.ads,
s-osinte-vms.adb, s-osinte-vms.ads, g-eacodu-vms.adb,
s-vaflop-vms-alpha.adb, s-parame-vms-ia64.ads, a-dirval-vms.adb,
a-caldel-vms.adb, mlib-tgt-specific-vms-alpha.adb, s-tasdeb-vms.adb,
symbols-vms.adb, a-intnam-vms.ads, g-expect-vms.adb,
symbols-processing-vms-alpha.adb, mlib-tgt-specific-vms-ia64.adb,
s-traent-vms.adb, s-traent-vms.ads, i-cstrea-vms.adb, a-numaux-vms.ads,
symbols-processing-vms-ia64.adb, s-interr-vms.adb, s-memory-vms_64.adb,
s-memory-vms_64.ads, g-enblsp-vms-ia64.adb, s-taspri-vms.ads,
s-auxdec-vms_64.ads, s-intman-vms.adb, s-intman-vms.ads,
s-tpopsp-vms.adb, s-asthan-vms-ia64.adb, a-calend-vms.adb,
a-calend-vms.ads, system-vms-ia64.ads, s-auxdec-vms-alpha.adb: Removed.
* namet.h (Is_Non_Ada_Error): Remove.
2014-07-31 Robert Dewar <dewar@adacore.com>
* exp_util.adb, lib-writ.adb, sem_ch12.adb, s-direio.adb: Minor

105
gcc/ada/a-caldel-vms.adb
View File

@ -1,105 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- A D A . C A L E N D A R . D E L A Y S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2012, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is the Alpha/VMS version
with System.OS_Primitives;
with System.Soft_Links;
package body Ada.Calendar.Delays is
package OSP renames System.OS_Primitives;
package TSL renames System.Soft_Links;
use type TSL.Timed_Delay_Call;
-----------------------
-- Local Subprograms --
-----------------------
procedure Timed_Delay_NT (Time : Duration; Mode : Integer);
-- Timed delay procedure used when no tasking is active
---------------
-- Delay_For --
---------------
procedure Delay_For (D : Duration) is
begin
TSL.Timed_Delay.all
(Duration'Min (D, OSP.Max_Sensible_Delay), OSP.Relative);
end Delay_For;
-----------------
-- Delay_Until --
-----------------
procedure Delay_Until (T : Time) is
begin
TSL.Timed_Delay.all (To_Duration (T), OSP.Absolute_Calendar);
end Delay_Until;
-----------------
-- To_Duration --
-----------------
function To_Duration (T : Time) return Duration is
Safe_Ada_High : constant Time := Time_Of (2250, 1, 1, 0.0);
-- A value distant enough to emulate "end of time" but which does not
-- cause overflow.
Safe_T : constant Time :=
(if T > Safe_Ada_High then Safe_Ada_High else T);
begin
return OSP.To_Duration (OSP.OS_Time (Safe_T), OSP.Absolute_Calendar);
end To_Duration;
--------------------
-- Timed_Delay_NT --
--------------------
procedure Timed_Delay_NT (Time : Duration; Mode : Integer) is
begin
OSP.Timed_Delay (Time, Mode);
end Timed_Delay_NT;
begin
-- Set up the Timed_Delay soft link to the non tasking version if it has
-- not been already set. If tasking is present, Timed_Delay has already set
-- this soft link, or this will be overridden during the elaboration of
-- System.Tasking.Initialization
if TSL.Timed_Delay = null then
TSL.Timed_Delay := Timed_Delay_NT'Access;
end if;
end Ada.Calendar.Delays;

1317
gcc/ada/a-calend-vms.adb
View File

File diff suppressed because it is too large Load Diff

310
gcc/ada/a-calend-vms.ads
View File

@ -1,310 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . C A L E N D A R --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the OpenVMS version
with System.OS_Primitives;
package Ada.Calendar is
type Time is private;
-- Declarations representing limits of allowed local time values. Note that
-- these do NOT constrain the possible stored values of time which may well
-- permit a larger range of times (this is explicitly allowed in Ada 95).
subtype Year_Number is Integer range 1901 .. 2399;
subtype Month_Number is Integer range 1 .. 12;
subtype Day_Number is Integer range 1 .. 31;
subtype Day_Duration is Duration range 0.0 .. 86_400.0;
-- Note that a value of 86_400.0 is the start of the next day
function Clock return Time;
-- The returned time value is the number of nanoseconds since the start
-- of Ada time (1901-01-01 00:00:00.0 UTC). If leap seconds are enabled,
-- the result will contain all elapsed leap seconds since the start of
-- Ada time until now.
function Year (Date : Time) return Year_Number;
function Month (Date : Time) return Month_Number;
function Day (Date : Time) return Day_Number;
function Seconds (Date : Time) return Day_Duration;
procedure Split
(Date : Time;
Year : out Year_Number;
Month : out Month_Number;
Day : out Day_Number;
Seconds : out Day_Duration);
-- Break down a time value into its date components set in the current
-- time zone. If Split is called on a time value created using Ada 2005
-- Time_Of in some arbitrary time zone, the input value will always be
-- interpreted as relative to the local time zone.
function Time_Of
(Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Seconds : Day_Duration := 0.0) return Time;
-- GNAT Note: Normally when procedure Split is called on a Time value
-- result of a call to function Time_Of, the out parameters of procedure
-- Split are identical to the in parameters of function Time_Of. However,
-- when a non-existent time of day is specified, the values for Seconds
-- may or may not be different. This may happen when Daylight Saving Time
-- (DST) is in effect, on the day when switching to DST, if Seconds
-- specifies a time of day in the hour that does not exist. For example,
-- in New York:
--
-- Time_Of (Year => 1998, Month => 4, Day => 5, Seconds => 10740.0)
--
-- will return a Time value T. If Split is called on T, the resulting
-- Seconds may be 14340.0 (3:59:00) instead of 10740.0 (2:59:00 being
-- a time that not exist).
function "+" (Left : Time; Right : Duration) return Time;
function "+" (Left : Duration; Right : Time) return Time;
function "-" (Left : Time; Right : Duration) return Time;
function "-" (Left : Time; Right : Time) return Duration;
-- The first three functions will raise Time_Error if the resulting time
-- value is less than the start of Ada time in UTC or greater than the
-- end of Ada time in UTC. The last function will raise Time_Error if the
-- resulting difference cannot fit into a duration value.
function "<" (Left, Right : Time) return Boolean;
function "<=" (Left, Right : Time) return Boolean;
function ">" (Left, Right : Time) return Boolean;
function ">=" (Left, Right : Time) return Boolean;
Time_Error : exception;
private
pragma Inline (Clock);
pragma Inline (Year);
pragma Inline (Month);
pragma Inline (Day);
pragma Inline ("+");
pragma Inline ("-");
pragma Inline ("<");
pragma Inline ("<=");
pragma Inline (">");
pragma Inline (">=");
-- Although the units are 100 nanoseconds, for the purpose of better
-- readability, this unit will be called "mili".
Mili : constant := 10_000_000;
Mili_F : constant := 10_000_000.0;
Milis_In_Day : constant := 864_000_000_000;
Secs_In_Day : constant := 86_400;
-- Time is represented as the number of 100-nanosecond (ns) units from the
-- system base date and time 1858-11-17 0.0 (the Smithsonian base date and
-- time for the astronomic calendar).
-- The time value stored is typically a UTC value, as provided in standard
-- Unix environments. If this is the case then Split and Time_Of perform
-- required conversions to and from local times.
-- Notwithstanding this definition, Time is not quite the same as OS_Time.
-- Relative Time is positive, whereas relative OS_Time is negative,
-- but this declaration makes for easier conversion.
type Time is new System.OS_Primitives.OS_Time;
Days_In_Month : constant array (Month_Number) of Day_Number :=
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
-- Days in month for non-leap year, leap year case is adjusted in code
Invalid_Time_Zone_Offset : Long_Integer;
pragma Import (C, Invalid_Time_Zone_Offset, "__gnat_invalid_tzoff");
function Is_Leap (Year : Year_Number) return Boolean;
-- Determine whether a given year is leap
----------------------------------------------------------
-- Target-Independent Interface to Children of Calendar --
----------------------------------------------------------
-- The following packages provide a target-independent interface to the
-- children of Calendar - Arithmetic, Conversions, Delays, Formatting and
-- Time_Zones.
-- NOTE: Delays does not need a target independent interface because
-- VMS already has a target specific file for that package.
---------------------------
-- Arithmetic_Operations --
---------------------------
package Arithmetic_Operations is
function Add (Date : Time; Days : Long_Integer) return Time;
-- Add a certain number of days to a time value
procedure Difference
(Left : Time;
Right : Time;
Days : out Long_Integer;
Seconds : out Duration;
Leap_Seconds : out Integer);
-- Calculate the difference between two time values in terms of days,
-- seconds and leap seconds elapsed. The leap seconds are not included
-- in the seconds returned. If Left is greater than Right, the returned
-- values are positive, negative otherwise.
function Subtract (Date : Time; Days : Long_Integer) return Time;
-- Subtract a certain number of days from a time value
end Arithmetic_Operations;
---------------------------
-- Conversion_Operations --
---------------------------
package Conversion_Operations is
function To_Ada_Time (Unix_Time : Long_Integer) return Time;
-- Unix to Ada Epoch conversion
function To_Ada_Time
(tm_year : Integer;
tm_mon : Integer;
tm_day : Integer;
tm_hour : Integer;
tm_min : Integer;
tm_sec : Integer;
tm_isdst : Integer) return Time;
-- Struct tm to Ada Epoch conversion
function To_Duration
(tv_sec : Long_Integer;
tv_nsec : Long_Integer) return Duration;
-- Struct timespec to Duration conversion
procedure To_Struct_Timespec
(D : Duration;
tv_sec : out Long_Integer;
tv_nsec : out Long_Integer);
-- Duration to struct timespec conversion
procedure To_Struct_Tm
(T : Time;
tm_year : out Integer;
tm_mon : out Integer;
tm_day : out Integer;
tm_hour : out Integer;
tm_min : out Integer;
tm_sec : out Integer);
-- Time to struct tm conversion
function To_Unix_Time (Ada_Time : Time) return Long_Integer;
-- Ada to Unix Epoch conversion
end Conversion_Operations;
---------------------------
-- Formatting_Operations --
---------------------------
package Formatting_Operations is
function Day_Of_Week (Date : Time) return Integer;
-- Determine which day of week Date falls on. The returned values are
-- within the range of 0 .. 6 (Monday .. Sunday).
procedure Split
(Date : Time;
Year : out Year_Number;
Month : out Month_Number;
Day : out Day_Number;
Day_Secs : out Day_Duration;
Hour : out Integer;
Minute : out Integer;
Second : out Integer;
Sub_Sec : out Duration;
Leap_Sec : out Boolean;
Use_TZ : Boolean;
Is_Historic : Boolean;
Time_Zone : Long_Integer);
pragma Export (Ada, Split, "__gnat_split");
-- Split a time value into its components. If flag Is_Historic is set,
-- this routine would try to use to the best of the OS's abilities the
-- time zone offset that was or will be in effect on Date. Set Use_TZ
-- to use the local time zone (the value in Time_Zone is ignored) when
-- splitting a time value.
function Time_Of
(Year : Year_Number;
Month : Month_Number;
Day : Day_Number;
Day_Secs : Day_Duration;
Hour : Integer;
Minute : Integer;
Second : Integer;
Sub_Sec : Duration;
Leap_Sec : Boolean;
Use_Day_Secs : Boolean;
Use_TZ : Boolean;
Is_Historic : Boolean;
Time_Zone : Long_Integer) return Time;
pragma Export (Ada, Time_Of, "__gnat_time_of");
-- Given all the components of a date, return the corresponding time
-- value. Set Use_Day_Secs to use the value in Day_Secs, otherwise the
-- day duration will be calculated from Hour, Minute, Second and Sub_
-- Sec. If flag Is_Historic is set, this routine would try to use to the
-- best of the OS's abilities the time zone offset that was or will be
-- in effect on the input date. Set Use_TZ to use the local time zone
-- (the value in formal Time_Zone is ignored) when building a time value
-- and to verify the validity of a requested leap second.
end Formatting_Operations;
---------------------------
-- Time_Zones_Operations --
---------------------------
package Time_Zones_Operations is
function UTC_Time_Offset (Date : Time) return Long_Integer;
-- Return (in seconds) the difference between the local time zone and
-- UTC time at a specific historic date.
end Time_Zones_Operations;
end Ada.Calendar;

200
gcc/ada/a-dirval-vms.adb
View File

@ -1,200 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . D I R E C T O R I E S . V A L I D I T Y --
-- --
-- B o d y --
-- (VMS Version) --
-- --
-- Copyright (C) 2004-2012, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the OpenVMS version of this package
package body Ada.Directories.Validity is
Max_Number_Of_Characters : constant := 39;
Max_Path_Length : constant := 1_024;
Invalid_Character : constant array (Character) of Boolean :=
('a' .. 'z' => False,
'A' .. 'Z' => False,
'0' .. '9' => False,
'_' | '$' | '-' | '.' => False,
others => True);
---------------------------------
-- Is_Path_Name_Case_Sensitive --
---------------------------------
function Is_Path_Name_Case_Sensitive return Boolean is
begin
return False;
end Is_Path_Name_Case_Sensitive;
------------------------
-- Is_Valid_Path_Name --
------------------------
function Is_Valid_Path_Name (Name : String) return Boolean is
First : Positive := Name'First;
Last : Positive;
Dot_Found : Boolean := False;
begin
-- A valid path (directory) name cannot be empty, and cannot contain
-- more than 1024 characters. Directories can be ".", ".." or be simple
-- name without extensions.
if Name'Length = 0 or else Name'Length > Max_Path_Length then
return False;
else
loop
-- Look for the start of the next directory or file name
while First <= Name'Last and then Name (First) = '/' loop
First := First + 1;
end loop;
-- If all directories/file names are OK, return True
exit when First > Name'Last;
Last := First;
Dot_Found := False;
-- Look for the end of the directory/file name
while Last < Name'Last loop
exit when Name (Last + 1) = '/';
Last := Last + 1;
if Name (Last) = '.' then
Dot_Found := True;
end if;
end loop;
-- If name include a dot, it can only be ".", ".." or the last
-- file name.
if Dot_Found then
if Name (First .. Last) /= "." and then
Name (First .. Last) /= ".."
then
return Last = Name'Last
and then Is_Valid_Simple_Name (Name (First .. Last));
end if;
-- Check if the directory/file name is valid
elsif not Is_Valid_Simple_Name (Name (First .. Last)) then
return False;
end if;
-- Move to the next name
First := Last + 1;
end loop;
end if;
-- If Name follows the rules, then it is valid
return True;
end Is_Valid_Path_Name;
--------------------------
-- Is_Valid_Simple_Name --
--------------------------
function Is_Valid_Simple_Name (Name : String) return Boolean is
In_Extension : Boolean := False;
Number_Of_Characters : Natural := 0;
begin
-- A file name cannot be empty, and cannot have more than 39 characters
-- before or after a single '.'.
if Name'Length = 0 then
return False;
else
-- Check each character for validity
for J in Name'Range loop
if Invalid_Character (Name (J)) then
return False;
elsif Name (J) = '.' then
-- Name cannot contain several dots
if In_Extension then
return False;
else
-- Reset the number of characters to count the characters
-- of the extension.
In_Extension := True;
Number_Of_Characters := 0;
end if;
else
-- Check that the number of character is not too large
Number_Of_Characters := Number_Of_Characters + 1;
if Number_Of_Characters > Max_Number_Of_Characters then
return False;
end if;
end if;
end loop;
end if;
-- If the rules are followed, then it is valid
return True;
end Is_Valid_Simple_Name;
-------------
-- OpenVMS --
-------------
function OpenVMS return Boolean is
begin
return True;
end OpenVMS;
-------------
-- Windows --
-------------
function Windows return Boolean is
begin
return False;
end Windows;
end Ada.Directories.Validity;

9
gcc/ada/a-intnam-linux.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- --
@ -31,12 +31,7 @@
-- This is a GNU/Linux version of this package
-- The following signals are reserved by the run time (FSU threads):
-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
-- SIGALRM, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL
-- The following signals are reserved by the run time (LinuxThreads):
-- The following signals are reserved by the run time:
-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT,
-- SIGUSR1, SIGUSR2, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL

80
gcc/ada/a-intnam-vms.ads
View File

@ -1,80 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- A D A . I N T E R R U P T S . N A M E S --
-- --
-- S p e c --
-- --
-- Copyright (C) 1991-2011, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a OpenVMS/Alpha version of this package
-- This target-dependent package spec contains names of interrupts
-- supported by the local system.
with System.OS_Interface;
package Ada.Interrupts.Names is
-- All identifiers in this unit are implementation defined
pragma Implementation_Defined;
package OS renames System.OS_Interface;
Interrupt_ID_0 : constant Interrupt_ID := OS.Interrupt_ID_0;
Interrupt_ID_1 : constant Interrupt_ID := OS.Interrupt_ID_1;
Interrupt_ID_2 : constant Interrupt_ID := OS.Interrupt_ID_2;
Interrupt_ID_3 : constant Interrupt_ID := OS.Interrupt_ID_3;
Interrupt_ID_4 : constant Interrupt_ID := OS.Interrupt_ID_4;
Interrupt_ID_5 : constant Interrupt_ID := OS.Interrupt_ID_5;
Interrupt_ID_6 : constant Interrupt_ID := OS.Interrupt_ID_6;
Interrupt_ID_7 : constant Interrupt_ID := OS.Interrupt_ID_7;
Interrupt_ID_8 : constant Interrupt_ID := OS.Interrupt_ID_8;
Interrupt_ID_9 : constant Interrupt_ID := OS.Interrupt_ID_9;
Interrupt_ID_10 : constant Interrupt_ID := OS.Interrupt_ID_10;
Interrupt_ID_11 : constant Interrupt_ID := OS.Interrupt_ID_11;
Interrupt_ID_12 : constant Interrupt_ID := OS.Interrupt_ID_12;
Interrupt_ID_13 : constant Interrupt_ID := OS.Interrupt_ID_13;
Interrupt_ID_14 : constant Interrupt_ID := OS.Interrupt_ID_14;
Interrupt_ID_15 : constant Interrupt_ID := OS.Interrupt_ID_15;
Interrupt_ID_16 : constant Interrupt_ID := OS.Interrupt_ID_16;
Interrupt_ID_17 : constant Interrupt_ID := OS.Interrupt_ID_17;
Interrupt_ID_18 : constant Interrupt_ID := OS.Interrupt_ID_18;
Interrupt_ID_19 : constant Interrupt_ID := OS.Interrupt_ID_19;
Interrupt_ID_20 : constant Interrupt_ID := OS.Interrupt_ID_20;
Interrupt_ID_21 : constant Interrupt_ID := OS.Interrupt_ID_21;
Interrupt_ID_22 : constant Interrupt_ID := OS.Interrupt_ID_22;
Interrupt_ID_23 : constant Interrupt_ID := OS.Interrupt_ID_23;
Interrupt_ID_24 : constant Interrupt_ID := OS.Interrupt_ID_24;
Interrupt_ID_25 : constant Interrupt_ID := OS.Interrupt_ID_25;
Interrupt_ID_26 : constant Interrupt_ID := OS.Interrupt_ID_26;
Interrupt_ID_27 : constant Interrupt_ID := OS.Interrupt_ID_27;
Interrupt_ID_28 : constant Interrupt_ID := OS.Interrupt_ID_28;
Interrupt_ID_29 : constant Interrupt_ID := OS.Interrupt_ID_29;
Interrupt_ID_30 : constant Interrupt_ID := OS.Interrupt_ID_30;
Interrupt_ID_31 : constant Interrupt_ID := OS.Interrupt_ID_31;
end Ada.Interrupts.Names;

104
gcc/ada/a-numaux-vms.ads
View File

@ -1,104 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . A U X --
-- --
-- S p e c --
-- (VMS Version) --
-- --
-- Copyright (C) 2003-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides the basic computational interface for the generic
-- elementary functions. The C library version interfaces with the routines
-- in the C mathematical library, and is thus quite portable, although it may
-- not necessarily meet the requirements for accuracy in the numerics annex.
-- This is the VMS version
package Ada.Numerics.Aux is
pragma Pure;
type Double is digits 15;
pragma Float_Representation (IEEE_Float, Double);
-- Type Double is the type used to call the C routines. Note that this
-- is IEEE format even when running on VMS with VAX_Native representation
-- since we use the IEEE version of the C library with VMS.
-- We import these functions directly from C. Note that we label them
-- all as pure functions, because indeed all of them are in fact pure.
function Sin (X : Double) return Double;
pragma Import (C, Sin, "MATH$SIN_T");
pragma Pure_Function (Sin);
function Cos (X : Double) return Double;
pragma Import (C, Cos, "MATH$COS_T");
pragma Pure_Function (Cos);
function Tan (X : Double) return Double;
pragma Import (C, Tan, "MATH$TAN_T");
pragma Pure_Function (Tan);
function Exp (X : Double) return Double;
pragma Import (C, Exp, "MATH$EXP_T");
pragma Pure_Function (Exp);
function Sqrt (X : Double) return Double;
pragma Import (C, Sqrt, "MATH$SQRT_T");
pragma Pure_Function (Sqrt);
function Log (X : Double) return Double;
pragma Import (C, Log, "DECC$TLOG_2");
pragma Pure_Function (Log);
function Acos (X : Double) return Double;
pragma Import (C, Acos, "MATH$ACOS_T");
pragma Pure_Function (Acos);
function Asin (X : Double) return Double;
pragma Import (C, Asin, "MATH$ASIN_T");
pragma Pure_Function (Asin);
function Atan (X : Double) return Double;
pragma Import (C, Atan, "MATH$ATAN_T");
pragma Pure_Function (Atan);
function Sinh (X : Double) return Double;
pragma Import (C, Sinh, "MATH$SINH_T");
pragma Pure_Function (Sinh);
function Cosh (X : Double) return Double;
pragma Import (C, Cosh, "MATH$COSH_T");
pragma Pure_Function (Cosh);
function Tanh (X : Double) return Double;
pragma Import (C, Tanh, "MATH$TANH_T");
pragma Pure_Function (Tanh);
function Pow (X, Y : Double) return Double;
pragma Import (C, Pow, "DECC$TPOW_2");
pragma Pure_Function (Pow);
end Ada.Numerics.Aux;

71
gcc/ada/g-eacodu-vms.adb
View File

@ -1,71 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . E X C E P T I O N _ A C T I O N S . C O R E _ D U M P --
-- --
-- B o d y --
-- --
-- Copyright (C) 2003-2012, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the VMS version
with System;
with System.Aux_DEC;
separate (GNAT.Exception_Actions)
procedure Core_Dump (Occurrence : Exception_Occurrence) is
use System;
use System.Aux_DEC;
pragma Unreferenced (Occurrence);
SS_IMGDMP : constant := 1276;
subtype Cond_Value_Type is Unsigned_Longword;
subtype Access_Mode_Type is
Unsigned_Word range 0 .. 3;
Access_Mode_Zero : constant Access_Mode_Type := 0;
Status : Cond_Value_Type;
procedure Setexv (
Status : out Cond_Value_Type;
Vector : Unsigned_Longword := 0;
Addres : Address := Address_Zero;
Acmode : Access_Mode_Type := Access_Mode_Zero;
Prvhnd : Unsigned_Longword := 0);
pragma Import (External, Setexv);
pragma Import_Valued_Procedure (Setexv, "SYS$SETEXV",
(Cond_Value_Type, Unsigned_Longword, Address, Access_Mode_Type,
Unsigned_Longword),
(Value, Value, Value, Value, Value));
procedure Lib_Signal (I : Integer);
pragma Import (C, Lib_Signal);
pragma Import_Procedure (Lib_Signal, "LIB$SIGNAL", Mechanism => (Value));
begin
Setexv (Status, 1, Address_Zero, 3);
Lib_Signal (SS_IMGDMP);
end Core_Dump;

128
gcc/ada/g-enblsp-vms-alpha.adb
View File

@ -1,128 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . E X P E C T . N O N _ B L O C K I N G _ S P A W N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2005-2010, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides a target dependent non-blocking spawn function
-- for use by the VMS GNAT.Expect package (g-expect-vms.adb). This package
-- should not be directly with'ed by an application program.
-- This version is for Alpha/VMS
separate (GNAT.Expect)
procedure Non_Blocking_Spawn
(Descriptor : out Process_Descriptor'Class;
Command : String;
Args : GNAT.OS_Lib.Argument_List;
Buffer_Size : Natural := 4096;
Err_To_Out : Boolean := False)
is
function Alloc_Vfork_Blocks return Integer;
pragma Import (C, Alloc_Vfork_Blocks, "decc$$alloc_vfork_blocks");
function Get_Vfork_Jmpbuf return System.Address;
pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf");
function Get_Current_Invo_Context
(Addr : System.Address) return Process_Id;
pragma Import (C, Get_Current_Invo_Context,
"LIB$GET_CURRENT_INVO_CONTEXT");
Pipe1, Pipe2, Pipe3 : aliased Pipe_Type;
Arg : String_Access;
Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
Command_With_Path : String_Access;
begin
-- Create the rest of the pipes
Set_Up_Communications
(Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
Command_With_Path := Locate_Exec_On_Path (Command);
if Command_With_Path = null then
raise Invalid_Process;
end if;
-- Fork a new process (it is not possible to do this in a subprogram)
Descriptor.Pid :=
(if Alloc_Vfork_Blocks >= 0
then Get_Current_Invo_Context (Get_Vfork_Jmpbuf) else -1);
-- Are we now in the child
if Descriptor.Pid = Null_Pid then
-- Prepare an array of arguments to pass to C
Arg := new String (1 .. Command_With_Path'Length + 1);
Arg (1 .. Command_With_Path'Length) := Command_With_Path.all;
Arg (Arg'Last) := ASCII.NUL;
Arg_List (1) := Arg.all'Address;
for J in Args'Range loop
Arg := new String (1 .. Args (J)'Length + 1);
Arg (1 .. Args (J)'Length) := Args (J).all;
Arg (Arg'Last) := ASCII.NUL;
Arg_List (J + 2 - Args'First) := Arg.all'Address;
end loop;
Arg_List (Arg_List'Last) := System.Null_Address;
-- This does not return on Unix systems
Set_Up_Child_Communications
(Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all,
Arg_List'Address);
end if;
Free (Command_With_Path);
-- Did we have an error when spawning the child ?
if Descriptor.Pid < Null_Pid then
raise Invalid_Process;
else
-- We are now in the parent process
Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3);
end if;
-- Create the buffer
Descriptor.Buffer_Size := Buffer_Size;
if Buffer_Size /= 0 then
Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
end if;
end Non_Blocking_Spawn;

125
gcc/ada/g-enblsp-vms-ia64.adb
View File

@ -1,125 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . E X P E C T . N O N _ B L O C K I N G _ S P A W N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2005-2010, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides a target dependent non-blocking spawn function
-- for use by the VMS GNAT.Expect package (g-expect-vms.adb). This package
-- should not be directly with'ed by an application program.
-- This version is for IA64/VMS
separate (GNAT.Expect)
procedure Non_Blocking_Spawn
(Descriptor : out Process_Descriptor'Class;
Command : String;
Args : GNAT.OS_Lib.Argument_List;
Buffer_Size : Natural := 4096;
Err_To_Out : Boolean := False)
is
function Alloc_Vfork_Blocks return Integer;
pragma Import (C, Alloc_Vfork_Blocks, "decc$$alloc_vfork_blocks");
function Get_Vfork_Jmpbuf return System.Address;
pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf");
function Setjmp1 (Addr : System.Address) return Process_Id;
pragma Import (C, Setjmp1, "decc$setjmp1");
Pipe1, Pipe2, Pipe3 : aliased Pipe_Type;
Arg : String_Access;
Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
Command_With_Path : String_Access;
begin
-- Create the rest of the pipes
Set_Up_Communications
(Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
Command_With_Path := Locate_Exec_On_Path (Command);
if Command_With_Path = null then
raise Invalid_Process;
end if;
-- Fork a new process (it is not possible to do this in a subprogram)
Descriptor.Pid :=
(if Alloc_Vfork_Blocks >= 0 then Setjmp1 (Get_Vfork_Jmpbuf) else -1);
-- Are we now in the child
if Descriptor.Pid = Null_Pid then
-- Prepare an array of arguments to pass to C
Arg := new String (1 .. Command_With_Path'Length + 1);
Arg (1 .. Command_With_Path'Length) := Command_With_Path.all;
Arg (Arg'Last) := ASCII.NUL;
Arg_List (1) := Arg.all'Address;
for J in Args'Range loop
Arg := new String (1 .. Args (J)'Length + 1);
Arg (1 .. Args (J)'Length) := Args (J).all;
Arg (Arg'Last) := ASCII.NUL;
Arg_List (J + 2 - Args'First) := Arg.all'Address;
end loop;
Arg_List (Arg_List'Last) := System.Null_Address;
-- This does not return on Unix systems
Set_Up_Child_Communications
(Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all,
Arg_List'Address);
end if;
Free (Command_With_Path);
-- Did we have an error when spawning the child ?
if Descriptor.Pid < Null_Pid then
raise Invalid_Process;
else
-- We are now in the parent process
Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3);
end if;
-- Create the buffer
Descriptor.Buffer_Size := Buffer_Size;
if Buffer_Size /= 0 then
Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
end if;
end Non_Blocking_Spawn;

1306
gcc/ada/g-expect-vms.adb
View File

File diff suppressed because it is too large Load Diff

501
gcc/ada/g-socthi-vms.adb
View File

@ -1,501 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . S O C K E T S . T H I N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the version for OpenVMS
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Task_Lock;
with Interfaces.C; use Interfaces.C;
package body GNAT.Sockets.Thin is
type VMS_Msghdr is new Msghdr;
pragma Pack (VMS_Msghdr);
-- On VMS 8.x (unlike other platforms), struct msghdr is packed, so a
-- specific derived type is required. This structure was not packed on
-- VMS 7.3.
function Is_VMS_V7 return Integer;
pragma Import (C, Is_VMS_V7, "__gnat_is_vms_v7");
-- Helper (defined in init.c) that returns a non-zero value if the VMS
-- version is 7.x.
VMS_V7 : constant Boolean := Is_VMS_V7 /= 0;
-- True if VMS version is 7.x.
Non_Blocking_Sockets : aliased Fd_Set;
-- When this package is initialized with Process_Blocking_IO set to True,
-- sockets are set in non-blocking mode to avoid blocking the whole process
-- when a thread wants to perform a blocking IO operation. But the user can
-- also set a socket in non-blocking mode by purpose. In order to make a
-- difference between these two situations, we track the origin of
-- non-blocking mode in Non_Blocking_Sockets. Note that if S is in
-- Non_Blocking_Sockets, it has been set in non-blocking mode by the user.
Quantum : constant Duration := 0.2;
-- When SOSC.Thread_Blocking_IO is False, we set sockets to non-blocking
-- mode and we spend a period of time Quantum between two attempts on a
-- blocking operation.
function Syscall_Accept
(S : C.int;
Addr : System.Address;
Addrlen : not null access C.int) return C.int;
pragma Import (C, Syscall_Accept, "accept");
function Syscall_Connect
(S : C.int;
Name : System.Address;
Namelen : C.int) return C.int;
pragma Import (C, Syscall_Connect, "connect");
function Syscall_Recv
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int) return C.int;
pragma Import (C, Syscall_Recv, "recv");
function Syscall_Recvfrom
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
From : System.Address;
Fromlen : not null access C.int) return C.int;
pragma Import (C, Syscall_Recvfrom, "recvfrom");
function Syscall_Recvmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return C.int;
pragma Import (C, Syscall_Recvmsg, "recvmsg");
function Syscall_Sendmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return C.int;
pragma Import (C, Syscall_Sendmsg, "sendmsg");
function Syscall_Sendto
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
To : System.Address;
Tolen : C.int) return C.int;
pragma Import (C, Syscall_Sendto, "sendto");
function Syscall_Socket
(Domain, Typ, Protocol : C.int) return C.int;
pragma Import (C, Syscall_Socket, "socket");
function Non_Blocking_Socket (S : C.int) return Boolean;
procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
--------------
-- C_Accept --
--------------
function C_Accept
(S : C.int;
Addr : System.Address;
Addrlen : not null access C.int) return C.int
is
R : C.int;
Val : aliased C.int := 1;
Discard : C.int;
pragma Warnings (Off, Discard);
begin
loop
R := Syscall_Accept (S, Addr, Addrlen);
exit when SOSC.Thread_Blocking_IO
or else R /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
if not SOSC.Thread_Blocking_IO
and then R /= Failure
then
-- A socket inherits the properties of its server, especially
-- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram
-- tracks sockets set in non-blocking mode by user.
Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
end if;
return R;
end C_Accept;
---------------
-- C_Connect --
---------------
function C_Connect
(S : C.int;
Name : System.Address;
Namelen : C.int) return C.int
is
Res : C.int;
begin
Res := Syscall_Connect (S, Name, Namelen);
if SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EINPROGRESS
then
return Res;
end if;
declare
WSet : aliased Fd_Set;
Now : aliased Timeval;
begin
Reset_Socket_Set (WSet'Access);
loop
Insert_Socket_In_Set (WSet'Access, S);
Now := Immediat;
Res := C_Select
(S + 1,
No_Fd_Set_Access,
WSet'Access,
No_Fd_Set_Access,
Now'Unchecked_Access);
exit when Res > 0;
if Res = Failure then
return Res;
end if;
delay Quantum;
end loop;
end;
Res := Syscall_Connect (S, Name, Namelen);
if Res = Failure and then Errno = SOSC.EISCONN then
return Thin_Common.Success;
else
return Res;
end if;
end C_Connect;
------------------
-- Socket_Ioctl --
------------------
function Socket_Ioctl
(S : C.int;
Req : SOSC.IOCTL_Req_T;
Arg : access C.int) return C.int
is
begin
if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then
if Arg.all /= 0 then
Set_Non_Blocking_Socket (S, True);
end if;
end if;
return C_Ioctl (S, Req, Arg);
end Socket_Ioctl;
------------
-- C_Recv --
------------
function C_Recv
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int) return C.int
is
Res : C.int;
begin
loop
Res := Syscall_Recv (S, Msg, Len, Flags);
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
return Res;
end C_Recv;
----------------
-- C_Recvfrom --
----------------
function C_Recvfrom
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
From : System.Address;
Fromlen : not null access C.int) return C.int
is
Res : C.int;
begin
loop
Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen);
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
return Res;
end C_Recvfrom;
---------------
-- C_Recvmsg --
---------------
function C_Recvmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return System.CRTL.ssize_t
is
Res : C.int;
Msg_Addr : System.Address;
GNAT_Msg : Msghdr;
for GNAT_Msg'Address use Msg;
pragma Import (Ada, GNAT_Msg);
VMS_Msg : aliased VMS_Msghdr;
begin
if VMS_V7 then
Msg_Addr := Msg;
else
VMS_Msg := VMS_Msghdr (GNAT_Msg);
Msg_Addr := VMS_Msg'Address;
end if;
loop
Res := Syscall_Recvmsg (S, Msg_Addr, Flags);
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
if not VMS_V7 then
GNAT_Msg := Msghdr (VMS_Msg);
end if;
return System.CRTL.ssize_t (Res);
end C_Recvmsg;
---------------
-- C_Sendmsg --
---------------
function C_Sendmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return System.CRTL.ssize_t
is
Res : C.int;
Msg_Addr : System.Address;
GNAT_Msg : Msghdr;
for GNAT_Msg'Address use Msg;
pragma Import (Ada, GNAT_Msg);
VMS_Msg : aliased VMS_Msghdr;
begin
if VMS_V7 then
Msg_Addr := Msg;
else
VMS_Msg := VMS_Msghdr (GNAT_Msg);
Msg_Addr := VMS_Msg'Address;
end if;
loop
Res := Syscall_Sendmsg (S, Msg_Addr, Flags);
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
if not VMS_V7 then
GNAT_Msg := Msghdr (VMS_Msg);
end if;
return System.CRTL.ssize_t (Res);
end C_Sendmsg;
--------------
-- C_Sendto --
--------------
function C_Sendto
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
To : System.Address;
Tolen : C.int) return C.int
is
Res : C.int;
begin
loop
Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen);
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
return Res;
end C_Sendto;
--------------
-- C_Socket --
--------------
function C_Socket
(Domain : C.int;
Typ : C.int;
Protocol : C.int) return C.int
is
R : C.int;
Val : aliased C.int := 1;
Discard : C.int;
begin
R := Syscall_Socket (Domain, Typ, Protocol);
if not SOSC.Thread_Blocking_IO
and then R /= Failure
then
-- Do not use Socket_Ioctl as this subprogram tracks sockets set
-- in non-blocking mode by user.
Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access);
Set_Non_Blocking_Socket (R, False);
end if;
return R;
end C_Socket;
--------------
-- Finalize --
--------------
procedure Finalize is
begin
null;
end Finalize;
-------------------------
-- Host_Error_Messages --
-------------------------
package body Host_Error_Messages is separate;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
Reset_Socket_Set (Non_Blocking_Sockets'Access);
end Initialize;
-------------------------
-- Non_Blocking_Socket --
-------------------------
function Non_Blocking_Socket (S : C.int) return Boolean is
R : Boolean;
begin
Task_Lock.Lock;
R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0);
Task_Lock.Unlock;
return R;
end Non_Blocking_Socket;
-----------------------------
-- Set_Non_Blocking_Socket --
-----------------------------
procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is
begin
Task_Lock.Lock;
if V then
Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S);
else
Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S);
end if;
Task_Lock.Unlock;
end Set_Non_Blocking_Socket;
--------------------
-- Signalling_Fds --
--------------------
package body Signalling_Fds is separate;
--------------------------
-- Socket_Error_Message --
--------------------------
function Socket_Error_Message (Errno : Integer) return String is separate;
end GNAT.Sockets.Thin;

257
gcc/ada/g-socthi-vms.ads
View File

@ -1,257 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . S O C K E T S . T H I N --
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2013, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides a target dependent thin interface to the sockets
-- layer for use by the GNAT.Sockets package (g-socket.ads). This package
-- should not be directly with'ed by an applications program.
-- This is the Alpha/VMS version
with Interfaces.C;
with GNAT.OS_Lib;
with GNAT.Sockets.Thin_Common;
with System;
with System.CRTL;
package GNAT.Sockets.Thin is
-- ??? more comments needed ???
use Thin_Common;
package C renames Interfaces.C;
use type System.CRTL.ssize_t;
function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
-- Returns last socket error number
procedure Set_Socket_Errno (Errno : Integer) renames GNAT.OS_Lib.Set_Errno;
-- Set last socket error number
function Socket_Error_Message (Errno : Integer) return String;
-- Returns the error message string for the error number Errno. If Errno is
-- not known, returns "Unknown system error".
function Host_Errno return Integer;
pragma Import (C, Host_Errno, "__gnat_get_h_errno");
-- Returns last host error number
package Host_Error_Messages is
function Host_Error_Message (H_Errno : Integer) return String;
-- Returns the error message string for the host error number H_Errno.
-- If H_Errno is not known, returns "Unknown system error".
end Host_Error_Messages;
--------------------------------
-- Standard library functions --
--------------------------------
function C_Accept
(S : C.int;
Addr : System.Address;
Addrlen : not null access C.int) return C.int;
function C_Bind
(S : C.int;
Name : System.Address;
Namelen : C.int) return C.int;
function C_Close
(Fd : C.int) return C.int;
function C_Connect
(S : C.int;
Name : System.Address;
Namelen : C.int) return C.int;
function C_Gethostname
(Name : System.Address;
Namelen : C.int) return C.int;
function C_Getpeername
(S : C.int;
Name : System.Address;
Namelen : not null access C.int) return C.int;
function C_Getsockname
(S : C.int;
Name : System.Address;
Namelen : not null access C.int) return C.int;
function C_Getsockopt
(S : C.int;
Level : C.int;
Optname : C.int;
Optval : System.Address;
Optlen : not null access C.int) return C.int;
function Socket_Ioctl
(S : C.int;
Req : SOSC.IOCTL_Req_T;
Arg : access C.int) return C.int;
function C_Listen
(S : C.int;
Backlog : C.int) return C.int;
function C_Recv
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int) return C.int;
function C_Recvfrom
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
From : System.Address;
Fromlen : not null access C.int) return C.int;
function C_Recvmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return System.CRTL.ssize_t;
function C_Select
(Nfds : C.int;
Readfds : access Fd_Set;
Writefds : access Fd_Set;
Exceptfds : access Fd_Set;
Timeout : Timeval_Access) return C.int;
function C_Sendmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return System.CRTL.ssize_t;
function C_Sendto
(S : C.int;
Msg : System.Address;
Len : C.int;
Flags : C.int;
To : System.Address;
Tolen : C.int) return C.int;
function C_Setsockopt
(S : C.int;
Level : C.int;
Optname : C.int;
Optval : System.Address;
Optlen : C.int) return C.int;
function C_Shutdown
(S : C.int;
How : C.int) return C.int;
function C_Socket
(Domain : C.int;
Typ : C.int;
Protocol : C.int) return C.int;
function C_System
(Command : System.Address) return C.int;
-------------------------------------------------------
-- Signalling file descriptors for selector abortion --
-------------------------------------------------------
package Signalling_Fds is
function Create (Fds : not null access Fd_Pair) return C.int;
pragma Convention (C, Create);
-- Create a pair of connected descriptors suitable for use with C_Select
-- (used for signalling in Selector objects).
function Read (Rsig : C.int) return C.int;
pragma Convention (C, Read);
-- Read one byte of data from rsig, the read end of a pair of signalling
-- fds created by Create_Signalling_Fds.
function Write (Wsig : C.int) return C.int;
pragma Convention (C, Write);
-- Write one byte of data to wsig, the write end of a pair of signalling
-- fds created by Create_Signalling_Fds.
procedure Close (Sig : C.int);
pragma Convention (C, Close);
-- Close one end of a pair of signalling fds (ignoring any error)
end Signalling_Fds;
-------------------------------------------
-- Nonreentrant network databases access --
-------------------------------------------
function Nonreentrant_Gethostbyname
(Name : C.char_array) return Hostent_Access;
function Nonreentrant_Gethostbyaddr
(Addr : System.Address;
Addr_Len : C.int;
Addr_Type : C.int) return Hostent_Access;
function Nonreentrant_Getservbyname
(Name : C.char_array;
Proto : C.char_array) return Servent_Access;
function Nonreentrant_Getservbyport
(Port : C.int;
Proto : C.char_array) return Servent_Access;
procedure Initialize;
procedure Finalize;
private
pragma Import (C, C_Bind, "DECC$BIND");
pragma Import (C, C_Close, "DECC$CLOSE");
pragma Import (C, C_Gethostname, "DECC$GETHOSTNAME");
pragma Import (C, C_Getpeername, "DECC$GETPEERNAME");
pragma Import (C, C_Getsockname, "DECC$GETSOCKNAME");
pragma Import (C, C_Getsockopt, "DECC$GETSOCKOPT");
pragma Import (C, C_Listen, "DECC$LISTEN");
pragma Import (C, C_Select, "DECC$SELECT");
pragma Import (C, C_Setsockopt, "DECC$SETSOCKOPT");
pragma Import (C, C_Shutdown, "DECC$SHUTDOWN");
pragma Import (C, C_System, "DECC$SYSTEM");
pragma Import (C, Nonreentrant_Gethostbyname, "DECC$GETHOSTBYNAME");
pragma Import (C, Nonreentrant_Gethostbyaddr, "DECC$GETHOSTBYADDR");
pragma Import (C, Nonreentrant_Getservbyname, "DECC$GETSERVBYNAME");
pragma Import (C, Nonreentrant_Getservbyport, "DECC$GETSERVBYPORT");
end GNAT.Sockets.Thin;

253
gcc/ada/i-cstrea-vms.adb
View File

@ -1,253 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- I N T E R F A C E S . C _ S T R E A M S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2009, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the Alpha/VMS version
with Ada.Unchecked_Conversion;
package body Interfaces.C_Streams is
use type System.CRTL.size_t;
-- As the functions fread, fwrite and setvbuf are too big to be inlined,
-- they are just wrappers to the following implementation functions.
function fread_impl
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t;
function fread_impl
(buffer : voids;
index : size_t;
size : size_t;
count : size_t;
stream : FILEs) return size_t;
function fwrite_impl
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t;
function setvbuf_impl
(stream : FILEs;
buffer : chars;
mode : int;
size : size_t) return int;
------------
-- fread --
------------
function fread_impl
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
Get_Count : size_t := 0;
type Buffer_Type is array (size_t range 1 .. count,
size_t range 1 .. size) of Character;
type Buffer_Access is access Buffer_Type;
function To_BA is new Ada.Unchecked_Conversion (voids, Buffer_Access);
BA : constant Buffer_Access := To_BA (buffer);
Ch : int;
begin
-- This Fread goes with the Fwrite below. The C library fread sometimes
-- can't read fputc generated files.
for C in 1 .. count loop
for S in 1 .. size loop
Ch := fgetc (stream);
if Ch = EOF then
return Get_Count;
end if;
BA.all (C, S) := Character'Val (Ch);
end loop;
Get_Count := Get_Count + 1;
end loop;
return Get_Count;
end fread_impl;
function fread_impl
(buffer : voids;
index : size_t;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
Get_Count : size_t := 0;
type Buffer_Type is array (size_t range 1 .. count,
size_t range 1 .. size) of Character;
type Buffer_Access is access Buffer_Type;
function To_BA is new Ada.Unchecked_Conversion (voids, Buffer_Access);
BA : constant Buffer_Access := To_BA (buffer);
Ch : int;
begin
-- This Fread goes with the Fwrite below. The C library fread sometimes
-- can't read fputc generated files.
for C in 1 + index .. count + index loop
for S in 1 .. size loop
Ch := fgetc (stream);
if Ch = EOF then
return Get_Count;
end if;
BA.all (C, S) := Character'Val (Ch);
end loop;
Get_Count := Get_Count + 1;
end loop;
return Get_Count;
end fread_impl;
function fread
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
begin
return fread_impl (buffer, size, count, stream);
end fread;
function fread
(buffer : voids;
index : size_t;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
begin
return fread_impl (buffer, index, size, count, stream);
end fread;
------------
-- fwrite --
------------
function fwrite_impl
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
Put_Count : size_t := 0;
type Buffer_Type is array (size_t range 1 .. count,
size_t range 1 .. size) of Character;
type Buffer_Access is access Buffer_Type;
function To_BA is new Ada.Unchecked_Conversion (voids, Buffer_Access);
BA : constant Buffer_Access := To_BA (buffer);
begin
-- Fwrite on VMS has the undesirable effect of always generating at
-- least one record of output per call, regardless of buffering. To
-- get around this, we do multiple fputc calls instead.
for C in 1 .. count loop
for S in 1 .. size loop
if fputc (Character'Pos (BA.all (C, S)), stream) = EOF then
return Put_Count;
end if;
end loop;
Put_Count := Put_Count + 1;
end loop;
return Put_Count;
end fwrite_impl;
function fwrite
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
begin
return fwrite_impl (buffer, size, count, stream);
end fwrite;
-------------
-- setvbuf --
-------------
function setvbuf_impl
(stream : FILEs;
buffer : chars;
mode : int;
size : size_t) return int
is
use type System.Address;
begin
-- In order for the above fwrite hack to work, we must always buffer
-- stdout and stderr. Is_regular_file on VMS cannot detect when
-- these are redirected to a file, so checking for that condition
-- doesn't help.
if mode = IONBF
and then (stream = stdout or else stream = stderr)
then
return System.CRTL.setvbuf
(stream, buffer, IOLBF, System.CRTL.size_t (size));
else
return System.CRTL.setvbuf
(stream, buffer, mode, System.CRTL.size_t (size));
end if;
end setvbuf_impl;
function setvbuf
(stream : FILEs;
buffer : chars;
mode : int;
size : size_t) return int
is
begin
return setvbuf_impl (stream, buffer, mode, size);
end setvbuf;
end Interfaces.C_Streams;

509
gcc/ada/mlib-tgt-specific-vms-alpha.adb
View File

@ -1,509 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- M L I B . T G T . S P E C I F I C --
-- (Alpha VMS Version) --
-- --
-- B o d y --
-- --
-- Copyright (C) 2003-2011, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the Alpha VMS version of the body
with Ada.Characters.Handling; use Ada.Characters.Handling;
with MLib.Fil;
with MLib.Utl;
with MLib.Tgt.VMS_Common; use MLib.Tgt.VMS_Common;
with Opt; use Opt;
with Output; use Output;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with System; use System;
with System.Case_Util; use System.Case_Util;
with System.CRTL; use System.CRTL;
package body MLib.Tgt.Specific is
-- Non default subprogram. See comment in mlib-tgt.ads
procedure Build_Dynamic_Library
(Ofiles : Argument_List;
Options : Argument_List;
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Version : String := "";
Auto_Init : Boolean := False);
-- Local variables
Empty_Argument_List : aliased Argument_List := (1 .. 0 => null);
Additional_Objects : Argument_List_Access := Empty_Argument_List'Access;
-- Used to add the generated auto-init object files for auto-initializing
-- stand-alone libraries.
Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler";
-- The name of the command to invoke the macro-assembler
VMS_Options : Argument_List := (1 .. 1 => null);
Gnatsym_Name : constant String := "gnatsym";
Gnatsym_Path : String_Access;
Arguments : Argument_List_Access := null;
Last_Argument : Natural := 0;
Success : Boolean := False;
Shared_Libgcc : aliased String := "-shared-libgcc";
Shared_Libgcc_Switch : constant Argument_List :=
(1 => Shared_Libgcc'Access);
---------------------------
-- Build_Dynamic_Library --
---------------------------
procedure Build_Dynamic_Library
(Ofiles : Argument_List;
Options : Argument_List;
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Version : String := "";
Auto_Init : Boolean := False)
is
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
Fil.Ext_To (Lib_Filename, DLL_Ext);
Opts : Argument_List := Options;
Last_Opt : Natural := Opts'Last;
Opts2 : Argument_List (Options'Range);
Last_Opt2 : Natural := Opts2'First - 1;
Inter : constant Argument_List := Interfaces;
function Is_Interface (Obj_File : String) return Boolean;
-- For a Stand-Alone Library, returns True if Obj_File is the object
-- file name of an interface of the SAL. For other libraries, always
-- return True.
function Option_File_Name return String;
-- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt"
function Version_String return String;
-- Returns Lib_Version if not empty and if Symbol_Data.Symbol_Policy is
-- not Autonomous, otherwise returns "". When Symbol_Data.Symbol_Policy
-- is Autonomous, fails gnatmake if Lib_Version is not the image of a
-- positive number.
------------------
-- Is_Interface --
------------------
function Is_Interface (Obj_File : String) return Boolean is
ALI : constant String :=
Fil.Ext_To
(Filename => To_Lower (Base_Name (Obj_File)),
New_Ext => "ali");
begin
if Inter'Length = 0 then
return True;
elsif ALI'Length > 2 and then
ALI (ALI'First .. ALI'First + 2) = "b__"
then
return True;
else
for J in Inter'Range loop
if Inter (J).all = ALI then
return True;
end if;
end loop;
return False;
end if;
end Is_Interface;
----------------------
-- Option_File_Name --
----------------------
function Option_File_Name return String is
begin
if Symbol_Data.Symbol_File = No_Path then
return "symvec.opt";
else
Get_Name_String (Symbol_Data.Symbol_File);
To_Lower (Name_Buffer (1 .. Name_Len));
return Name_Buffer (1 .. Name_Len);
end if;
end Option_File_Name;
--------------------
-- Version_String --
--------------------
function Version_String return String is
Version : Integer := 0;
begin
if Lib_Version = ""
or else Symbol_Data.Symbol_Policy /= Autonomous
then
return "";
else
begin
Version := Integer'Value (Lib_Version);
if Version <= 0 then
raise Constraint_Error;
end if;
return Lib_Version;
exception
when Constraint_Error =>
Fail ("illegal version """
& Lib_Version
& """ (on VMS version must be a positive number)");
return "";
end;
end if;
end Version_String;
---------------------
-- Local Variables --
---------------------
Opt_File_Name : constant String := Option_File_Name;
Version : constant String := Version_String;
For_Linker_Opt : String_Access;
-- Start of processing for Build_Dynamic_Library
begin
-- If option file name does not ends with ".opt", append "/OPTIONS"
-- to its specification for the VMS linker.
if Opt_File_Name'Length > 4
and then
Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt"
then
For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name);
else
For_Linker_Opt :=
new String'("--for-linker=" & Opt_File_Name & "/OPTIONS");
end if;
VMS_Options (VMS_Options'First) := For_Linker_Opt;
for J in Inter'Range loop
To_Lower (Inter (J).all);
end loop;
-- "gnatsym" is necessary for building the option file
if Gnatsym_Path = null then
Gnatsym_Path := Locate_Exec_On_Path (Gnatsym_Name);
if Gnatsym_Path = null then
Fail (Gnatsym_Name & " not found in path");
end if;
end if;
-- For auto-initialization of a stand-alone library, we create
-- a macro-assembly file and we invoke the macro-assembler.
if Auto_Init then
declare
Macro_File_Name : constant String := Lib_Filename & "__init.asm";
Macro_File : File_Descriptor;
Init_Proc : constant String := Init_Proc_Name (Lib_Filename);
Popen_Result : System.Address;
Pclose_Result : Integer;
Len : Natural;
OK : Boolean := True;
command : constant String :=
Macro_Name & " " & Macro_File_Name & ASCII.NUL;
-- The command to invoke the assembler on the generated auto-init
-- assembly file.
mode : constant String := "r" & ASCII.NUL;
-- The mode for the invocation of Popen
begin
if Verbose_Mode then
Write_Str ("Creating auto-init assembly file """);
Write_Str (Macro_File_Name);
Write_Line ("""");
end if;
-- Create and write the auto-init assembly file
declare
use ASCII;
-- Output a dummy transfer address for debugging
-- followed by the LIB$INITIALIZE section.
Lines : constant String :=
HT & ".text" & LF &
HT & ".align 4" & LF &
HT & ".globl __main" & LF &
HT & ".ent __main" & LF &
"__main..en:" & LF &
HT & ".base $27" & LF &
HT & ".frame $29,0,$26,8" & LF &
HT & "ret $31,($26),1" & LF &
HT & ".link" & LF &
"__main:" & LF &
HT & ".pdesc __main..en,null" & LF &
HT & ".end __main" & LF & LF &
HT & ".section LIB$INITIALIZE,GBL,NOWRT" & LF &
HT & ".long " & Init_Proc & LF;
begin
Macro_File := Create_File (Macro_File_Name, Text);
OK := Macro_File /= Invalid_FD;
if OK then
Len := Write
(Macro_File, Lines (Lines'First)'Address,
Lines'Length);
OK := Len = Lines'Length;
end if;
if OK then
Close (Macro_File, OK);
end if;
if not OK then
Fail ("creation of auto-init assembly file """
& Macro_File_Name
& """ failed");
end if;
end;
-- Invoke the macro-assembler
if Verbose_Mode then
Write_Str ("Assembling auto-init assembly file """);
Write_Str (Macro_File_Name);
Write_Line ("""");
end if;
Popen_Result := popen (command (command'First)'Address,
mode (mode'First)'Address);
if Popen_Result = Null_Address then
Fail ("assembly of auto-init assembly file """
& Macro_File_Name
& """ failed");
end if;
-- Wait for the end of execution of the macro-assembler
Pclose_Result := pclose (Popen_Result);
if Pclose_Result < 0 then
Fail ("assembly of auto init assembly file """
& Macro_File_Name
& """ failed");
end if;
-- Add the generated object file to the list of objects to be
-- included in the library.
Additional_Objects :=
new Argument_List'
(1 => new String'(Lib_Filename & "__init.obj"));
end;
end if;
-- Allocate the argument list and put the symbol file name, the
-- reference (if any) and the policy (if not autonomous).
Arguments := new Argument_List (1 .. Ofiles'Length + 8);
Last_Argument := 0;
-- Verbosity
if Verbose_Mode then
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-v");
end if;
-- Version number (major ID)
if Lib_Version /= "" then
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-V");
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'(Version);
end if;
-- Symbol file
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-s");
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'(Opt_File_Name);
-- Reference Symbol File
if Symbol_Data.Reference /= No_Path then
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-r");
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) :=
new String'(Get_Name_String (Symbol_Data.Reference));
end if;
-- Policy
case Symbol_Data.Symbol_Policy is
when Autonomous =>
null;
when Compliant =>
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-c");
when Controlled =>
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-C");
when Restricted =>
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-R");
when Direct =>
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-D");
end case;
-- Add each relevant object file
for Index in Ofiles'Range loop
if Is_Interface (Ofiles (Index).all) then
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'(Ofiles (Index).all);
end if;
end loop;
-- Spawn gnatsym
Spawn (Program_Name => Gnatsym_Path.all,
Args => Arguments (1 .. Last_Argument),
Success => Success);
if not Success then
Fail ("unable to create symbol file for library """
& Lib_Filename
& """");
end if;
Free (Arguments);
-- Move all the -l switches from Opts to Opts2
declare
Index : Natural := Opts'First;
Opt : String_Access;
begin
while Index <= Last_Opt loop
Opt := Opts (Index);
if Opt'Length > 2 and then
Opt (Opt'First .. Opt'First + 1) = "-l"
then
if Index < Last_Opt then
Opts (Index .. Last_Opt - 1) :=
Opts (Index + 1 .. Last_Opt);
end if;
Last_Opt := Last_Opt - 1;
Last_Opt2 := Last_Opt2 + 1;
Opts2 (Last_Opt2) := Opt;
else
Index := Index + 1;
end if;
end loop;
end;
-- Invoke gcc to build the library
Utl.Gcc
(Output_File => Lib_File,
Objects => Ofiles & Additional_Objects.all,
Options => VMS_Options,
Options_2 => Shared_Libgcc_Switch &
Opts (Opts'First .. Last_Opt) &
Opts2 (Opts2'First .. Last_Opt2),
Driver_Name => Driver_Name);
-- The auto-init object file need to be deleted, so that it will not
-- be included in the library as a regular object file, otherwise
-- it will be included twice when the library will be built next
-- time, which may lead to errors.
if Auto_Init then
declare
Auto_Init_Object_File_Name : constant String :=
Lib_Filename & "__init.obj";
Disregard : Boolean;
begin
if Verbose_Mode then
Write_Str ("deleting auto-init object file """);
Write_Str (Auto_Init_Object_File_Name);
Write_Line ("""");
end if;
Delete_File (Auto_Init_Object_File_Name, Success => Disregard);
end;
end if;
end Build_Dynamic_Library;
-- Package initialization
begin
Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access;
end MLib.Tgt.Specific;

513
gcc/ada/mlib-tgt-specific-vms-ia64.adb
View File

@ -1,513 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- M L I B . T G T . S P E C I F I C --
-- (Integrity VMS Version) --
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2011, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the Integrity VMS version of the body
with Ada.Characters.Handling; use Ada.Characters.Handling;
with MLib.Fil;
with MLib.Utl;
with MLib.Tgt.VMS_Common; use MLib.Tgt.VMS_Common;
with Opt; use Opt;
with Output; use Output;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
with System; use System;
with System.Case_Util; use System.Case_Util;
with System.CRTL; use System.CRTL;
package body MLib.Tgt.Specific is
-- Non default subprogram, see comment in mlib-tgt.ads
procedure Build_Dynamic_Library
(Ofiles : Argument_List;
Options : Argument_List;
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Version : String := "";
Auto_Init : Boolean := False);
-- Local variables
Empty_Argument_List : aliased Argument_List := (1 .. 0 => null);
Additional_Objects : Argument_List_Access := Empty_Argument_List'Access;
-- Used to add the generated auto-init object files for auto-initializing
-- stand-alone libraries.
Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler";
-- The name of the command to invoke the macro-assembler
VMS_Options : Argument_List := (1 .. 1 => null);
Gnatsym_Name : constant String := "gnatsym";
Gnatsym_Path : String_Access;
Arguments : Argument_List_Access := null;
Last_Argument : Natural := 0;
Success : Boolean := False;
Shared_Libgcc : aliased String := "-shared-libgcc";
Shared_Libgcc_Switch : constant Argument_List :=
(1 => Shared_Libgcc'Access);
---------------------------
-- Build_Dynamic_Library --
---------------------------
procedure Build_Dynamic_Library
(Ofiles : Argument_List;
Options : Argument_List;
Interfaces : Argument_List;
Lib_Filename : String;
Lib_Dir : String;
Symbol_Data : Symbol_Record;
Driver_Name : Name_Id := No_Name;
Lib_Version : String := "";
Auto_Init : Boolean := False)
is
Lib_File : constant String :=
Lib_Dir & Directory_Separator & "lib" &
Fil.Ext_To (Lib_Filename, DLL_Ext);
Opts : Argument_List := Options;
Last_Opt : Natural := Opts'Last;
Opts2 : Argument_List (Options'Range);
Last_Opt2 : Natural := Opts2'First - 1;
Inter : constant Argument_List := Interfaces;
function Is_Interface (Obj_File : String) return Boolean;
-- For a Stand-Alone Library, returns True if Obj_File is the object
-- file name of an interface of the SAL. For other libraries, always
-- return True.
function Option_File_Name return String;
-- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt"
function Version_String return String;
-- Returns Lib_Version if not empty and if Symbol_Data.Symbol_Policy is
-- not Autonomous, otherwise returns "". When Symbol_Data.Symbol_Policy
-- is Autonomous, fails gnatmake if Lib_Version is not the image of a
-- positive number.
------------------
-- Is_Interface --
------------------
function Is_Interface (Obj_File : String) return Boolean is
ALI : constant String :=
Fil.Ext_To
(Filename => To_Lower (Base_Name (Obj_File)),
New_Ext => "ali");
begin
if Inter'Length = 0 then
return True;
elsif ALI'Length > 2 and then
ALI (ALI'First .. ALI'First + 2) = "b__"
then
return True;
else
for J in Inter'Range loop
if Inter (J).all = ALI then
return True;
end if;
end loop;
return False;
end if;
end Is_Interface;
----------------------
-- Option_File_Name --
----------------------
function Option_File_Name return String is
begin
if Symbol_Data.Symbol_File = No_Path then
return "symvec.opt";
else
Get_Name_String (Symbol_Data.Symbol_File);
To_Lower (Name_Buffer (1 .. Name_Len));
return Name_Buffer (1 .. Name_Len);
end if;
end Option_File_Name;
--------------------
-- Version_String --
--------------------
function Version_String return String is
Version : Integer := 0;
begin
if Lib_Version = ""
or else Symbol_Data.Symbol_Policy /= Autonomous
then
return "";
else
begin
Version := Integer'Value (Lib_Version);
if Version <= 0 then
raise Constraint_Error;
end if;
return Lib_Version;
exception
when Constraint_Error =>
Fail ("illegal version """
& Lib_Version
& """ (on VMS version must be a positive number)");
return "";
end;
end if;
end Version_String;
---------------------
-- Local Variables --
---------------------
Opt_File_Name : constant String := Option_File_Name;
Version : constant String := Version_String;
For_Linker_Opt : String_Access;
-- Start of processing for Build_Dynamic_Library
begin
-- Option file must end with ".opt"
if Opt_File_Name'Length > 4
and then
Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt"
then
For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name);
else
Fail ("Options File """ & Opt_File_Name & """ must end with .opt");
end if;
VMS_Options (VMS_Options'First) := For_Linker_Opt;
for J in Inter'Range loop
To_Lower (Inter (J).all);
end loop;
-- "gnatsym" is necessary for building the option file
if Gnatsym_Path = null then
Gnatsym_Path := Locate_Exec_On_Path (Gnatsym_Name);
if Gnatsym_Path = null then
Fail (Gnatsym_Name & " not found in path");
end if;
end if;
-- For auto-initialization of a stand-alone library, we create
-- a macro-assembly file and we invoke the macro-assembler.
if Auto_Init then
declare
Macro_File_Name : constant String := Lib_Filename & "__init.asm";
Macro_File : File_Descriptor;
Init_Proc : constant String := Init_Proc_Name (Lib_Filename);
Popen_Result : System.Address;
Pclose_Result : Integer;
Len : Natural;
OK : Boolean := True;
command : constant String :=
Macro_Name & " " & Macro_File_Name & ASCII.NUL;
-- The command to invoke the assembler on the generated auto-init
-- assembly file.
-- Why odd lower case name ???
mode : constant String := "r" & ASCII.NUL;
-- The mode for the invocation of Popen
-- Why odd lower case name ???
begin
if Verbose_Mode then
Write_Str ("Creating auto-init assembly file """);
Write_Str (Macro_File_Name);
Write_Line ("""");
end if;
-- Create and write the auto-init assembly file
declare
use ASCII;
-- Output a dummy transfer address for debugging
-- followed by the LIB$INITIALIZE section.
Lines : constant String :=
HT & ".pred.safe_across_calls p1-p5,p16-p63" & LF &
HT & ".text" & LF &
HT & ".align 16" & LF &
HT & ".global __main#" & LF &
HT & ".proc __main#" & LF &
"__main:" & LF &
HT & ".prologue" & LF &
HT & ".body" & LF &
HT & ".mib" & LF &
HT & "nop 0" & LF &
HT & "nop 0" & LF &
HT & "br.ret.sptk.many b0" & LF &
HT & ".endp __main#" & LF & LF &
HT & ".type " & Init_Proc & "#, @function" & LF &
HT & ".global " & Init_Proc & "#" & LF &
HT & ".global LIB$INITIALIZE#" & LF &
HT & ".section LIB$INITIALIZE#,""a"",@progbits" & LF &
HT & "data4 @fptr(" & Init_Proc & "#)" & LF;
begin
Macro_File := Create_File (Macro_File_Name, Text);
OK := Macro_File /= Invalid_FD;
if OK then
Len := Write
(Macro_File, Lines (Lines'First)'Address,
Lines'Length);
OK := Len = Lines'Length;
end if;
if OK then
Close (Macro_File, OK);
end if;
if not OK then
Fail ("creation of auto-init assembly file """
& Macro_File_Name
& """ failed");
end if;
end;
-- Invoke the macro-assembler
if Verbose_Mode then
Write_Str ("Assembling auto-init assembly file """);
Write_Str (Macro_File_Name);
Write_Line ("""");
end if;
Popen_Result := popen (command (command'First)'Address,
mode (mode'First)'Address);
if Popen_Result = Null_Address then
Fail ("assembly of auto-init assembly file """
& Macro_File_Name
& """ failed");
end if;
-- Wait for the end of execution of the macro-assembler
Pclose_Result := pclose (Popen_Result);
if Pclose_Result < 0 then
Fail ("assembly of auto init assembly file """
& Macro_File_Name
& """ failed");
end if;
-- Add the generated object file to the list of objects to be
-- included in the library.
Additional_Objects :=
new Argument_List'
(1 => new String'(Lib_Filename & "__init.obj"));
end;
end if;
-- Allocate the argument list and put the symbol file name, the
-- reference (if any) and the policy (if not autonomous).
Arguments := new Argument_List (1 .. Ofiles'Length + 8);
Last_Argument := 0;
-- Verbosity
if Verbose_Mode then
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-v");
end if;
-- Version number (major ID)
if Lib_Version /= "" then
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-V");
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'(Version);
end if;
-- Symbol file
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-s");
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'(Opt_File_Name);
-- Reference Symbol File
if Symbol_Data.Reference /= No_Path then
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-r");
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) :=
new String'(Get_Name_String (Symbol_Data.Reference));
end if;
-- Policy
case Symbol_Data.Symbol_Policy is
when Autonomous =>
null;
when Compliant =>
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-c");
when Controlled =>
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-C");
when Restricted =>
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-R");
when Direct =>
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'("-D");
end case;
-- Add each relevant object file
for Index in Ofiles'Range loop
if Is_Interface (Ofiles (Index).all) then
Last_Argument := Last_Argument + 1;
Arguments (Last_Argument) := new String'(Ofiles (Index).all);
end if;
end loop;
-- Spawn gnatsym
Spawn (Program_Name => Gnatsym_Path.all,
Args => Arguments (1 .. Last_Argument),
Success => Success);
if not Success then
Fail ("unable to create symbol file for library """
& Lib_Filename
& """");
end if;
Free (Arguments);
-- Move all the -l switches from Opts to Opts2
declare
Index : Natural := Opts'First;
Opt : String_Access;
begin
while Index <= Last_Opt loop
Opt := Opts (Index);
if Opt'Length > 2 and then
Opt (Opt'First .. Opt'First + 1) = "-l"
then
if Index < Last_Opt then
Opts (Index .. Last_Opt - 1) :=
Opts (Index + 1 .. Last_Opt);
end if;
Last_Opt := Last_Opt - 1;
Last_Opt2 := Last_Opt2 + 1;
Opts2 (Last_Opt2) := Opt;
else
Index := Index + 1;
end if;
end loop;
end;
-- Invoke gcc to build the library
Utl.Gcc
(Output_File => Lib_File,
Objects => Ofiles & Additional_Objects.all,
Options => VMS_Options,
Options_2 => Shared_Libgcc_Switch &
Opts (Opts'First .. Last_Opt) &
Opts2 (Opts2'First .. Last_Opt2),
Driver_Name => Driver_Name);
-- The auto-init object file need to be deleted, so that it will not
-- be included in the library as a regular object file, otherwise
-- it will be included twice when the library will be built next
-- time, which may lead to errors.
if Auto_Init then
declare
Auto_Init_Object_File_Name : constant String :=
Lib_Filename & "__init.obj";
Disregard : Boolean;
pragma Warnings (Off, Disregard);
begin
if Verbose_Mode then
Write_Str ("deleting auto-init object file """);
Write_Str (Auto_Init_Object_File_Name);
Write_Line ("""");
end if;
Delete_File (Auto_Init_Object_File_Name, Success => Disregard);
end;
end if;
end Build_Dynamic_Library;
-- Package initialization
begin
Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access;
end MLib.Tgt.Specific;

174
gcc/ada/mlib-tgt-vms_common.adb
View File

@ -1,174 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- M L I B . T G T . V M S _ C O M M O N --
-- --
-- B o d y --
-- --
-- Copyright (C) 2003-2011, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the part of MLib.Tgt.Specific common to both VMS versions
with System.Case_Util; use System.Case_Util;
package body MLib.Tgt.VMS_Common is
-- Non default subprograms. See comments in mlib-tgt.ads
function Archive_Ext return String;
function Default_Symbol_File_Name return String;
function DLL_Ext return String;
function Is_Object_Ext (Ext : String) return Boolean;
function Is_Archive_Ext (Ext : String) return Boolean;
function Libgnat return String;
function Object_Ext return String;
function Library_Major_Minor_Id_Supported return Boolean;
function PIC_Option return String;
-----------------
-- Archive_Ext --
-----------------
function Archive_Ext return String is
begin
return "olb";
end Archive_Ext;
------------------------------
-- Default_Symbol_File_Name --
------------------------------
function Default_Symbol_File_Name return String is
begin
return "symvec.opt";
end Default_Symbol_File_Name;
-------------
-- DLL_Ext --
-------------
function DLL_Ext return String is
begin
return "exe";
end DLL_Ext;
--------------------
-- Init_Proc_Name --
--------------------
function Init_Proc_Name (Library_Name : String) return String is
Result : String := Library_Name & "INIT";
begin
To_Upper (Result);
if Result = "ADAINIT" then
return "ADA_INIT";
else
return Result;
end if;
end Init_Proc_Name;
-------------------
-- Is_Object_Ext --
-------------------
function Is_Object_Ext (Ext : String) return Boolean is
begin
return Ext = ".obj";
end Is_Object_Ext;
--------------------
-- Is_Archive_Ext --
--------------------
function Is_Archive_Ext (Ext : String) return Boolean is
begin
return Ext = ".olb" or else Ext = ".exe";
end Is_Archive_Ext;
-------------
-- Libgnat --
-------------
function Libgnat return String is
Libgnat_A : constant String := "libgnat.a";
Libgnat_Olb : constant String := "libgnat.olb";
begin
Name_Len := Libgnat_A'Length;
Name_Buffer (1 .. Name_Len) := Libgnat_A;
if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then
return Libgnat_A;
else
return Libgnat_Olb;
end if;
end Libgnat;
--------------------------------------
-- Library_Major_Minor_Id_Supported --
--------------------------------------
function Library_Major_Minor_Id_Supported return Boolean is
begin
return False;
end Library_Major_Minor_Id_Supported;
----------------
-- Object_Ext --
----------------
function Object_Ext return String is
begin
return "obj";
end Object_Ext;
----------------
-- PIC_Option --
----------------
function PIC_Option return String is
begin
return "";
end PIC_Option;
-- Package initialization
begin
Archive_Ext_Ptr := Archive_Ext'Access;
Default_Symbol_File_Name_Ptr := Default_Symbol_File_Name'Access;
DLL_Ext_Ptr := DLL_Ext'Access;
Is_Object_Ext_Ptr := Is_Object_Ext'Access;
Is_Archive_Ext_Ptr := Is_Archive_Ext'Access;
Libgnat_Ptr := Libgnat'Access;
Object_Ext_Ptr := Object_Ext'Access;
PIC_Option_Ptr := PIC_Option'Access;
Library_Major_Minor_Id_Supported_Ptr :=
Library_Major_Minor_Id_Supported'Access;
end MLib.Tgt.VMS_Common;

35
gcc/ada/mlib-tgt-vms_common.ads
View File

@ -1,35 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- M L I B . T G T . V M S _ C O M M O N --
-- --
-- S p e c --
-- --
-- Copyright (C) 2007-2011, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the part of MLib.Tgt.Specific common to both VMS versions
package MLib.Tgt.VMS_Common is
pragma Elaborate_Body;
function Init_Proc_Name (Library_Name : String) return String;
-- Returns, in upper case, Library_Name & "INIT", except when Library_Name
-- is "ada" (case insensitive), returns "ADA_INIT".
end MLib.Tgt.VMS_Common;

5
gcc/ada/namet.h
View File

@ -6,7 +6,7 @@
* *
* C Header File *
* *
* 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- *
@ -109,9 +109,6 @@ extern char *Spec_Context_List, *Body_Context_List;
#define Body_Filename exp_dbug__body_filename
extern char *Spec_Filename, *Body_Filename;
#define Is_Non_Ada_Error exp_ch11__is_non_ada_error
extern Boolean Is_Non_Ada_Error (Entity_Id);
/* Here are some functions in sinput.adb we call from trans.c. */
typedef Nat Source_File_Index;

603
gcc/ada/s-asthan-vms-alpha.adb
View File

@ -1,603 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . A S T _ H A N D L I N G --
-- --
-- B o d y --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the OpenVMS/Alpha version
with System; use System;
with System.IO;
with System.Machine_Code;
with System.Parameters;
with System.Storage_Elements;
with System.Tasking;
with System.Tasking.Rendezvous;
with System.Tasking.Initialization;
with System.Tasking.Utilities;
with System.Task_Primitives;
with System.Task_Primitives.Operations;
with System.Task_Primitives.Operations.DEC;
with Ada.Finalization;
with Ada.Task_Attributes;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
package body System.AST_Handling is
package ATID renames Ada.Task_Identification;
package SP renames System.Parameters;
package ST renames System.Tasking;
package STR renames System.Tasking.Rendezvous;
package STI renames System.Tasking.Initialization;
package STU renames System.Tasking.Utilities;
package SSE renames System.Storage_Elements;
package STPO renames System.Task_Primitives.Operations;
package STPOD renames System.Task_Primitives.Operations.DEC;
AST_Lock : aliased System.Task_Primitives.RTS_Lock;
-- This is a global lock; it is used to execute in mutual exclusion
-- from all other AST tasks. It is only used by Lock_AST and
-- Unlock_AST.
procedure Lock_AST (Self_ID : ST.Task_Id);
-- Locks out other AST tasks. Preceding a section of code by Lock_AST and
-- following it by Unlock_AST creates a critical region.
procedure Unlock_AST (Self_ID : ST.Task_Id);
-- Releases lock previously set by call to Lock_AST.
-- All nested locks must be released before other tasks competing for the
-- tasking lock are released.
--------------
-- Lock_AST --
--------------
procedure Lock_AST (Self_ID : ST.Task_Id) is
begin
STI.Defer_Abort_Nestable (Self_ID);
STPO.Write_Lock (AST_Lock'Access, Global_Lock => True);
end Lock_AST;
----------------
-- Unlock_AST --
----------------
procedure Unlock_AST (Self_ID : ST.Task_Id) is
begin
STPO.Unlock (AST_Lock'Access, Global_Lock => True);
STI.Undefer_Abort_Nestable (Self_ID);
end Unlock_AST;
---------------------------------
-- AST_Handler Data Structures --
---------------------------------
-- As noted in the private part of the spec of System.Aux_DEC, the
-- AST_Handler type is simply a pointer to a procedure that takes
-- a single 64bit parameter. The following is a local copy
-- of that definition.
-- We need our own copy because we need to get our hands on this
-- and we cannot see the private part of System.Aux_DEC. We don't
-- want to be a child of Aux_Dec because of complications resulting
-- from the use of pragma Extend_System. We will use unchecked
-- conversions between the two versions of the declarations.
type AST_Handler is access procedure (Param : Long_Integer);
-- However, this declaration is somewhat misleading, since the values
-- referenced by AST_Handler values (all produced in this package by
-- calls to Create_AST_Handler) are highly stylized.
-- The first point is that in VMS/Alpha, procedure pointers do not in
-- fact point to code, but rather to a 48-byte procedure descriptor.
-- So a value of type AST_Handler is in fact a pointer to one of these
-- 48-byte descriptors.
type Descriptor_Type is new SSE.Storage_Array (1 .. 48);
for Descriptor_Type'Alignment use Standard'Maximum_Alignment;
type Descriptor_Ref is access all Descriptor_Type;
-- Normally, there is only one such descriptor for a given procedure, but
-- it works fine to make a copy of the single allocated descriptor, and
-- use the copy itself, and we take advantage of this in the design here.
-- The idea is that AST_Handler values will all point to a record with the
-- following structure:
-- Note: When we say it works fine, there is one delicate point, which
-- is that the code for the AST procedure itself requires the original
-- descriptor address. We handle this by saving the original descriptor
-- address in this structure and restoring in Process_AST.
type AST_Handler_Data is record
Descriptor : Descriptor_Type;
Original_Descriptor_Ref : Descriptor_Ref;
Taskid : ATID.Task_Id;
Entryno : Natural;
end record;
type AST_Handler_Data_Ref is access all AST_Handler_Data;
function To_AST_Handler is new Ada.Unchecked_Conversion
(AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler);
-- Each time Create_AST_Handler is called, a new value of this record
-- type is created, containing a copy of the procedure descriptor for
-- the routine used to handle all AST's (Process_AST), and the Task_Id
-- and entry number parameters identifying the task entry involved.
-- The AST_Handler value returned is a pointer to this record. Since
-- the record starts with the procedure descriptor, it can be used
-- by the system in the normal way to call the procedure. But now
-- when the procedure gets control, it can determine the address of
-- the procedure descriptor used to call it (since the ABI specifies
-- that this is left sitting in register r27 on entry), and then use
-- that address to retrieve the Task_Id and entry number so that it
-- knows on which entry to queue the AST request.
-- The next issue is where are these records placed. Since we intend
-- to pass pointers to these records to asynchronous system service
-- routines, they have to be on the heap, which means we have to worry
-- about when to allocate them and deallocate them.
-- We solve this problem by introducing a task attribute that points to
-- a vector, indexed by the entry number, of AST_Handler_Data records
-- for a given task. The pointer itself is a controlled object allowing
-- us to write a finalization routine that frees the referenced vector.
-- An entry in this vector is either initialized (Entryno non-zero) and
-- can be used for any subsequent reference to the same entry, or it is
-- unused, marked by the Entryno value being zero.
type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data;
type AST_Handler_Vector_Ref is access all AST_Handler_Vector;
type AST_Vector_Ptr is new Ada.Finalization.Controlled with record
Vector : AST_Handler_Vector_Ref;
end record;
procedure Finalize (Obj : in out AST_Vector_Ptr);
-- Override Finalize so that the AST Vector gets freed.
procedure Finalize (Obj : in out AST_Vector_Ptr) is
procedure Free is new
Ada.Unchecked_Deallocation (AST_Handler_Vector, AST_Handler_Vector_Ref);
begin
if Obj.Vector /= null then
Free (Obj.Vector);
end if;
end Finalize;
AST_Vector_Init : AST_Vector_Ptr;
-- Initial value, treated as constant, Vector will be null
package AST_Attribute is new Ada.Task_Attributes
(Attribute => AST_Vector_Ptr,
Initial_Value => AST_Vector_Init);
use AST_Attribute;
-----------------------
-- AST Service Queue --
-----------------------
-- The following global data structures are used to queue pending
-- AST requests. When an AST is signalled, the AST service routine
-- Process_AST is called, and it makes an entry in this structure.
type AST_Instance is record
Taskid : ATID.Task_Id;
Entryno : Natural;
Param : Long_Integer;
end record;
-- The Taskid and Entryno indicate the entry on which this AST is to
-- be queued, and Param is the parameter provided from the AST itself.
AST_Service_Queue_Size : constant := 256;
AST_Service_Queue_Limit : constant := 250;
type AST_Service_Queue_Index is mod AST_Service_Queue_Size;
-- Index used to refer to entries in the circular buffer which holds
-- active AST_Instance values. The upper bound reflects the maximum
-- number of AST instances that can be stored in the buffer. Since
-- these entries are immediately serviced by the high priority server
-- task that does the actual entry queuing, it is very unusual to have
-- any significant number of entries simultaneously queued.
AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance;
pragma Volatile_Components (AST_Service_Queue);
-- The circular buffer used to store active AST requests
AST_Service_Queue_Put : AST_Service_Queue_Index := 0;
AST_Service_Queue_Get : AST_Service_Queue_Index := 0;
pragma Atomic (AST_Service_Queue_Put);
pragma Atomic (AST_Service_Queue_Get);
-- These two variables point to the next slots in the AST_Service_Queue
-- to be used for putting a new entry in and taking an entry out. This
-- is a circular buffer, so these pointers wrap around. If the two values
-- are equal the buffer is currently empty. The pointers are atomic to
-- ensure proper synchronization between the single producer (namely the
-- Process_AST procedure), and the single consumer (the AST_Service_Task).
--------------------------------
-- AST Server Task Structures --
--------------------------------
-- The basic approach is that when an AST comes in, a call is made to
-- the Process_AST procedure. It queues the request in the service queue
-- and then wakes up an AST server task to perform the actual call to the
-- required entry. We use this intermediate server task, since the AST
-- procedure itself cannot wait to return, and we need some caller for
-- the rendezvous so that we can use the normal rendezvous mechanism.
-- It would work to have only one AST server task, but then we would lose
-- all overlap in AST processing, and furthermore, we could get priority
-- inversion effects resulting in starvation of AST requests.
-- We therefore maintain a small pool of AST server tasks. We adjust
-- the size of the pool dynamically to reflect traffic, so that we have
-- a sufficient number of server tasks to avoid starvation.
Max_AST_Servers : constant Natural := 16;
-- Maximum number of AST server tasks that can be allocated
Num_AST_Servers : Natural := 0;
-- Number of AST server tasks currently active
Num_Waiting_AST_Servers : Natural := 0;
-- This is the number of AST server tasks that are either waiting for
-- work, or just about to go to sleep and wait for work.
Is_Waiting : array (1 .. Max_AST_Servers) of Boolean := (others => False);
-- An array of flags showing which AST server tasks are currently waiting
AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_Id;
-- Task Id's of allocated AST server tasks
task type AST_Server_Task (Num : Natural) is
pragma Priority (Priority'Last);
end AST_Server_Task;
-- Declaration for AST server task. This task has no entries, it is
-- controlled by sleep and wakeup calls at the task primitives level.
type AST_Server_Task_Ptr is access all AST_Server_Task;
-- Type used to allocate server tasks
-----------------------
-- Local Subprograms --
-----------------------
procedure Allocate_New_AST_Server;
-- Allocate an additional AST server task
procedure Process_AST (Param : Long_Integer);
-- This is the central routine for processing all AST's, it is referenced
-- as the code address of all created AST_Handler values. See detailed
-- description in body to understand how it works to have a single such
-- procedure for all AST's even though it does not get any indication of
-- the entry involved passed as an explicit parameter. The single explicit
-- parameter Param is the parameter passed by the system with the AST.
-----------------------------
-- Allocate_New_AST_Server --
-----------------------------
procedure Allocate_New_AST_Server is
Dummy : AST_Server_Task_Ptr;
begin
if Num_AST_Servers = Max_AST_Servers then
return;
else
-- Note: it is safe to increment Num_AST_Servers immediately, since
-- no one will try to activate this task until it indicates that it
-- is sleeping by setting its entry in Is_Waiting to True.
Num_AST_Servers := Num_AST_Servers + 1;
Dummy := new AST_Server_Task (Num_AST_Servers);
end if;
end Allocate_New_AST_Server;
---------------------
-- AST_Server_Task --
---------------------
task body AST_Server_Task is
Taskid : ATID.Task_Id;
Entryno : Natural;
Param : aliased Long_Integer;
Self_Id : constant ST.Task_Id := ST.Self;
pragma Volatile (Param);
-- By making this task independent of master, when the environment
-- task is finalizing, the AST_Server_Task will be notified that it
-- should terminate.
Ignore : constant Boolean := STU.Make_Independent;
pragma Unreferenced (Ignore);
begin
-- Record our task Id for access by Process_AST
AST_Task_Ids (Num) := Self_Id;
-- Note: this entire task operates with the main task lock set, except
-- when it is sleeping waiting for work, or busy doing a rendezvous
-- with an AST server. This lock protects the data structures that
-- are shared by multiple instances of the server task.
Lock_AST (Self_Id);
-- This is the main infinite loop of the task. We go to sleep and
-- wait to be woken up by Process_AST when there is some work to do.
loop
Num_Waiting_AST_Servers := Num_Waiting_AST_Servers + 1;
Unlock_AST (Self_Id);
STI.Defer_Abort (Self_Id);
if SP.Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Self_Id);
Is_Waiting (Num) := True;
Self_Id.Common.State := ST.AST_Server_Sleep;
STPO.Sleep (Self_Id, ST.AST_Server_Sleep);
Self_Id.Common.State := ST.Runnable;
STPO.Unlock (Self_Id);
if SP.Single_Lock then
STPO.Unlock_RTS;
end if;
-- If the process is finalizing, Undefer_Abort will simply end
-- this task.
STI.Undefer_Abort (Self_Id);
-- We are awake, there is something to do
Lock_AST (Self_Id);
Num_Waiting_AST_Servers := Num_Waiting_AST_Servers - 1;
-- Loop here to service outstanding requests. We are always
-- locked on entry to this loop.
while AST_Service_Queue_Get /= AST_Service_Queue_Put loop
Taskid := AST_Service_Queue (AST_Service_Queue_Get).Taskid;
Entryno := AST_Service_Queue (AST_Service_Queue_Get).Entryno;
Param := AST_Service_Queue (AST_Service_Queue_Get).Param;
AST_Service_Queue_Get := AST_Service_Queue_Get + 1;
-- This is a manual expansion of the normal call simple code
declare
type AA is access all Long_Integer;
P : AA := Param'Unrestricted_Access;
function To_ST_Task_Id is new Ada.Unchecked_Conversion
(ATID.Task_Id, ST.Task_Id);
begin
Unlock_AST (Self_Id);
STR.Call_Simple
(Acceptor => To_ST_Task_Id (Taskid),
E => ST.Task_Entry_Index (Entryno),
Uninterpreted_Data => P'Address);
exception
when E : others =>
System.IO.Put_Line ("%Debugging event");
System.IO.Put_Line (Exception_Name (E) &
" raised when trying to deliver an AST.");
if Exception_Message (E)'Length /= 0 then
System.IO.Put_Line (Exception_Message (E));
end if;
System.IO.Put_Line ("Task type is " & "Receiver_Type");
System.IO.Put_Line ("Task id is " & ATID.Image (Taskid));
end;
Lock_AST (Self_Id);
end loop;
end loop;
end AST_Server_Task;
------------------------
-- Create_AST_Handler --
------------------------
function Create_AST_Handler
(Taskid : ATID.Task_Id;
Entryno : Natural) return System.Aux_DEC.AST_Handler
is
Attr_Ref : Attribute_Handle;
Process_AST_Ptr : constant AST_Handler := Process_AST'Access;
-- Reference to standard procedure descriptor for Process_AST
pragma Warnings (Off, "*alignment*");
-- Suppress harmless warnings about alignment.
-- Should explain why this warning is harmless ???
function To_Descriptor_Ref is new Ada.Unchecked_Conversion
(AST_Handler, Descriptor_Ref);
Original_Descriptor_Ref : constant Descriptor_Ref :=
To_Descriptor_Ref (Process_AST_Ptr);
pragma Warnings (On, "*alignment*");
begin
if ATID.Is_Terminated (Taskid) then
raise Program_Error;
end if;
Attr_Ref := Reference (Taskid);
-- Allocate another server if supply is getting low
if Num_Waiting_AST_Servers < 2 then
Allocate_New_AST_Server;
end if;
-- No point in creating more if we have zillions waiting to
-- be serviced.
while AST_Service_Queue_Put - AST_Service_Queue_Get
> AST_Service_Queue_Limit
loop
delay 0.01;
end loop;
-- If no AST vector allocated, or the one we have is too short, then
-- allocate one of right size and initialize all entries except the
-- one we will use to unused. Note that the assignment automatically
-- frees the old allocated table if there is one.
if Attr_Ref.Vector = null
or else Attr_Ref.Vector'Length < Entryno
then
Attr_Ref.Vector := new AST_Handler_Vector (1 .. Entryno);
for E in 1 .. Entryno loop
Attr_Ref.Vector (E).Descriptor :=
Original_Descriptor_Ref.all;
Attr_Ref.Vector (E).Original_Descriptor_Ref :=
Original_Descriptor_Ref;
Attr_Ref.Vector (E).Taskid := Taskid;
Attr_Ref.Vector (E).Entryno := E;
end loop;
end if;
return To_AST_Handler (Attr_Ref.Vector (Entryno)'Unrestricted_Access);
end Create_AST_Handler;
----------------------------
-- Expand_AST_Packet_Pool --
----------------------------
procedure Expand_AST_Packet_Pool
(Requested_Packets : Natural;
Actual_Number : out Natural;
Total_Number : out Natural)
is
pragma Unreferenced (Requested_Packets);
begin
-- The AST implementation of GNAT does not permit dynamic expansion
-- of the pool, so we simply add no entries and return the total. If
-- it is necessary to expand the allocation, then this package body
-- must be recompiled with a larger value for AST_Service_Queue_Size.
Actual_Number := 0;
Total_Number := AST_Service_Queue_Size;
end Expand_AST_Packet_Pool;
-----------------
-- Process_AST --
-----------------
procedure Process_AST (Param : Long_Integer) is
Handler_Data_Ptr : AST_Handler_Data_Ref;
-- This variable is set to the address of the descriptor through
-- which Process_AST is called. Since the descriptor is part of
-- an AST_Handler value, this is also the address of this value,
-- from which we can obtain the task and entry number information.
function To_Address is new Ada.Unchecked_Conversion
(ST.Task_Id, System.Task_Primitives.Task_Address);
begin
System.Machine_Code.Asm
(Template => "addq $27,0,%0",
Outputs => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr),
Volatile => True);
System.Machine_Code.Asm
(Template => "ldq $27,%0",
Inputs => Descriptor_Ref'Asm_Input
("m", Handler_Data_Ptr.Original_Descriptor_Ref),
Volatile => True);
AST_Service_Queue (AST_Service_Queue_Put) := AST_Instance'
(Taskid => Handler_Data_Ptr.Taskid,
Entryno => Handler_Data_Ptr.Entryno,
Param => Param);
-- OpenVMS Programming Concepts manual, chapter 8.2.3:
-- "Implicit synchronization can be achieved for data that is shared
-- for write by using only AST routines to write the data, since only
-- one AST can be running at any one time."
-- This subprogram runs at AST level so is guaranteed to be
-- called sequentially at a given access level.
AST_Service_Queue_Put := AST_Service_Queue_Put + 1;
-- Need to wake up processing task. If there is no waiting server
-- then we have temporarily run out, but things should still be
-- OK, since one of the active ones will eventually pick up the
-- service request queued in the AST_Service_Queue.
for J in 1 .. Num_AST_Servers loop
if Is_Waiting (J) then
Is_Waiting (J) := False;
-- Sleeps are handled by ASTs on VMS, so don't call Wakeup
STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J)));
exit;
end if;
end loop;
end Process_AST;
begin
STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level);
end System.AST_Handling;

608
gcc/ada/s-asthan-vms-ia64.adb
View File

@ -1,608 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . A S T _ H A N D L I N G --
-- --
-- B o d y --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the OpenVMS/IA64 version
with System; use System;
with System.IO;
with System.Machine_Code;
with System.Parameters;
with System.Tasking;
with System.Tasking.Rendezvous;
with System.Tasking.Initialization;
with System.Tasking.Utilities;
with System.Task_Primitives;
with System.Task_Primitives.Operations;
with System.Task_Primitives.Operations.DEC;
with Ada.Finalization;
with Ada.Task_Attributes;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
package body System.AST_Handling is
package ATID renames Ada.Task_Identification;
package SP renames System.Parameters;
package ST renames System.Tasking;
package STR renames System.Tasking.Rendezvous;
package STI renames System.Tasking.Initialization;
package STU renames System.Tasking.Utilities;
package STPO renames System.Task_Primitives.Operations;
package STPOD renames System.Task_Primitives.Operations.DEC;
AST_Lock : aliased System.Task_Primitives.RTS_Lock;
-- This is a global lock; it is used to execute in mutual exclusion
-- from all other AST tasks. It is only used by Lock_AST and
-- Unlock_AST.
procedure Lock_AST (Self_ID : ST.Task_Id);
-- Locks out other AST tasks. Preceding a section of code by Lock_AST and
-- following it by Unlock_AST creates a critical region.
procedure Unlock_AST (Self_ID : ST.Task_Id);
-- Releases lock previously set by call to Lock_AST.
-- All nested locks must be released before other tasks competing for the
-- tasking lock are released.
--------------
-- Lock_AST --
--------------
procedure Lock_AST (Self_ID : ST.Task_Id) is
begin
STI.Defer_Abort_Nestable (Self_ID);
STPO.Write_Lock (AST_Lock'Access, Global_Lock => True);
end Lock_AST;
----------------
-- Unlock_AST --
----------------
procedure Unlock_AST (Self_ID : ST.Task_Id) is
begin
STPO.Unlock (AST_Lock'Access, Global_Lock => True);
STI.Undefer_Abort_Nestable (Self_ID);
end Unlock_AST;
---------------------------------
-- AST_Handler Data Structures --
---------------------------------
-- As noted in the private part of the spec of System.Aux_DEC, the
-- AST_Handler type is simply a pointer to a procedure that takes
-- a single 64bit parameter. The following is a local copy
-- of that definition.
-- We need our own copy because we need to get our hands on this
-- and we cannot see the private part of System.Aux_DEC. We don't
-- want to be a child of Aux_Dec because of complications resulting
-- from the use of pragma Extend_System. We will use unchecked
-- conversions between the two versions of the declarations.
type AST_Handler is access procedure (Param : Long_Integer);
-- However, this declaration is somewhat misleading, since the values
-- referenced by AST_Handler values (all produced in this package by
-- calls to Create_AST_Handler) are highly stylized.
-- The first point is that in VMS/I64, procedure pointers do not in
-- fact point to code, but rather to a procedure descriptor.
-- So a value of type AST_Handler is in fact a pointer to one of
-- descriptors.
type Descriptor_Type is
record
Entry_Point : System.Address;
GP_Value : System.Address;
end record;
for Descriptor_Type'Alignment use Standard'Maximum_Alignment;
-- pragma Warnings (Off, Descriptor_Type);
-- Suppress harmless warnings about alignment.
-- Should explain why this warning is harmless ???
type Descriptor_Ref is access all Descriptor_Type;
-- Normally, there is only one such descriptor for a given procedure, but
-- it works fine to make a copy of the single allocated descriptor, and
-- use the copy itself, and we take advantage of this in the design here.
-- The idea is that AST_Handler values will all point to a record with the
-- following structure:
-- Note: When we say it works fine, there is one delicate point, which
-- is that the code for the AST procedure itself requires the original
-- descriptor address. We handle this by saving the orignal descriptor
-- address in this structure and restoring in Process_AST.
type AST_Handler_Data is record
Descriptor : Descriptor_Type;
Original_Descriptor_Ref : Descriptor_Ref;
Taskid : ATID.Task_Id;
Entryno : Natural;
end record;
type AST_Handler_Data_Ref is access all AST_Handler_Data;
function To_AST_Handler is new Ada.Unchecked_Conversion
(AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler);
-- Each time Create_AST_Handler is called, a new value of this record
-- type is created, containing a copy of the procedure descriptor for
-- the routine used to handle all AST's (Process_AST), and the Task_Id
-- and entry number parameters identifying the task entry involved.
-- The AST_Handler value returned is a pointer to this record. Since
-- the record starts with the procedure descriptor, it can be used
-- by the system in the normal way to call the procedure. But now
-- when the procedure gets control, it can determine the address of
-- the procedure descriptor used to call it (since the ABI specifies
-- that this is left sitting in register r27 on entry), and then use
-- that address to retrieve the Task_Id and entry number so that it
-- knows on which entry to queue the AST request.
-- The next issue is where are these records placed. Since we intend
-- to pass pointers to these records to asynchronous system service
-- routines, they have to be on the heap, which means we have to worry
-- about when to allocate them and deallocate them.
-- We solve this problem by introducing a task attribute that points to
-- a vector, indexed by the entry number, of AST_Handler_Data records
-- for a given task. The pointer itself is a controlled object allowing
-- us to write a finalization routine that frees the referenced vector.
-- An entry in this vector is either initialized (Entryno non-zero) and
-- can be used for any subsequent reference to the same entry, or it is
-- unused, marked by the Entryno value being zero.
type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data;
type AST_Handler_Vector_Ref is access all AST_Handler_Vector;
type AST_Vector_Ptr is new Ada.Finalization.Controlled with record
Vector : AST_Handler_Vector_Ref;
end record;
procedure Finalize (Obj : in out AST_Vector_Ptr);
-- Override Finalize so that the AST Vector gets freed.
procedure Finalize (Obj : in out AST_Vector_Ptr) is
procedure Free is new
Ada.Unchecked_Deallocation (AST_Handler_Vector, AST_Handler_Vector_Ref);
begin
if Obj.Vector /= null then
Free (Obj.Vector);
end if;
end Finalize;
AST_Vector_Init : AST_Vector_Ptr;
-- Initial value, treated as constant, Vector will be null
package AST_Attribute is new Ada.Task_Attributes
(Attribute => AST_Vector_Ptr,
Initial_Value => AST_Vector_Init);
use AST_Attribute;
-----------------------
-- AST Service Queue --
-----------------------
-- The following global data structures are used to queue pending
-- AST requests. When an AST is signalled, the AST service routine
-- Process_AST is called, and it makes an entry in this structure.
type AST_Instance is record
Taskid : ATID.Task_Id;
Entryno : Natural;
Param : Long_Integer;
end record;
-- The Taskid and Entryno indicate the entry on which this AST is to
-- be queued, and Param is the parameter provided from the AST itself.
AST_Service_Queue_Size : constant := 256;
AST_Service_Queue_Limit : constant := 250;
type AST_Service_Queue_Index is mod AST_Service_Queue_Size;
-- Index used to refer to entries in the circular buffer which holds
-- active AST_Instance values. The upper bound reflects the maximum
-- number of AST instances that can be stored in the buffer. Since
-- these entries are immediately serviced by the high priority server
-- task that does the actual entry queuing, it is very unusual to have
-- any significant number of entries simulaneously queued.
AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance;
pragma Volatile_Components (AST_Service_Queue);
-- The circular buffer used to store active AST requests
AST_Service_Queue_Put : AST_Service_Queue_Index := 0;
AST_Service_Queue_Get : AST_Service_Queue_Index := 0;
pragma Atomic (AST_Service_Queue_Put);
pragma Atomic (AST_Service_Queue_Get);
-- These two variables point to the next slots in the AST_Service_Queue
-- to be used for putting a new entry in and taking an entry out. This
-- is a circular buffer, so these pointers wrap around. If the two values
-- are equal the buffer is currently empty. The pointers are atomic to
-- ensure proper synchronization between the single producer (namely the
-- Process_AST procedure), and the single consumer (the AST_Service_Task).
--------------------------------
-- AST Server Task Structures --
--------------------------------
-- The basic approach is that when an AST comes in, a call is made to
-- the Process_AST procedure. It queues the request in the service queue
-- and then wakes up an AST server task to perform the actual call to the
-- required entry. We use this intermediate server task, since the AST
-- procedure itself cannot wait to return, and we need some caller for
-- the rendezvous so that we can use the normal rendezvous mechanism.
-- It would work to have only one AST server task, but then we would lose
-- all overlap in AST processing, and furthermore, we could get priority
-- inversion effects resulting in starvation of AST requests.
-- We therefore maintain a small pool of AST server tasks. We adjust
-- the size of the pool dynamically to reflect traffic, so that we have
-- a sufficient number of server tasks to avoid starvation.
Max_AST_Servers : constant Natural := 16;
-- Maximum number of AST server tasks that can be allocated
Num_AST_Servers : Natural := 0;
-- Number of AST server tasks currently active
Num_Waiting_AST_Servers : Natural := 0;
-- This is the number of AST server tasks that are either waiting for
-- work, or just about to go to sleep and wait for work.
Is_Waiting : array (1 .. Max_AST_Servers) of Boolean := (others => False);
-- An array of flags showing which AST server tasks are currently waiting
AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_Id;
-- Task Id's of allocated AST server tasks
task type AST_Server_Task (Num : Natural) is
pragma Priority (Priority'Last);
end AST_Server_Task;
-- Declaration for AST server task. This task has no entries, it is
-- controlled by sleep and wakeup calls at the task primitives level.
type AST_Server_Task_Ptr is access all AST_Server_Task;
-- Type used to allocate server tasks
-----------------------
-- Local Subprograms --
-----------------------
procedure Allocate_New_AST_Server;
-- Allocate an additional AST server task
procedure Process_AST (Param : Long_Integer);
-- This is the central routine for processing all AST's, it is referenced
-- as the code address of all created AST_Handler values. See detailed
-- description in body to understand how it works to have a single such
-- procedure for all AST's even though it does not get any indication of
-- the entry involved passed as an explicit parameter. The single explicit
-- parameter Param is the parameter passed by the system with the AST.
-----------------------------
-- Allocate_New_AST_Server --
-----------------------------
procedure Allocate_New_AST_Server is
Dummy : AST_Server_Task_Ptr;
begin
if Num_AST_Servers = Max_AST_Servers then
return;
else
-- Note: it is safe to increment Num_AST_Servers immediately, since
-- no one will try to activate this task until it indicates that it
-- is sleeping by setting its entry in Is_Waiting to True.
Num_AST_Servers := Num_AST_Servers + 1;
Dummy := new AST_Server_Task (Num_AST_Servers);
end if;
end Allocate_New_AST_Server;
---------------------
-- AST_Server_Task --
---------------------
task body AST_Server_Task is
Taskid : ATID.Task_Id;
Entryno : Natural;
Param : aliased Long_Integer;
Self_Id : constant ST.Task_Id := ST.Self;
pragma Volatile (Param);
-- By making this task independent of master, when the environment
-- task is finalizing, the AST_Server_Task will be notified that it
-- should terminate.
Ignore : constant Boolean := STU.Make_Independent;
pragma Unreferenced (Ignore);
begin
-- Record our task Id for access by Process_AST
AST_Task_Ids (Num) := Self_Id;
-- Note: this entire task operates with the main task lock set, except
-- when it is sleeping waiting for work, or busy doing a rendezvous
-- with an AST server. This lock protects the data structures that
-- are shared by multiple instances of the server task.
Lock_AST (Self_Id);
-- This is the main infinite loop of the task. We go to sleep and
-- wait to be woken up by Process_AST when there is some work to do.
loop
Num_Waiting_AST_Servers := Num_Waiting_AST_Servers + 1;
Unlock_AST (Self_Id);
STI.Defer_Abort (Self_Id);
if SP.Single_Lock then
STPO.Lock_RTS;
end if;
STPO.Write_Lock (Self_Id);
Is_Waiting (Num) := True;
Self_Id.Common.State := ST.AST_Server_Sleep;
STPO.Sleep (Self_Id, ST.AST_Server_Sleep);
Self_Id.Common.State := ST.Runnable;
STPO.Unlock (Self_Id);
if SP.Single_Lock then
STPO.Unlock_RTS;
end if;
-- If the process is finalizing, Undefer_Abort will simply end
-- this task.
STI.Undefer_Abort (Self_Id);
-- We are awake, there is something to do
Lock_AST (Self_Id);
Num_Waiting_AST_Servers := Num_Waiting_AST_Servers - 1;
-- Loop here to service outstanding requests. We are always
-- locked on entry to this loop.
while AST_Service_Queue_Get /= AST_Service_Queue_Put loop
Taskid := AST_Service_Queue (AST_Service_Queue_Get).Taskid;
Entryno := AST_Service_Queue (AST_Service_Queue_Get).Entryno;
Param := AST_Service_Queue (AST_Service_Queue_Get).Param;
AST_Service_Queue_Get := AST_Service_Queue_Get + 1;
-- This is a manual expansion of the normal call simple code
declare
type AA is access all Long_Integer;
P : AA := Param'Unrestricted_Access;
function To_ST_Task_Id is new Ada.Unchecked_Conversion
(ATID.Task_Id, ST.Task_Id);
begin
Unlock_AST (Self_Id);
STR.Call_Simple
(Acceptor => To_ST_Task_Id (Taskid),
E => ST.Task_Entry_Index (Entryno),
Uninterpreted_Data => P'Address);
exception
when E : others =>
System.IO.Put_Line ("%Debugging event");
System.IO.Put_Line (Exception_Name (E) &
" raised when trying to deliver an AST.");
if Exception_Message (E)'Length /= 0 then
System.IO.Put_Line (Exception_Message (E));
end if;
System.IO.Put_Line ("Task type is " & "Receiver_Type");
System.IO.Put_Line ("Task id is " & ATID.Image (Taskid));
end;
Lock_AST (Self_Id);
end loop;
end loop;
end AST_Server_Task;
------------------------
-- Create_AST_Handler --
------------------------
function Create_AST_Handler
(Taskid : ATID.Task_Id;
Entryno : Natural) return System.Aux_DEC.AST_Handler
is
Attr_Ref : Attribute_Handle;
Process_AST_Ptr : constant AST_Handler := Process_AST'Access;
-- Reference to standard procedure descriptor for Process_AST
function To_Descriptor_Ref is new Ada.Unchecked_Conversion
(AST_Handler, Descriptor_Ref);
Original_Descriptor_Ref : constant Descriptor_Ref :=
To_Descriptor_Ref (Process_AST_Ptr);
begin
if ATID.Is_Terminated (Taskid) then
raise Program_Error;
end if;
Attr_Ref := Reference (Taskid);
-- Allocate another server if supply is getting low
if Num_Waiting_AST_Servers < 2 then
Allocate_New_AST_Server;
end if;
-- No point in creating more if we have zillions waiting to
-- be serviced.
while AST_Service_Queue_Put - AST_Service_Queue_Get
> AST_Service_Queue_Limit
loop
delay 0.01;
end loop;
-- If no AST vector allocated, or the one we have is too short, then
-- allocate one of right size and initialize all entries except the
-- one we will use to unused. Note that the assignment automatically
-- frees the old allocated table if there is one.
if Attr_Ref.Vector = null
or else Attr_Ref.Vector'Length < Entryno
then
Attr_Ref.Vector := new AST_Handler_Vector (1 .. Entryno);
for E in 1 .. Entryno loop
Attr_Ref.Vector (E).Descriptor.Entry_Point :=
Original_Descriptor_Ref.Entry_Point;
Attr_Ref.Vector (E).Descriptor.GP_Value :=
Attr_Ref.Vector (E)'Address;
Attr_Ref.Vector (E).Original_Descriptor_Ref :=
Original_Descriptor_Ref;
Attr_Ref.Vector (E).Taskid := Taskid;
Attr_Ref.Vector (E).Entryno := E;
end loop;
end if;
return To_AST_Handler (Attr_Ref.Vector (Entryno)'Unrestricted_Access);
end Create_AST_Handler;
----------------------------
-- Expand_AST_Packet_Pool --
----------------------------
procedure Expand_AST_Packet_Pool
(Requested_Packets : Natural;
Actual_Number : out Natural;
Total_Number : out Natural)
is
pragma Unreferenced (Requested_Packets);
begin
-- The AST implementation of GNAT does not permit dynamic expansion
-- of the pool, so we simply add no entries and return the total. If
-- it is necessary to expand the allocation, then this package body
-- must be recompiled with a larger value for AST_Service_Queue_Size.
Actual_Number := 0;
Total_Number := AST_Service_Queue_Size;
end Expand_AST_Packet_Pool;
-----------------
-- Process_AST --
-----------------
procedure Process_AST (Param : Long_Integer) is
Handler_Data_Ptr : AST_Handler_Data_Ref;
-- This variable is set to the address of the descriptor through
-- which Process_AST is called. Since the descriptor is part of
-- an AST_Handler value, this is also the address of this value,
-- from which we can obtain the task and entry number information.
function To_Address is new Ada.Unchecked_Conversion
(ST.Task_Id, System.Task_Primitives.Task_Address);
begin
-- Move the contrived GP into place so Taskid and Entryno
-- become available, then restore the true GP.
System.Machine_Code.Asm
(Template => "mov %0 = r1",
Outputs => AST_Handler_Data_Ref'Asm_Output
("=r", Handler_Data_Ptr),
Volatile => True);
System.Machine_Code.Asm
(Template => "ld8 r1 = %0;;",
Inputs => System.Address'Asm_Input
("m", Handler_Data_Ptr.Original_Descriptor_Ref.GP_Value),
Volatile => True);
AST_Service_Queue (AST_Service_Queue_Put) := AST_Instance'
(Taskid => Handler_Data_Ptr.Taskid,
Entryno => Handler_Data_Ptr.Entryno,
Param => Param);
-- OpenVMS Programming Concepts manual, chapter 8.2.3:
-- "Implicit synchronization can be achieved for data that is shared
-- for write by using only AST routines to write the data, since only
-- one AST can be running at any one time."
-- This subprogram runs at AST level so is guaranteed to be
-- called sequentially at a given access level.
AST_Service_Queue_Put := AST_Service_Queue_Put + 1;
-- Need to wake up processing task. If there is no waiting server
-- then we have temporarily run out, but things should still be
-- OK, since one of the active ones will eventually pick up the
-- service request queued in the AST_Service_Queue.
for J in 1 .. Num_AST_Servers loop
if Is_Waiting (J) then
Is_Waiting (J) := False;
-- Sleeps are handled by ASTs on VMS, so don't call Wakeup
STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J)));
exit;
end if;
end loop;
end Process_AST;
begin
STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level);
end System.AST_Handling;

809
gcc/ada/s-auxdec-vms-alpha.adb
View File

@ -1,809 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . A U X _ D E C --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the Alpha/VMS version.
pragma Style_Checks (All_Checks);
-- Turn off alpha ordering check on subprograms, this unit is laid
-- out to correspond to the declarations in the DEC 83 System unit.
with System.Machine_Code; use System.Machine_Code;
package body System.Aux_DEC is
------------------------
-- Fetch_From_Address --
------------------------
function Fetch_From_Address (A : Address) return Target is
type T_Ptr is access all Target;
function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
Ptr : constant T_Ptr := To_T_Ptr (A);
begin
return Ptr.all;
end Fetch_From_Address;
-----------------------
-- Assign_To_Address --
-----------------------
procedure Assign_To_Address (A : Address; T : Target) is
type T_Ptr is access all Target;
function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
Ptr : constant T_Ptr := To_T_Ptr (A);
begin
Ptr.all := T;
end Assign_To_Address;
-----------------------
-- Clear_Interlocked --
-----------------------
procedure Clear_Interlocked
(Bit : in out Boolean;
Old_Value : out Boolean)
is
use ASCII;
Clr_Bit : Boolean := Bit;
Old_Bit : Boolean;
begin
-- All these ASM sequences should be commented. I suggest defining
-- a constant called E which is LF & HT and then you have more space
-- for line by line comments ???
System.Machine_Code.Asm
(
"lda $16, %2" & LF & HT &
"mb" & LF & HT &
"sll $16, 3, $17 " & LF & HT &
"bis $31, 1, $1" & LF & HT &
"and $17, 63, $18" & LF & HT &
"bic $17, 63, $17" & LF & HT &
"sra $17, 3, $17" & LF & HT &
"bis $31, 1, %1" & LF & HT &
"sll %1, $18, $18" & LF & HT &
"1:" & LF & HT &
"ldq_l $1, 0($17)" & LF & HT &
"and $1, $18, %1" & LF & HT &
"bic $1, $18, $1" & LF & HT &
"stq_c $1, 0($17)" & LF & HT &
"cmpeq %1, 0, %1" & LF & HT &
"beq $1, 1b" & LF & HT &
"mb" & LF & HT &
"xor %1, 1, %1" & LF & HT &
"trapb",
Outputs => (Boolean'Asm_Output ("=m", Clr_Bit),
Boolean'Asm_Output ("=r", Old_Bit)),
Inputs => Boolean'Asm_Input ("m", Clr_Bit),
Clobber => "$1, $16, $17, $18",
Volatile => True);
Bit := Clr_Bit;
Old_Value := Old_Bit;
end Clear_Interlocked;
procedure Clear_Interlocked
(Bit : in out Boolean;
Old_Value : out Boolean;
Retry_Count : Natural;
Success_Flag : out Boolean)
is
use ASCII;
Clr_Bit : Boolean := Bit;
Succ, Old_Bit : Boolean;
begin
System.Machine_Code.Asm
(
"lda $16, %3" & LF & HT &
"mb" & LF & HT &
"sll $16, 3, $18 " & LF & HT &
"bis $31, 1, %1" & LF & HT &
"and $18, 63, $19" & LF & HT &
"bic $18, 63, $18" & LF & HT &
"sra $18, 3, $18" & LF & HT &
"bis $31, %4, $17" & LF & HT &
"sll %1, $19, $19" & LF & HT &
"1:" & LF & HT &
"ldq_l %2, 0($18)" & LF & HT &
"and %2, $19, %1" & LF & HT &
"bic %2, $19, %2" & LF & HT &
"stq_c %2, 0($18)" & LF & HT &
"beq %2, 2f" & LF & HT &
"cmpeq %1, 0, %1" & LF & HT &
"br 3f" & LF & HT &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
"3:" & LF & HT &
"mb" & LF & HT &
"xor %1, 1, %1" & LF & HT &
"trapb",
Outputs => (Boolean'Asm_Output ("=m", Clr_Bit),
Boolean'Asm_Output ("=r", Old_Bit),
Boolean'Asm_Output ("=r", Succ)),
Inputs => (Boolean'Asm_Input ("m", Clr_Bit),
Natural'Asm_Input ("rJ", Retry_Count)),
Clobber => "$16, $17, $18, $19",
Volatile => True);
Bit := Clr_Bit;
Old_Value := Old_Bit;
Success_Flag := Succ;
end Clear_Interlocked;
---------------------
-- Set_Interlocked --
---------------------
procedure Set_Interlocked
(Bit : in out Boolean;
Old_Value : out Boolean)
is
use ASCII;
Set_Bit : Boolean := Bit;
Old_Bit : Boolean;
begin
-- Don't we need comments on these long asm sequences???
System.Machine_Code.Asm
(
"lda $16, %2" & LF & HT &
"sll $16, 3, $17 " & LF & HT &
"bis $31, 1, $1" & LF & HT &
"and $17, 63, $18" & LF & HT &
"mb" & LF & HT &
"bic $17, 63, $17" & LF & HT &
"sra $17, 3, $17" & LF & HT &
"bis $31, 1, %1" & LF & HT &
"sll %1, $18, $18" & LF & HT &
"1:" & LF & HT &
"ldq_l $1, 0($17)" & LF & HT &
"and $1, $18, %1" & LF & HT &
"bis $1, $18, $1" & LF & HT &
"stq_c $1, 0($17)" & LF & HT &
"cmovne %1, 1, %1" & LF & HT &
"beq $1, 1b" & LF & HT &
"mb" & LF & HT &
"trapb",
Outputs => (Boolean'Asm_Output ("=m", Set_Bit),
Boolean'Asm_Output ("=r", Old_Bit)),
Inputs => Boolean'Asm_Input ("m", Set_Bit),
Clobber => "$1, $16, $17, $18",
Volatile => True);
Bit := Set_Bit;
Old_Value := Old_Bit;
end Set_Interlocked;
procedure Set_Interlocked
(Bit : in out Boolean;
Old_Value : out Boolean;
Retry_Count : Natural;
Success_Flag : out Boolean)
is
use ASCII;
Set_Bit : Boolean := Bit;
Succ, Old_Bit : Boolean;
begin
System.Machine_Code.Asm
(
"lda $16, %3" & LF & HT & -- Address of Bit
"mb" & LF & HT &
"sll $16, 3, $18 " & LF & HT & -- Byte address to bit address
"bis $31, 1, %1" & LF & HT & -- Set temp to 1 for the sll
"and $18, 63, $19" & LF & HT & -- Quadword bit offset
"bic $18, 63, $18" & LF & HT & -- Quadword bit address
"sra $18, 3, $18" & LF & HT & -- Quadword address
"bis $31, %4, $17" & LF & HT & -- Retry_Count -> $17
"sll %1, $19, $19" & LF & -- $19 = 1 << bit_offset
"1:" & LF & HT &
"ldq_l %2, 0($18)" & LF & HT & -- Load & lock
"and %2, $19, %1" & LF & HT & -- Previous value -> %1
"bis %2, $19, %2" & LF & HT & -- Set Bit
"stq_c %2, 0($18)" & LF & HT & -- Store conditional
"beq %2, 2f" & LF & HT & -- Goto 2: if failed
"cmovne %1, 1, %1" & LF & HT & -- Set Old_Bit
"br 3f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT & -- Retry_Count - 1
"bgt $17, 1b" & LF & -- Retry ?
"3:" & LF & HT &
"mb" & LF & HT &
"trapb",
Outputs => (Boolean'Asm_Output ("=m", Set_Bit),
Boolean'Asm_Output ("=r", Old_Bit),
Boolean'Asm_Output ("=r", Succ)),
Inputs => (Boolean'Asm_Input ("m", Set_Bit),
Natural'Asm_Input ("rJ", Retry_Count)),
Clobber => "$16, $17, $18, $19",
Volatile => True);
Bit := Set_Bit;
Old_Value := Old_Bit;
Success_Flag := Succ;
end Set_Interlocked;
---------------------
-- Add_Interlocked --
---------------------
procedure Add_Interlocked
(Addend : Short_Integer;
Augend : in out Aligned_Word;
Sign : out Integer)
is
use ASCII;
Overflowed : Boolean := False;
begin
System.Machine_Code.Asm
(
"lda $18, %0" & LF & HT &
"bic $18, 6, $21" & LF & HT &
"mb" & LF & HT &
"1:" & LF & HT &
"ldq_l $0, 0($21)" & LF & HT &
"extwl $0, $18, $19" & LF & HT &
"mskwl $0, $18, $0" & LF & HT &
"addq $19, %3, $20" & LF & HT &
"inswl $20, $18, $17" & LF & HT &
"xor $19, %3, $19" & LF & HT &
"bis $17, $0, $0" & LF & HT &
"stq_c $0, 0($21)" & LF & HT &
"beq $0, 1b" & LF & HT &
"srl $20, 16, $0" & LF & HT &
"mb" & LF & HT &
"srl $20, 12, $21" & LF & HT &
"zapnot $20, 3, $20" & LF & HT &
"and $0, 1, $0" & LF & HT &
"and $21, 8, $21" & LF & HT &
"bis $21, $0, $0" & LF & HT &
"cmpeq $20, 0, $21" & LF & HT &
"xor $20, 2, $20" & LF & HT &
"sll $21, 2, $21" & LF & HT &
"bis $21, $0, $0" & LF & HT &
"bic $20, $19, $21" & LF & HT &
"srl $21, 14, $21" & LF & HT &
"and $21, 2, $21" & LF & HT &
"bis $21, $0, $0" & LF & HT &
"and $0, 2, %2" & LF & HT &
"bne %2, 2f" & LF & HT &
"and $0, 4, %1" & LF & HT &
"cmpeq %1, 0, %1" & LF & HT &
"and $0, 8, $0" & LF & HT &
"lda $16, -1" & LF & HT &
"cmovne $0, $16, %1" & LF & HT &
"2:",
Outputs => (Aligned_Word'Asm_Output ("=m", Augend),
Integer'Asm_Output ("=r", Sign),
Boolean'Asm_Output ("=r", Overflowed)),
Inputs => (Short_Integer'Asm_Input ("r", Addend),
Aligned_Word'Asm_Input ("m", Augend)),
Clobber => "$0, $1, $16, $17, $18, $19, $20, $21",
Volatile => True);
if Overflowed then
raise Constraint_Error;
end if;
end Add_Interlocked;
----------------
-- Add_Atomic --
----------------
procedure Add_Atomic
(To : in out Aligned_Integer;
Amount : Integer)
is
use ASCII;
begin
System.Machine_Code.Asm
(
"mb" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"addl $1, %2, $0" & LF & HT &
"stl_c $0, %1" & LF & HT &
"beq $0, 1b" & LF & HT &
"mb",
Outputs => Aligned_Integer'Asm_Output ("=m", To),
Inputs => (Aligned_Integer'Asm_Input ("m", To),
Integer'Asm_Input ("rJ", Amount)),
Clobber => "$0, $1",
Volatile => True);
end Add_Atomic;
procedure Add_Atomic
(To : in out Aligned_Integer;
Amount : Integer;
Retry_Count : Natural;
Old_Value : out Integer;
Success_Flag : out Boolean)
is
use ASCII;
begin
System.Machine_Code.Asm
(
"mb" & LF & HT &
"bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"addl $1, %4, $0" & LF & HT &
"stl_c $0, %3" & LF & HT &
"beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stl $1, %1" & LF & HT &
"br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
"br 3b" & LF &
"4:",
Outputs => (Aligned_Integer'Asm_Output ("=m", To),
Integer'Asm_Output ("=m", Old_Value),
Boolean'Asm_Output ("=m", Success_Flag)),
Inputs => (Aligned_Integer'Asm_Input ("m", To),
Integer'Asm_Input ("rJ", Amount),
Natural'Asm_Input ("rJ", Retry_Count)),
Clobber => "$0, $1, $17",
Volatile => True);
end Add_Atomic;
procedure Add_Atomic
(To : in out Aligned_Long_Integer;
Amount : Long_Integer)
is
use ASCII;
begin
System.Machine_Code.Asm
(
"mb" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"addq $1, %2, $0" & LF & HT &
"stq_c $0, %1" & LF & HT &
"beq $0, 1b" & LF & HT &
"mb",
Outputs => Aligned_Long_Integer'Asm_Output ("=m", To),
Inputs => (Aligned_Long_Integer'Asm_Input ("m", To),
Long_Integer'Asm_Input ("rJ", Amount)),
Clobber => "$0, $1",
Volatile => True);
end Add_Atomic;
procedure Add_Atomic
(To : in out Aligned_Long_Integer;
Amount : Long_Integer;
Retry_Count : Natural;
Old_Value : out Long_Integer;
Success_Flag : out Boolean)
is
use ASCII;
begin
System.Machine_Code.Asm
(
"mb" & LF & HT &
"bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"addq $1, %4, $0" & LF & HT &
"stq_c $0, %3" & LF & HT &
"beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stq $1, %1" & LF & HT &
"br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
"br 3b" & LF &
"4:",
Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To),
Long_Integer'Asm_Output ("=m", Old_Value),
Boolean'Asm_Output ("=m", Success_Flag)),
Inputs => (Aligned_Long_Integer'Asm_Input ("m", To),
Long_Integer'Asm_Input ("rJ", Amount),
Natural'Asm_Input ("rJ", Retry_Count)),
Clobber => "$0, $1, $17",
Volatile => True);
end Add_Atomic;
----------------
-- And_Atomic --
----------------
procedure And_Atomic
(To : in out Aligned_Integer;
From : Integer)
is
use ASCII;
begin
System.Machine_Code.Asm
(
"mb" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"and $1, %2, $0" & LF & HT &
"stl_c $0, %1" & LF & HT &
"beq $0, 1b" & LF & HT &
"mb",
Outputs => Aligned_Integer'Asm_Output ("=m", To),
Inputs => (Aligned_Integer'Asm_Input ("m", To),
Integer'Asm_Input ("rJ", From)),
Clobber => "$0, $1",
Volatile => True);
end And_Atomic;
procedure And_Atomic
(To : in out Aligned_Integer;
From : Integer;
Retry_Count : Natural;
Old_Value : out Integer;
Success_Flag : out Boolean)
is
use ASCII;
begin
System.Machine_Code.Asm
(
"mb" & LF & HT &
"bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"and $1, %4, $0" & LF & HT &
"stl_c $0, %3" & LF & HT &
"beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stl $1, %1" & LF & HT &
"br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
"br 3b" & LF &
"4:",
Outputs => (Aligned_Integer'Asm_Output ("=m", To),
Integer'Asm_Output ("=m", Old_Value),
Boolean'Asm_Output ("=m", Success_Flag)),
Inputs => (Aligned_Integer'Asm_Input ("m", To),
Integer'Asm_Input ("rJ", From),
Natural'Asm_Input ("rJ", Retry_Count)),
Clobber => "$0, $1, $17",
Volatile => True);
end And_Atomic;
procedure And_Atomic
(To : in out Aligned_Long_Integer;
From : Long_Integer)
is
use ASCII;
begin
System.Machine_Code.Asm
(
"mb" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"and $1, %2, $0" & LF & HT &
"stq_c $0, %1" & LF & HT &
"beq $0, 1b" & LF & HT &
"mb",
Outputs => Aligned_Long_Integer'Asm_Output ("=m", To),
Inputs => (Aligned_Long_Integer'Asm_Input ("m", To),
Long_Integer'Asm_Input ("rJ", From)),
Clobber => "$0, $1",
Volatile => True);
end And_Atomic;
procedure And_Atomic
(To : in out Aligned_Long_Integer;
From : Long_Integer;
Retry_Count : Natural;
Old_Value : out Long_Integer;
Success_Flag : out Boolean)
is
use ASCII;
begin
System.Machine_Code.Asm
(
"mb" & LF & HT &
"bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"and $1, %4, $0" & LF & HT &
"stq_c $0, %3" & LF & HT &
"beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stq $1, %1" & LF & HT &
"br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
"br 3b" & LF &
"4:",
Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To),
Long_Integer'Asm_Output ("=m", Old_Value),
Boolean'Asm_Output ("=m", Success_Flag)),
Inputs => (Aligned_Long_Integer'Asm_Input ("m", To),
Long_Integer'Asm_Input ("rJ", From),
Natural'Asm_Input ("rJ", Retry_Count)),
Clobber => "$0, $1, $17",
Volatile => True);
end And_Atomic;
---------------
-- Or_Atomic --
---------------
procedure Or_Atomic
(To : in out Aligned_Integer;
From : Integer)
is
use ASCII;
begin
System.Machine_Code.Asm
(
"mb" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"bis $1, %2, $0" & LF & HT &
"stl_c $0, %1" & LF & HT &
"beq $0, 1b" & LF & HT &
"mb",
Outputs => Aligned_Integer'Asm_Output ("=m", To),
Inputs => (Aligned_Integer'Asm_Input ("m", To),
Integer'Asm_Input ("rJ", From)),
Clobber => "$0, $1",
Volatile => True);
end Or_Atomic;
procedure Or_Atomic
(To : in out Aligned_Integer;
From : Integer;
Retry_Count : Natural;
Old_Value : out Integer;
Success_Flag : out Boolean)
is
use ASCII;
begin
System.Machine_Code.Asm
(
"mb" & LF & HT &
"bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldl_l $1, %0" & LF & HT &
"bis $1, %4, $0" & LF & HT &
"stl_c $0, %3" & LF & HT &
"beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stl $1, %1" & LF & HT &
"br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
"br 3b" & LF &
"4:",
Outputs => (Aligned_Integer'Asm_Output ("=m", To),
Integer'Asm_Output ("=m", Old_Value),
Boolean'Asm_Output ("=m", Success_Flag)),
Inputs => (Aligned_Integer'Asm_Input ("m", To),
Integer'Asm_Input ("rJ", From),
Natural'Asm_Input ("rJ", Retry_Count)),
Clobber => "$0, $1, $17",
Volatile => True);
end Or_Atomic;
procedure Or_Atomic
(To : in out Aligned_Long_Integer;
From : Long_Integer)
is
use ASCII;
begin
System.Machine_Code.Asm
(
"mb" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"bis $1, %2, $0" & LF & HT &
"stq_c $0, %1" & LF & HT &
"beq $0, 1b" & LF & HT &
"mb",
Outputs => Aligned_Long_Integer'Asm_Output ("=m", To),
Inputs => (Aligned_Long_Integer'Asm_Input ("m", To),
Long_Integer'Asm_Input ("rJ", From)),
Clobber => "$0, $1",
Volatile => True);
end Or_Atomic;
procedure Or_Atomic
(To : in out Aligned_Long_Integer;
From : Long_Integer;
Retry_Count : Natural;
Old_Value : out Long_Integer;
Success_Flag : out Boolean)
is
use ASCII;
begin
System.Machine_Code.Asm
(
"mb" & LF & HT &
"bis $31, %5, $17" & LF &
"1:" & LF & HT &
"ldq_l $1, %0" & LF & HT &
"bis $1, %4, $0" & LF & HT &
"stq_c $0, %3" & LF & HT &
"beq $0, 2f" & LF &
"3:" & LF & HT &
"mb" & LF & HT &
"stq $0, %2" & LF & HT &
"stq $1, %1" & LF & HT &
"br 4f" & LF &
"2:" & LF & HT &
"subq $17, 1, $17" & LF & HT &
"bgt $17, 1b" & LF & HT &
"br 3b" & LF &
"4:",
Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To),
Long_Integer'Asm_Output ("=m", Old_Value),
Boolean'Asm_Output ("=m", Success_Flag)),
Inputs => (Aligned_Long_Integer'Asm_Input ("m", To),
Long_Integer'Asm_Input ("rJ", From),
Natural'Asm_Input ("rJ", Retry_Count)),
Clobber => "$0, $1, $17",
Volatile => True);
end Or_Atomic;
------------
-- Insqhi --
------------
procedure Insqhi
(Item : Address;
Header : Address;
Status : out Insq_Status)
is
use ASCII;
begin
System.Machine_Code.Asm
(
"bis $31, %1, $17" & LF & HT &
"bis $31, %2, $16" & LF & HT &
"mb" & LF & HT &
"call_pal 0x87" & LF & HT &
"mb",
Outputs => Insq_Status'Asm_Output ("=v", Status),
Inputs => (Address'Asm_Input ("rJ", Item),
Address'Asm_Input ("rJ", Header)),
Clobber => "$16, $17",
Volatile => True);
end Insqhi;
------------
-- Remqhi --
------------
procedure Remqhi
(Header : Address;
Item : out Address;
Status : out Remq_Status)
is
use ASCII;
begin
System.Machine_Code.Asm
(
"bis $31, %2, $16" & LF & HT &
"mb" & LF & HT &
"call_pal 0x93" & LF & HT &
"mb" & LF & HT &
"bis $31, $1, %1",
Outputs => (Remq_Status'Asm_Output ("=v", Status),
Address'Asm_Output ("=r", Item)),
Inputs => Address'Asm_Input ("rJ", Header),
Clobber => "$1, $16",
Volatile => True);
end Remqhi;
------------
-- Insqti --
------------
procedure Insqti
(Item : Address;
Header : Address;
Status : out Insq_Status)
is
use ASCII;
begin
System.Machine_Code.Asm
(
"bis $31, %1, $17" & LF & HT &
"bis $31, %2, $16" & LF & HT &
"mb" & LF & HT &
"call_pal 0x88" & LF & HT &
"mb",
Outputs => Insq_Status'Asm_Output ("=v", Status),
Inputs => (Address'Asm_Input ("rJ", Item),
Address'Asm_Input ("rJ", Header)),
Clobber => "$16, $17",
Volatile => True);
end Insqti;
------------
-- Remqti --
------------
procedure Remqti
(Header : Address;
Item : out Address;
Status : out Remq_Status)
is
use ASCII;
begin
System.Machine_Code.Asm
(
"bis $31, %2, $16" & LF & HT &
"mb" & LF & HT &
"call_pal 0x94" & LF & HT &
"mb" & LF & HT &
"bis $31, $1, %1",
Outputs => (Remq_Status'Asm_Output ("=v", Status),
Address'Asm_Output ("=r", Item)),
Inputs => Address'Asm_Input ("rJ", Header),
Clobber => "$1, $16",
Volatile => True);
end Remqti;
end System.Aux_DEC;

576
gcc/ada/s-auxdec-vms-ia64.adb
View File

@ -1,576 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . A U X _ D E C --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2012, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the Itanium/VMS version.
-- The Add,Clear_Interlocked subprograms are dubiously implmented due to
-- the lack of a single bit sync_lock_test_and_set builtin.
-- The "Retry" parameter is ignored due to the lack of retry builtins making
-- the subprograms identical to the non-retry versions.
pragma Style_Checks (All_Checks);
-- Turn off alpha ordering check on subprograms, this unit is laid
-- out to correspond to the declarations in the DEC 83 System unit.
with Interfaces;
package body System.Aux_DEC is
use type Interfaces.Unsigned_8;
------------------------
-- Fetch_From_Address --
------------------------
function Fetch_From_Address (A : Address) return Target is
type T_Ptr is access all Target;
function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
Ptr : constant T_Ptr := To_T_Ptr (A);
begin
return Ptr.all;
end Fetch_From_Address;
-----------------------
-- Assign_To_Address --
-----------------------
procedure Assign_To_Address (A : Address; T : Target) is
type T_Ptr is access all Target;
function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
Ptr : constant T_Ptr := To_T_Ptr (A);
begin
Ptr.all := T;
end Assign_To_Address;
-----------------------
-- Clear_Interlocked --
-----------------------
procedure Clear_Interlocked
(Bit : in out Boolean;
Old_Value : out Boolean)
is
Clr_Bit : Boolean := Bit;
Old_Uns : Interfaces.Unsigned_8;
function Sync_Lock_Test_And_Set
(Ptr : Address;
Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
"__sync_lock_test_and_set_1");
begin
Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);
Bit := Clr_Bit;
Old_Value := Old_Uns /= 0;
end Clear_Interlocked;
procedure Clear_Interlocked
(Bit : in out Boolean;
Old_Value : out Boolean;
Retry_Count : Natural;
Success_Flag : out Boolean)
is
pragma Unreferenced (Retry_Count);
Clr_Bit : Boolean := Bit;
Old_Uns : Interfaces.Unsigned_8;
function Sync_Lock_Test_And_Set
(Ptr : Address;
Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
"__sync_lock_test_and_set_1");
begin
Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);
Bit := Clr_Bit;
Old_Value := Old_Uns /= 0;
Success_Flag := True;
end Clear_Interlocked;
---------------------
-- Set_Interlocked --
---------------------
procedure Set_Interlocked
(Bit : in out Boolean;
Old_Value : out Boolean)
is
Set_Bit : Boolean := Bit;
Old_Uns : Interfaces.Unsigned_8;
function Sync_Lock_Test_And_Set
(Ptr : Address;
Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
"__sync_lock_test_and_set_1");
begin
Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);
Bit := Set_Bit;
Old_Value := Old_Uns /= 0;
end Set_Interlocked;
procedure Set_Interlocked
(Bit : in out Boolean;
Old_Value : out Boolean;
Retry_Count : Natural;
Success_Flag : out Boolean)
is
pragma Unreferenced (Retry_Count);
Set_Bit : Boolean := Bit;
Old_Uns : Interfaces.Unsigned_8;
function Sync_Lock_Test_And_Set
(Ptr : Address;
Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
"__sync_lock_test_and_set_1");
begin
Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);
Bit := Set_Bit;
Old_Value := Old_Uns /= 0;
Success_Flag := True;
end Set_Interlocked;
---------------------
-- Add_Interlocked --
---------------------
procedure Add_Interlocked
(Addend : Short_Integer;
Augend : in out Aligned_Word;
Sign : out Integer)
is
Overflowed : Boolean := False;
Former : Aligned_Word;
function Sync_Fetch_And_Add
(Ptr : Address;
Value : Short_Integer) return Short_Integer;
pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_2");
begin
Former.Value := Sync_Fetch_And_Add (Augend.Value'Address, Addend);
if Augend.Value < 0 then
Sign := -1;
elsif Augend.Value > 0 then
Sign := 1;
else
Sign := 0;
end if;
if Former.Value > 0 and then Augend.Value <= 0 then
Overflowed := True;
end if;
if Overflowed then
raise Constraint_Error;
end if;
end Add_Interlocked;
----------------
-- Add_Atomic --
----------------
procedure Add_Atomic
(To : in out Aligned_Integer;
Amount : Integer)
is
procedure Sync_Add_And_Fetch
(Ptr : Address;
Value : Integer);
pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4");
begin
Sync_Add_And_Fetch (To.Value'Address, Amount);
end Add_Atomic;
procedure Add_Atomic
(To : in out Aligned_Integer;
Amount : Integer;
Retry_Count : Natural;
Old_Value : out Integer;
Success_Flag : out Boolean)
is
pragma Unreferenced (Retry_Count);
function Sync_Fetch_And_Add
(Ptr : Address;
Value : Integer) return Integer;
pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_4");
begin
Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);
Success_Flag := True;
end Add_Atomic;
procedure Add_Atomic
(To : in out Aligned_Long_Integer;
Amount : Long_Integer)
is
procedure Sync_Add_And_Fetch
(Ptr : Address;
Value : Long_Integer);
pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_8");
begin
Sync_Add_And_Fetch (To.Value'Address, Amount);
end Add_Atomic;
procedure Add_Atomic
(To : in out Aligned_Long_Integer;
Amount : Long_Integer;
Retry_Count : Natural;
Old_Value : out Long_Integer;
Success_Flag : out Boolean)
is
pragma Unreferenced (Retry_Count);
function Sync_Fetch_And_Add
(Ptr : Address;
Value : Long_Integer) return Long_Integer;
pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_8");
-- Why do we keep importing this over and over again???
begin
Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);
Success_Flag := True;
end Add_Atomic;
----------------
-- And_Atomic --
----------------
procedure And_Atomic
(To : in out Aligned_Integer;
From : Integer)
is
procedure Sync_And_And_Fetch
(Ptr : Address;
Value : Integer);
pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_4");
begin
Sync_And_And_Fetch (To.Value'Address, From);
end And_Atomic;
procedure And_Atomic
(To : in out Aligned_Integer;
From : Integer;
Retry_Count : Natural;
Old_Value : out Integer;
Success_Flag : out Boolean)
is
pragma Unreferenced (Retry_Count);
function Sync_Fetch_And_And
(Ptr : Address;
Value : Integer) return Integer;
pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_4");
begin
Old_Value := Sync_Fetch_And_And (To.Value'Address, From);
Success_Flag := True;
end And_Atomic;
procedure And_Atomic
(To : in out Aligned_Long_Integer;
From : Long_Integer)
is
procedure Sync_And_And_Fetch
(Ptr : Address;
Value : Long_Integer);
pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_8");
begin
Sync_And_And_Fetch (To.Value'Address, From);
end And_Atomic;
procedure And_Atomic
(To : in out Aligned_Long_Integer;
From : Long_Integer;
Retry_Count : Natural;
Old_Value : out Long_Integer;
Success_Flag : out Boolean)
is
pragma Unreferenced (Retry_Count);
function Sync_Fetch_And_And
(Ptr : Address;
Value : Long_Integer) return Long_Integer;
pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_8");
begin
Old_Value := Sync_Fetch_And_And (To.Value'Address, From);
Success_Flag := True;
end And_Atomic;
---------------
-- Or_Atomic --
---------------
procedure Or_Atomic
(To : in out Aligned_Integer;
From : Integer)
is
procedure Sync_Or_And_Fetch
(Ptr : Address;
Value : Integer);
pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_4");
begin
Sync_Or_And_Fetch (To.Value'Address, From);
end Or_Atomic;
procedure Or_Atomic
(To : in out Aligned_Integer;
From : Integer;
Retry_Count : Natural;
Old_Value : out Integer;
Success_Flag : out Boolean)
is
pragma Unreferenced (Retry_Count);
function Sync_Fetch_And_Or
(Ptr : Address;
Value : Integer) return Integer;
pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_4");
begin
Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);
Success_Flag := True;
end Or_Atomic;
procedure Or_Atomic
(To : in out Aligned_Long_Integer;
From : Long_Integer)
is
procedure Sync_Or_And_Fetch
(Ptr : Address;
Value : Long_Integer);
pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_8");
begin
Sync_Or_And_Fetch (To.Value'Address, From);
end Or_Atomic;
procedure Or_Atomic
(To : in out Aligned_Long_Integer;
From : Long_Integer;
Retry_Count : Natural;
Old_Value : out Long_Integer;
Success_Flag : out Boolean)
is
pragma Unreferenced (Retry_Count);
function Sync_Fetch_And_Or
(Ptr : Address;
Value : Long_Integer) return Long_Integer;
pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_8");
begin
Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);
Success_Flag := True;
end Or_Atomic;
------------
-- Insqhi --
------------
procedure Insqhi
(Item : Address;
Header : Address;
Status : out Insq_Status) is
procedure SYS_PAL_INSQHIL
(STATUS : out Integer; Header : Address; ITEM : Address);
pragma Import (External, SYS_PAL_INSQHIL);
pragma Import_Valued_Procedure (SYS_PAL_INSQHIL, "SYS$PAL_INSQHIL",
(Integer, Address, Address),
(Value, Value, Value));
Istat : Integer;
begin
SYS_PAL_INSQHIL (Istat, Header, Item);
if Istat = 0 then
Status := OK_Not_First;
elsif Istat = 1 then
Status := OK_First;
else
-- This status is never returned on IVMS
Status := Fail_No_Lock;
end if;
end Insqhi;
------------
-- Remqhi --
------------
procedure Remqhi
(Header : Address;
Item : out Address;
Status : out Remq_Status)
is
-- The removed item is returned in the second function return register,
-- R9 on IVMS. The VMS ABI calls for "small" records to be returned in
-- these registers, so inventing this odd looking record type makes that
-- all work.
type Remq is record
Status : Long_Integer;
Item : Address;
end record;
procedure SYS_PAL_REMQHIL
(Remret : out Remq; Header : Address);
pragma Import (External, SYS_PAL_REMQHIL);
pragma Import_Valued_Procedure
(SYS_PAL_REMQHIL, "SYS$PAL_REMQHIL",
(Remq, Address),
(Value, Value));
-- Following variables need documentation???
Rstat : Long_Integer;
Remret : Remq;
begin
SYS_PAL_REMQHIL (Remret, Header);
Rstat := Remret.Status;
Item := Remret.Item;
if Rstat = 0 then
Status := Fail_Was_Empty;
elsif Rstat = 1 then
Status := OK_Not_Empty;
elsif Rstat = 2 then
Status := OK_Empty;
else
-- This status is never returned on IVMS
Status := Fail_No_Lock;
end if;
end Remqhi;
------------
-- Insqti --
------------
procedure Insqti
(Item : Address;
Header : Address;
Status : out Insq_Status) is
procedure SYS_PAL_INSQTIL
(STATUS : out Integer; Header : Address; ITEM : Address);
pragma Import (External, SYS_PAL_INSQTIL);
pragma Import_Valued_Procedure (SYS_PAL_INSQTIL, "SYS$PAL_INSQTIL",
(Integer, Address, Address),
(Value, Value, Value));
Istat : Integer;
begin
SYS_PAL_INSQTIL (Istat, Header, Item);
if Istat = 0 then
Status := OK_Not_First;
elsif Istat = 1 then
Status := OK_First;
else
-- This status is never returned on IVMS
Status := Fail_No_Lock;
end if;
end Insqti;
------------
-- Remqti --
------------
procedure Remqti
(Header : Address;
Item : out Address;
Status : out Remq_Status)
is
-- The removed item is returned in the second function return register,
-- R9 on IVMS. The VMS ABI calls for "small" records to be returned in
-- these registers, so inventing (where is rest of this comment???)
type Remq is record
Status : Long_Integer;
Item : Address;
end record;
procedure SYS_PAL_REMQTIL
(Remret : out Remq; Header : Address);
pragma Import (External, SYS_PAL_REMQTIL);
pragma Import_Valued_Procedure (SYS_PAL_REMQTIL, "SYS$PAL_REMQTIL",
(Remq, Address),
(Value, Value));
Rstat : Long_Integer;
Remret : Remq;
begin
SYS_PAL_REMQTIL (Remret, Header);
Rstat := Remret.Status;
Item := Remret.Item;
-- Wouldn't case be nicer here, and in previous similar cases ???
if Rstat = 0 then
Status := Fail_Was_Empty;
elsif Rstat = 1 then
Status := OK_Not_Empty;
elsif Rstat = 2 then
Status := OK_Empty;
else
-- This status is never returned on IVMS
Status := Fail_No_Lock;
end if;
end Remqti;
end System.Aux_DEC;

693
gcc/ada/s-auxdec-vms_64.ads
View File

@ -1,693 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . A U X _ D E C --
-- --
-- S p e c --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package contains definitions that are designed to be compatible
-- with the extra definitions in package System for DEC Ada implementations.
-- These definitions can be used directly by withing this package, or merged
-- with System using pragma Extend_System (Aux_DEC)
-- This is the VMS 64 bit version
with Ada.Unchecked_Conversion;
package System.Aux_DEC is
pragma Preelaborate;
type Short_Integer_Address is
range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1;
-- Integer literals cannot appear naked in an address context, as a
-- result the bounds of Short_Address cannot be given simply as 2^32 etc.
subtype Short_Address is Address
range Address (Short_Integer_Address'First) ..
Address (Short_Integer_Address'Last);
for Short_Address'Object_Size use 32;
-- This subtype allows addresses to be converted from 64 bits to 32 bits
-- with an appropriate range check. Note that since this is a subtype of
-- type System.Address, the same limitations apply to this subtype. Namely
-- there are no visible arithmetic operations, and integer literals are
-- not available.
Short_Memory_Size : constant := 2 ** 32;
-- Defined for convenience of porting
type Integer_8 is range -2 ** (8 - 1) .. +2 ** (8 - 1) - 1;
for Integer_8'Size use 8;
type Integer_16 is range -2 ** (16 - 1) .. +2 ** (16 - 1) - 1;
for Integer_16'Size use 16;
type Integer_32 is range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1;
for Integer_32'Size use 32;
type Integer_64 is range -2 ** (64 - 1) .. +2 ** (64 - 1) - 1;
for Integer_64'Size use 64;
type Integer_8_Array is array (Integer range <>) of Integer_8;
type Integer_16_Array is array (Integer range <>) of Integer_16;
type Integer_32_Array is array (Integer range <>) of Integer_32;
type Integer_64_Array is array (Integer range <>) of Integer_64;
-- These array types are not in all versions of DEC System, and in fact it
-- is not quite clear why they are in some and not others, but since they
-- definitely appear in some versions, we include them unconditionally.
type Largest_Integer is range Min_Int .. Max_Int;
type AST_Handler is private;
No_AST_Handler : constant AST_Handler;
type Type_Class is
(Type_Class_Enumeration,
Type_Class_Integer,
Type_Class_Fixed_Point,
Type_Class_Floating_Point,
Type_Class_Array,
Type_Class_Record,
Type_Class_Access,
Type_Class_Task, -- also in Ada 95 protected
Type_Class_Address);
function "not" (Left : Largest_Integer) return Largest_Integer;
function "and" (Left, Right : Largest_Integer) return Largest_Integer;
function "or" (Left, Right : Largest_Integer) return Largest_Integer;
function "xor" (Left, Right : Largest_Integer) return Largest_Integer;
Address_Zero : constant Address;
No_Addr : constant Address;
Address_Size : constant := Standard'Address_Size;
Short_Address_Size : constant := 32;
function "+" (Left : Address; Right : Integer) return Address;
function "+" (Left : Integer; Right : Address) return Address;
function "-" (Left : Address; Right : Address) return Integer;
function "-" (Left : Address; Right : Integer) return Address;
pragma Import (Intrinsic, "+");
pragma Import (Intrinsic, "-");
generic
type Target is private;
function Fetch_From_Address (A : Address) return Target;
generic
type Target is private;
procedure Assign_To_Address (A : Address; T : Target);
-- Floating point type declarations for VAX floating point data types
pragma Warnings (Off);
-- ??? needs comment
type F_Float is digits 6;
pragma Float_Representation (VAX_Float, F_Float);
type D_Float is digits 9;
pragma Float_Representation (Vax_Float, D_Float);
type G_Float is digits 15;
pragma Float_Representation (Vax_Float, G_Float);
-- Floating point type declarations for IEEE floating point data types
type IEEE_Single_Float is digits 6;
pragma Float_Representation (IEEE_Float, IEEE_Single_Float);
type IEEE_Double_Float is digits 15;
pragma Float_Representation (IEEE_Float, IEEE_Double_Float);
pragma Warnings (On);
Non_Ada_Error : exception;
-- Hardware-oriented types and functions
type Bit_Array is array (Integer range <>) of Boolean;
pragma Pack (Bit_Array);
subtype Bit_Array_8 is Bit_Array (0 .. 7);
subtype Bit_Array_16 is Bit_Array (0 .. 15);
subtype Bit_Array_32 is Bit_Array (0 .. 31);
subtype Bit_Array_64 is Bit_Array (0 .. 63);
type Unsigned_Byte is range 0 .. 255;
for Unsigned_Byte'Size use 8;
function "not" (Left : Unsigned_Byte) return Unsigned_Byte;
function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte;
function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte;
function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte;
function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte;
function To_Bit_Array_8 (X : Unsigned_Byte) return Bit_Array_8;
type Unsigned_Byte_Array is array (Integer range <>) of Unsigned_Byte;
type Unsigned_Word is range 0 .. 65535;
for Unsigned_Word'Size use 16;
function "not" (Left : Unsigned_Word) return Unsigned_Word;
function "and" (Left, Right : Unsigned_Word) return Unsigned_Word;
function "or" (Left, Right : Unsigned_Word) return Unsigned_Word;
function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word;
function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word;
function To_Bit_Array_16 (X : Unsigned_Word) return Bit_Array_16;
type Unsigned_Word_Array is array (Integer range <>) of Unsigned_Word;
type Unsigned_Longword is range -2_147_483_648 .. 2_147_483_647;
for Unsigned_Longword'Size use 32;
function "not" (Left : Unsigned_Longword) return Unsigned_Longword;
function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword;
function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword;
function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword;
function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword;
function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32;
type Unsigned_Longword_Array is
array (Integer range <>) of Unsigned_Longword;
type Unsigned_32 is range 0 .. 4_294_967_295;
for Unsigned_32'Size use 32;
function "not" (Left : Unsigned_32) return Unsigned_32;
function "and" (Left, Right : Unsigned_32) return Unsigned_32;
function "or" (Left, Right : Unsigned_32) return Unsigned_32;
function "xor" (Left, Right : Unsigned_32) return Unsigned_32;
function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32;
function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32;
type Unsigned_Quadword is record
L0 : Unsigned_Longword;
L1 : Unsigned_Longword;
end record;
for Unsigned_Quadword'Size use 64;
for Unsigned_Quadword'Alignment use
Integer'Min (8, Standard'Maximum_Alignment);
function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword;
function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword;
function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword;
function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword;
function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword;
function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64;
type Unsigned_Quadword_Array is
array (Integer range <>) of Unsigned_Quadword;
function To_Address (X : Integer) return Short_Address;
pragma Pure_Function (To_Address);
function To_Address_Long (X : Unsigned_Longword) return Short_Address;
pragma Pure_Function (To_Address_Long);
function To_Integer (X : Short_Address) return Integer;
function To_Unsigned_Longword (X : Short_Address) return Unsigned_Longword;
function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword;
-- Conventional names for static subtypes of type UNSIGNED_LONGWORD
subtype Unsigned_1 is Unsigned_Longword range 0 .. 2** 1 - 1;
subtype Unsigned_2 is Unsigned_Longword range 0 .. 2** 2 - 1;
subtype Unsigned_3 is Unsigned_Longword range 0 .. 2** 3 - 1;
subtype Unsigned_4 is Unsigned_Longword range 0 .. 2** 4 - 1;
subtype Unsigned_5 is Unsigned_Longword range 0 .. 2** 5 - 1;
subtype Unsigned_6 is Unsigned_Longword range 0 .. 2** 6 - 1;
subtype Unsigned_7 is Unsigned_Longword range 0 .. 2** 7 - 1;
subtype Unsigned_8 is Unsigned_Longword range 0 .. 2** 8 - 1;
subtype Unsigned_9 is Unsigned_Longword range 0 .. 2** 9 - 1;
subtype Unsigned_10 is Unsigned_Longword range 0 .. 2**10 - 1;
subtype Unsigned_11 is Unsigned_Longword range 0 .. 2**11 - 1;
subtype Unsigned_12 is Unsigned_Longword range 0 .. 2**12 - 1;
subtype Unsigned_13 is Unsigned_Longword range 0 .. 2**13 - 1;
subtype Unsigned_14 is Unsigned_Longword range 0 .. 2**14 - 1;
subtype Unsigned_15 is Unsigned_Longword range 0 .. 2**15 - 1;
subtype Unsigned_16 is Unsigned_Longword range 0 .. 2**16 - 1;
subtype Unsigned_17 is Unsigned_Longword range 0 .. 2**17 - 1;
subtype Unsigned_18 is Unsigned_Longword range 0 .. 2**18 - 1;
subtype Unsigned_19 is Unsigned_Longword range 0 .. 2**19 - 1;
subtype Unsigned_20 is Unsigned_Longword range 0 .. 2**20 - 1;
subtype Unsigned_21 is Unsigned_Longword range 0 .. 2**21 - 1;
subtype Unsigned_22 is Unsigned_Longword range 0 .. 2**22 - 1;
subtype Unsigned_23 is Unsigned_Longword range 0 .. 2**23 - 1;
subtype Unsigned_24 is Unsigned_Longword range 0 .. 2**24 - 1;
subtype Unsigned_25 is Unsigned_Longword range 0 .. 2**25 - 1;
subtype Unsigned_26 is Unsigned_Longword range 0 .. 2**26 - 1;
subtype Unsigned_27 is Unsigned_Longword range 0 .. 2**27 - 1;
subtype Unsigned_28 is Unsigned_Longword range 0 .. 2**28 - 1;
subtype Unsigned_29 is Unsigned_Longword range 0 .. 2**29 - 1;
subtype Unsigned_30 is Unsigned_Longword range 0 .. 2**30 - 1;
subtype Unsigned_31 is Unsigned_Longword range 0 .. 2**31 - 1;
-- Function for obtaining global symbol values
function Import_Value (Symbol : String) return Unsigned_Longword;
function Import_Address (Symbol : String) return Address;
function Import_Largest_Value (Symbol : String) return Largest_Integer;
pragma Import (Intrinsic, Import_Value);
pragma Import (Intrinsic, Import_Address);
pragma Import (Intrinsic, Import_Largest_Value);
-- For the following declarations, note that the declaration without a
-- Retry_Count parameter means to retry infinitely. A value of zero for
-- the Retry_Count parameter means do not retry.
-- Interlocked-instruction procedures
procedure Clear_Interlocked
(Bit : in out Boolean;
Old_Value : out Boolean);
procedure Set_Interlocked
(Bit : in out Boolean;
Old_Value : out Boolean);
type Aligned_Word is record
Value : Short_Integer;
end record;
for Aligned_Word'Alignment use Integer'Min (2, Standard'Maximum_Alignment);
procedure Clear_Interlocked
(Bit : in out Boolean;
Old_Value : out Boolean;
Retry_Count : Natural;
Success_Flag : out Boolean);
procedure Set_Interlocked
(Bit : in out Boolean;
Old_Value : out Boolean;
Retry_Count : Natural;
Success_Flag : out Boolean);
procedure Add_Interlocked
(Addend : Short_Integer;
Augend : in out Aligned_Word;
Sign : out Integer);
type Aligned_Integer is record
Value : Integer;
end record;
for Aligned_Integer'Alignment use
Integer'Min (4, Standard'Maximum_Alignment);
type Aligned_Long_Integer is record
Value : Long_Integer;
end record;
for Aligned_Long_Integer'Alignment use
Integer'Min (8, Standard'Maximum_Alignment);
-- For the following declarations, note that the declaration without a
-- Retry_Count parameter mean to retry infinitely. A value of zero for
-- the Retry_Count means do not retry.
procedure Add_Atomic
(To : in out Aligned_Integer;
Amount : Integer);
procedure Add_Atomic
(To : in out Aligned_Integer;
Amount : Integer;
Retry_Count : Natural;
Old_Value : out Integer;
Success_Flag : out Boolean);
procedure Add_Atomic
(To : in out Aligned_Long_Integer;
Amount : Long_Integer);
procedure Add_Atomic
(To : in out Aligned_Long_Integer;
Amount : Long_Integer;
Retry_Count : Natural;
Old_Value : out Long_Integer;
Success_Flag : out Boolean);
procedure And_Atomic
(To : in out Aligned_Integer;
From : Integer);
procedure And_Atomic
(To : in out Aligned_Integer;
From : Integer;
Retry_Count : Natural;
Old_Value : out Integer;
Success_Flag : out Boolean);
procedure And_Atomic
(To : in out Aligned_Long_Integer;
From : Long_Integer);
procedure And_Atomic
(To : in out Aligned_Long_Integer;
From : Long_Integer;
Retry_Count : Natural;
Old_Value : out Long_Integer;
Success_Flag : out Boolean);
procedure Or_Atomic
(To : in out Aligned_Integer;
From : Integer);
procedure Or_Atomic
(To : in out Aligned_Integer;
From : Integer;
Retry_Count : Natural;
Old_Value : out Integer;
Success_Flag : out Boolean);
procedure Or_Atomic
(To : in out Aligned_Long_Integer;
From : Long_Integer);
procedure Or_Atomic
(To : in out Aligned_Long_Integer;
From : Long_Integer;
Retry_Count : Natural;
Old_Value : out Long_Integer;
Success_Flag : out Boolean);
type Insq_Status is (Fail_No_Lock, OK_Not_First, OK_First);
for Insq_Status use
(Fail_No_Lock => -1,
OK_Not_First => 0,
OK_First => +1);
type Remq_Status is (
Fail_No_Lock,
Fail_Was_Empty,
OK_Not_Empty,
OK_Empty);
for Remq_Status use
(Fail_No_Lock => -1,
Fail_Was_Empty => 0,
OK_Not_Empty => +1,
OK_Empty => +2);
procedure Insqhi
(Item : Address;
Header : Address;
Status : out Insq_Status);
procedure Remqhi
(Header : Address;
Item : out Address;
Status : out Remq_Status);
procedure Insqti
(Item : Address;
Header : Address;
Status : out Insq_Status);
procedure Remqti
(Header : Address;
Item : out Address;
Status : out Remq_Status);
private
Address_Zero : constant Address := Null_Address;
No_Addr : constant Address := Null_Address;
-- An AST_Handler value is from a typing point of view simply a pointer
-- to a procedure taking a single 64 bit parameter. However, this
-- is a bit misleading, because the data that this pointer references is
-- highly stylized. See body of System.AST_Handling for full details.
type AST_Handler is access procedure (Param : Long_Integer);
No_AST_Handler : constant AST_Handler := null;
-- Other operators have incorrect profiles. It would be nice to make
-- them intrinsic, since the backend can handle them, but the front
-- end is not prepared to deal with them, so at least inline them.
pragma Import (Intrinsic, "not");
pragma Import (Intrinsic, "and");
pragma Import (Intrinsic, "or");
pragma Import (Intrinsic, "xor");
-- Other inlined subprograms
pragma Inline_Always (Fetch_From_Address);
pragma Inline_Always (Assign_To_Address);
-- Synchronization related subprograms. Mechanism is explicitly set
-- so that the critical parameters are passed by reference.
-- Without this, the parameters are passed by copy, creating load/store
-- race conditions. We also inline them, since this seems more in the
-- spirit of the original (hardware intrinsic) routines.
pragma Export_Procedure
(Clear_Interlocked,
External => "system__aux_dec__clear_interlocked__1",
Parameter_Types => (Boolean, Boolean),
Mechanism => (Reference, Reference));
pragma Export_Procedure
(Clear_Interlocked,
External => "system__aux_dec__clear_interlocked__2",
Parameter_Types => (Boolean, Boolean, Natural, Boolean),
Mechanism => (Reference, Reference, Value, Reference));
pragma Inline_Always (Clear_Interlocked);
pragma Export_Procedure
(Set_Interlocked,
External => "system__aux_dec__set_interlocked__1",
Parameter_Types => (Boolean, Boolean),
Mechanism => (Reference, Reference));
pragma Export_Procedure
(Set_Interlocked,
External => "system__aux_dec__set_interlocked__2",
Parameter_Types => (Boolean, Boolean, Natural, Boolean),
Mechanism => (Reference, Reference, Value, Reference));
pragma Inline_Always (Set_Interlocked);
pragma Export_Procedure
(Add_Interlocked,
External => "system__aux_dec__add_interlocked__1",
Mechanism => (Value, Reference, Reference));
pragma Inline_Always (Add_Interlocked);
pragma Export_Procedure
(Add_Atomic,
External => "system__aux_dec__add_atomic__1",
Parameter_Types => (Aligned_Integer, Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(Add_Atomic,
External => "system__aux_dec__add_atomic__2",
Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Export_Procedure
(Add_Atomic,
External => "system__aux_dec__add_atomic__3",
Parameter_Types => (Aligned_Long_Integer, Long_Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(Add_Atomic,
External => "system__aux_dec__add_atomic__4",
Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural,
Long_Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Inline_Always (Add_Atomic);
pragma Export_Procedure
(And_Atomic,
External => "system__aux_dec__and_atomic__1",
Parameter_Types => (Aligned_Integer, Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(And_Atomic,
External => "system__aux_dec__and_atomic__2",
Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Export_Procedure
(And_Atomic,
External => "system__aux_dec__and_atomic__3",
Parameter_Types => (Aligned_Long_Integer, Long_Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(And_Atomic,
External => "system__aux_dec__and_atomic__4",
Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural,
Long_Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Inline_Always (And_Atomic);
pragma Export_Procedure
(Or_Atomic,
External => "system__aux_dec__or_atomic__1",
Parameter_Types => (Aligned_Integer, Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(Or_Atomic,
External => "system__aux_dec__or_atomic__2",
Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Export_Procedure
(Or_Atomic,
External => "system__aux_dec__or_atomic__3",
Parameter_Types => (Aligned_Long_Integer, Long_Integer),
Mechanism => (Reference, Value));
pragma Export_Procedure
(Or_Atomic,
External => "system__aux_dec__or_atomic__4",
Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural,
Long_Integer, Boolean),
Mechanism => (Reference, Value, Value, Reference, Reference));
pragma Inline_Always (Or_Atomic);
-- Inline the VAX Queue Functions
pragma Inline_Always (Insqhi);
pragma Inline_Always (Remqhi);
pragma Inline_Always (Insqti);
pragma Inline_Always (Remqti);
-- Provide proper unchecked conversion definitions for transfer
-- functions. Note that we need this level of indirection because
-- the formal parameter name is X and not Source (and this is indeed
-- detectable by a program)
function To_Unsigned_Byte_A is new
Ada.Unchecked_Conversion (Bit_Array_8, Unsigned_Byte);
function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte
renames To_Unsigned_Byte_A;
function To_Bit_Array_8_A is new
Ada.Unchecked_Conversion (Unsigned_Byte, Bit_Array_8);
function To_Bit_Array_8 (X : Unsigned_Byte) return Bit_Array_8
renames To_Bit_Array_8_A;
function To_Unsigned_Word_A is new
Ada.Unchecked_Conversion (Bit_Array_16, Unsigned_Word);
function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word
renames To_Unsigned_Word_A;
function To_Bit_Array_16_A is new
Ada.Unchecked_Conversion (Unsigned_Word, Bit_Array_16);
function To_Bit_Array_16 (X : Unsigned_Word) return Bit_Array_16
renames To_Bit_Array_16_A;
function To_Unsigned_Longword_A is new
Ada.Unchecked_Conversion (Bit_Array_32, Unsigned_Longword);
function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword
renames To_Unsigned_Longword_A;
function To_Bit_Array_32_A is new
Ada.Unchecked_Conversion (Unsigned_Longword, Bit_Array_32);
function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32
renames To_Bit_Array_32_A;
function To_Unsigned_32_A is new
Ada.Unchecked_Conversion (Bit_Array_32, Unsigned_32);
function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32
renames To_Unsigned_32_A;
function To_Bit_Array_32_A is new
Ada.Unchecked_Conversion (Unsigned_32, Bit_Array_32);
function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32
renames To_Bit_Array_32_A;
function To_Unsigned_Quadword_A is new
Ada.Unchecked_Conversion (Bit_Array_64, Unsigned_Quadword);
function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword
renames To_Unsigned_Quadword_A;
function To_Bit_Array_64_A is new
Ada.Unchecked_Conversion (Unsigned_Quadword, Bit_Array_64);
function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64
renames To_Bit_Array_64_A;
pragma Warnings (Off);
-- Turn warnings off. This is needed for systems with 64-bit integers,
-- where some of these operations are of dubious meaning, but we do not
-- want warnings when we compile on such systems.
function To_Address_A is new
Ada.Unchecked_Conversion (Integer, Short_Address);
pragma Pure_Function (To_Address_A);
function To_Address (X : Integer) return Short_Address
renames To_Address_A;
pragma Pure_Function (To_Address);
function To_Address_Long_A is new
Ada.Unchecked_Conversion (Unsigned_Longword, Short_Address);
pragma Pure_Function (To_Address_Long_A);
function To_Address_Long (X : Unsigned_Longword) return Short_Address
renames To_Address_Long_A;
pragma Pure_Function (To_Address_Long);
function To_Integer_A is new
Ada.Unchecked_Conversion (Short_Address, Integer);
function To_Integer (X : Short_Address) return Integer
renames To_Integer_A;
function To_Unsigned_Longword_A is new
Ada.Unchecked_Conversion (Short_Address, Unsigned_Longword);
function To_Unsigned_Longword (X : Short_Address) return Unsigned_Longword
renames To_Unsigned_Longword_A;
function To_Unsigned_Longword_A is new
Ada.Unchecked_Conversion (AST_Handler, Unsigned_Longword);
function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword
renames To_Unsigned_Longword_A;
pragma Warnings (On);
end System.Aux_DEC;

303
gcc/ada/s-inmaop-vms.adb
View File

@ -1,303 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a OpenVMS/Alpha version of this package
with System.OS_Interface;
with System.Aux_DEC;
with System.Parameters;
with System.Tasking;
with System.Tasking.Initialization;
with System.Task_Primitives;
with System.Task_Primitives.Operations;
with System.Task_Primitives.Operations.DEC;
with Ada.Unchecked_Conversion;
package body System.Interrupt_Management.Operations is
use System.OS_Interface;
use System.Parameters;
use System.Tasking;
use type unsigned_short;
function To_Address is
new Ada.Unchecked_Conversion
(Task_Id, System.Task_Primitives.Task_Address);
package POP renames System.Task_Primitives.Operations;
----------------------------
-- Thread_Block_Interrupt --
----------------------------
procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID) is
pragma Warnings (Off, Interrupt);
begin
null;
end Thread_Block_Interrupt;
------------------------------
-- Thread_Unblock_Interrupt --
------------------------------
procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID) is
pragma Warnings (Off, Interrupt);
begin
null;
end Thread_Unblock_Interrupt;
------------------------
-- Set_Interrupt_Mask --
------------------------
procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
pragma Warnings (Off, Mask);
begin
null;
end Set_Interrupt_Mask;
procedure Set_Interrupt_Mask
(Mask : access Interrupt_Mask;
OMask : access Interrupt_Mask)
is
pragma Warnings (Off, Mask);
pragma Warnings (Off, OMask);
begin
null;
end Set_Interrupt_Mask;
------------------------
-- Get_Interrupt_Mask --
------------------------
procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
pragma Warnings (Off, Mask);
begin
null;
end Get_Interrupt_Mask;
--------------------
-- Interrupt_Wait --
--------------------
function To_unsigned_long is new
Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, unsigned_long);
function Interrupt_Wait (Mask : access Interrupt_Mask)
return Interrupt_ID
is
Self_ID : constant Task_Id := Self;
Iosb : IO_Status_Block_Type := (0, 0, 0);
Status : Cond_Value_Type;
begin
-- A QIO read is registered. The system call returns immediately
-- after scheduling an AST to be fired when the operation
-- completes.
Sys_QIO
(Status => Status,
Chan => Rcv_Interrupt_Chan,
Func => IO_READVBLK,
Iosb => Iosb,
Astadr =>
POP.DEC.Interrupt_AST_Handler'Access,
Astprm => To_Address (Self_ID),
P1 => To_unsigned_long (Interrupt_Mailbox'Address),
P2 => Interrupt_ID'Size / 8);
pragma Assert ((Status and 1) = 1);
loop
-- Wait to be woken up. Could be that the AST has fired,
-- in which case the Iosb.Status variable will be non-zero,
-- or maybe the wait is being aborted.
POP.Sleep
(Self_ID,
System.Tasking.Interrupt_Server_Blocked_On_Event_Flag);
if Iosb.Status /= 0 then
if (Iosb.Status and 1) = 1
and then Mask (Signal (Interrupt_Mailbox))
then
return Interrupt_Mailbox;
else
return 0;
end if;
else
POP.Unlock (Self_ID);
if Single_Lock then
POP.Unlock_RTS;
end if;
System.Tasking.Initialization.Undefer_Abort (Self_ID);
System.Tasking.Initialization.Defer_Abort (Self_ID);
if Single_Lock then
POP.Lock_RTS;
end if;
POP.Write_Lock (Self_ID);
end if;
end loop;
end Interrupt_Wait;
----------------------------
-- Install_Default_Action --
----------------------------
procedure Install_Default_Action (Interrupt : Interrupt_ID) is
pragma Warnings (Off, Interrupt);
begin
null;
end Install_Default_Action;
---------------------------
-- Install_Ignore_Action --
---------------------------
procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
pragma Warnings (Off, Interrupt);
begin
null;
end Install_Ignore_Action;
-------------------------
-- Fill_Interrupt_Mask --
-------------------------
procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
begin
Mask.all := (others => True);
end Fill_Interrupt_Mask;
--------------------------
-- Empty_Interrupt_Mask --
--------------------------
procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
begin
Mask.all := (others => False);
end Empty_Interrupt_Mask;
---------------------------
-- Add_To_Interrupt_Mask --
---------------------------
procedure Add_To_Interrupt_Mask
(Mask : access Interrupt_Mask;
Interrupt : Interrupt_ID)
is
begin
Mask (Signal (Interrupt)) := True;
end Add_To_Interrupt_Mask;
--------------------------------
-- Delete_From_Interrupt_Mask --
--------------------------------
procedure Delete_From_Interrupt_Mask
(Mask : access Interrupt_Mask;
Interrupt : Interrupt_ID)
is
begin
Mask (Signal (Interrupt)) := False;
end Delete_From_Interrupt_Mask;
---------------
-- Is_Member --
---------------
function Is_Member
(Mask : access Interrupt_Mask;
Interrupt : Interrupt_ID) return Boolean
is
begin
return Mask (Signal (Interrupt));
end Is_Member;
-------------------------
-- Copy_Interrupt_Mask --
-------------------------
procedure Copy_Interrupt_Mask
(X : out Interrupt_Mask;
Y : Interrupt_Mask)
is
begin
X := Y;
end Copy_Interrupt_Mask;
----------------------------
-- Interrupt_Self_Process --
----------------------------
procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
Status : Cond_Value_Type;
begin
Sys_QIO
(Status => Status,
Chan => Snd_Interrupt_Chan,
Func => IO_WRITEVBLK,
P1 => To_unsigned_long (Interrupt'Address),
P2 => Interrupt_ID'Size / 8);
-- The following could use a comment ???
pragma Assert ((Status and 1) = 1);
end Interrupt_Self_Process;
--------------------------
-- Setup_Interrupt_Mask --
--------------------------
procedure Setup_Interrupt_Mask is
begin
null;
end Setup_Interrupt_Mask;
begin
Interrupt_Management.Initialize;
Environment_Mask := (others => False);
All_Tasks_Mask := (others => True);
for J in Interrupt_ID loop
if Keep_Unmasked (J) then
Environment_Mask (Signal (J)) := True;
All_Tasks_Mask (Signal (J)) := False;
end if;
end loop;
end System.Interrupt_Management.Operations;

1128
gcc/ada/s-interr-vms.adb
View File

File diff suppressed because it is too large Load Diff

76
gcc/ada/s-intman-vms.adb
View File

@ -1,76 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a OpenVMS/Alpha version of this package
package body System.Interrupt_Management is
----------------
-- Initialize --
----------------
Initialized : Boolean := False;
procedure Initialize is
use System.OS_Interface;
Status : Cond_Value_Type;
begin
if Initialized then
return;
end if;
Initialized := True;
Abort_Task_Interrupt := Interrupt_ID_0;
-- Unused
Reserve := Reserve or Keep_Unmasked or Keep_Masked;
Reserve (Interrupt_ID_0) := True;
Sys_Crembx
(Status => Status,
Prmflg => 0,
Chan => Rcv_Interrupt_Chan,
Maxmsg => Interrupt_ID'Size,
Bufquo => Interrupt_Bufquo,
Lognam => "GNAT_Interrupt_Mailbox",
Flags => CMB_M_READONLY);
pragma Assert ((Status and 1) = 1);
Sys_Assign
(Status => Status,
Devnam => "GNAT_Interrupt_Mailbox",
Chan => Snd_Interrupt_Chan,
Flags => AGN_M_WRITEONLY);
pragma Assert ((Status and 1) = 1);
end Initialize;
end System.Interrupt_Management;

119
gcc/ada/s-intman-vms.ads
View File

@ -1,119 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
-- --
-- S p e c --
-- --
-- Copyright (C) 1991-2009, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is the Alpha/VMS version of this package
-- This package encapsulates and centralizes information about all uses of
-- interrupts (or signals), including the target-dependent mapping of
-- interrupts (or signals) to exceptions.
-- PLEASE DO NOT add any with-clauses to this package
-- PLEASE DO NOT put any subprogram declarations with arguments of type
-- Interrupt_ID into the visible part of this package.
-- The type Interrupt_ID is used to derive the type in Ada.Interrupts, and
-- adding more operations to that type would be illegal according to the Ada
-- Reference Manual. (This is the reason why the signals sets below are
-- implemented as visible arrays rather than functions.)
with System.OS_Interface;
package System.Interrupt_Management is
pragma Preelaborate;
type Interrupt_Mask is limited private;
type Interrupt_ID is new System.OS_Interface.Signal;
type Interrupt_Set is array (Interrupt_ID) of Boolean;
-- The following objects serve as constants, but are initialized in the
-- body to aid portability. This permits us to use more portable names for
-- interrupts, where distinct names may map to the same interrupt ID
-- value. For example, suppose SIGRARE is a signal that is not defined on
-- all systems, but is always reserved when it is defined. If we have the
-- convention that ID zero is not used for any "real" signals, and SIGRARE
-- = 0 when SIGRARE is not one of the locally supported signals, we can
-- write:
-- Reserved (SIGRARE) := true;
-- Then the initialization code will be portable.
Abort_Task_Interrupt : Interrupt_ID;
-- The interrupt that is used to implement task abort, if an interrupt is
-- used for that purpose. This is one of the reserved interrupts.
Keep_Unmasked : Interrupt_Set := (others => False);
-- Keep_Unmasked (I) is true iff the interrupt I is one that must be kept
-- unmasked at all times, except (perhaps) for short critical sections.
-- This includes interrupts that are mapped to exceptions (see
-- System.Interrupt_Exceptions.Is_Exception), but may also include
-- interrupts (e.g. timer) that need to be kept unmasked for other
-- reasons. Where interrupts are implemented as OS signals, and signal
-- masking is per-task, the interrupt should be unmasked in ALL TASKS.
Reserve : Interrupt_Set := (others => False);
-- Reserve (I) is true iff the interrupt I is one that cannot be permitted
-- to be attached to a user handler. The possible reasons are many. For
-- example it may be mapped to an exception used to implement task abort.
Keep_Masked : Interrupt_Set := (others => False);
-- Keep_Masked (I) is true iff the interrupt I must always be masked.
-- Where interrupts are implemented as OS signals, and signal masking is
-- per-task, the interrupt should be masked in ALL TASKS. There might not
-- be any interrupts in this class, depending on the environment. For
-- example, if interrupts are OS signals and signal masking is per-task,
-- use of the sigwait operation requires the signal be masked in all tasks.
procedure Initialize;
-- Initialize the various variables defined in this package.
-- This procedure must be called before accessing any object from this
-- package and can be called multiple times.
private
use type System.OS_Interface.unsigned_long;
type Interrupt_Mask is new System.OS_Interface.sigset_t;
-- Interrupts on VMS are implemented with a mailbox. A QIO read is
-- registered on the Rcv channel and the interrupt occurs by registering
-- a QIO write on the Snd channel. The maximum number of pending
-- interrupts is arbitrarily set at 1000. One nice feature of using
-- a mailbox is that it is trivially extendable to cross process
-- interrupts.
Rcv_Interrupt_Chan : System.OS_Interface.unsigned_short := 0;
Snd_Interrupt_Chan : System.OS_Interface.unsigned_short := 0;
Interrupt_Mailbox : Interrupt_ID := 0;
Interrupt_Bufquo : System.OS_Interface.unsigned_long :=
1000 * (Interrupt_ID'Size / 8);
end System.Interrupt_Management;

274
gcc/ada/s-mastop-vms.adb
View File

@ -1,274 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- SYSTEM.MACHINE_STATE_OPERATIONS --
-- --
-- B o d y --
-- (Version for Alpha/VMS) --
-- --
-- Copyright (C) 2001-2012, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This version of System.Machine_State_Operations is for use on
-- Alpha systems running VMS.
with System.Memory;
with System.Aux_DEC; use System.Aux_DEC;
with Ada.Unchecked_Conversion;
package body System.Machine_State_Operations is
subtype Cond_Value_Type is Unsigned_Longword;
-- Record layouts copied from Starlet
type ICB_Fflags_Bits_Type is record
Exception_Frame : Boolean;
Ast_Frame : Boolean;
Bottom_Of_Stack : Boolean;
Base_Frame : Boolean;
Filler_1 : Unsigned_20;
end record;
for ICB_Fflags_Bits_Type use record
Exception_Frame at 0 range 0 .. 0;
Ast_Frame at 0 range 1 .. 1;
Bottom_Of_Stack at 0 range 2 .. 2;
Base_Frame at 0 range 3 .. 3;
Filler_1 at 0 range 4 .. 23;
end record;
for ICB_Fflags_Bits_Type'Size use 24;
type ICB_Hdr_Quad_Type is record
Context_Length : Unsigned_Longword;
Fflags_Bits : ICB_Fflags_Bits_Type;
Block_Version : Unsigned_Byte;
end record;
for ICB_Hdr_Quad_Type use record
Context_Length at 0 range 0 .. 31;
Fflags_Bits at 4 range 0 .. 23;
Block_Version at 7 range 0 .. 7;
end record;
for ICB_Hdr_Quad_Type'Size use 64;
type Invo_Context_Blk_Type is record
Hdr_Quad : ICB_Hdr_Quad_Type;
-- The first quadword contains:
-- o The length of the structure in bytes (a longword field)
-- o The frame flags (a 3 byte field of bits)
-- o The version number (a 1 byte field)
Procedure_Descriptor : Unsigned_Quadword;
-- The address of the procedure descriptor for the procedure
Program_Counter : Integer_64;
-- The current PC of a given procedure invocation
Processor_Status : Integer_64;
-- The current PS of a given procedure invocation
Ireg : Unsigned_Quadword_Array (0 .. 30);
Freg : Unsigned_Quadword_Array (0 .. 30);
-- The register contents areas. 31 for scalars, 31 for float
System_Defined : Unsigned_Quadword_Array (0 .. 1);
-- The following is an "internal" area that's reserved for use by
-- the operating system. It's size may vary over time.
-- Chfctx_Addr : Unsigned_Quadword;
-- Defined as a comment since it overlaps other fields
Filler_1 : String (1 .. 0);
-- Align to octaword
end record;
for Invo_Context_Blk_Type use record
Hdr_Quad at 0 range 0 .. 63;
Procedure_Descriptor at 8 range 0 .. 63;
Program_Counter at 16 range 0 .. 63;
Processor_Status at 24 range 0 .. 63;
Ireg at 32 range 0 .. 1983;
Freg at 280 range 0 .. 1983;
System_Defined at 528 range 0 .. 127;
-- Component representation spec(s) below are defined as
-- comments since they overlap other fields
-- Chfctx_Addr at 528 range 0 .. 63;
Filler_1 at 544 range 0 .. -1;
end record;
for Invo_Context_Blk_Type'Size use 4352;
subtype Invo_Handle_Type is Unsigned_Longword;
type Invo_Handle_Access_Type is access all Invo_Handle_Type;
function Fetch is new Fetch_From_Address (Code_Loc);
function To_Invo_Handle_Access is new Ada.Unchecked_Conversion
(Machine_State, Invo_Handle_Access_Type);
function To_Machine_State is new Ada.Unchecked_Conversion
(System.Address, Machine_State);
----------------------------
-- Allocate_Machine_State --
----------------------------
function Allocate_Machine_State return Machine_State is
begin
return To_Machine_State
(Memory.Alloc (Invo_Handle_Type'Max_Size_In_Storage_Elements));
end Allocate_Machine_State;
----------------
-- Fetch_Code --
----------------
function Fetch_Code (Loc : Code_Loc) return Code_Loc is
begin
-- The starting address is in the second longword pointed to by Loc
return Fetch (System.Aux_DEC."+" (Loc, 8));
end Fetch_Code;
------------------------
-- Free_Machine_State --
------------------------
procedure Free_Machine_State (M : in out Machine_State) is
begin
Memory.Free (Address (M));
M := Machine_State (Null_Address);
end Free_Machine_State;
------------------
-- Get_Code_Loc --
------------------
function Get_Code_Loc (M : Machine_State) return Code_Loc is
procedure Get_Invo_Context (
Result : out Unsigned_Longword; -- return value
Invo_Handle : Invo_Handle_Type;
Invo_Context : out Invo_Context_Blk_Type);
pragma Import (External, Get_Invo_Context);
pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT",
(Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type),
(Value, Value, Reference));
Asm_Call_Size : constant := 4;
-- Under VMS a call
-- asm instruction takes 4 bytes. So we must remove this amount.
ICB : Invo_Context_Blk_Type;
Status : Cond_Value_Type;
begin
Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB);
if (Status and 1) /= 1 then
return Code_Loc (System.Null_Address);
end if;
return Code_Loc (ICB.Program_Counter - Asm_Call_Size);
end Get_Code_Loc;
--------------------------
-- Machine_State_Length --
--------------------------
function Machine_State_Length
return System.Storage_Elements.Storage_Offset
is
use System.Storage_Elements;
begin
return Invo_Handle_Type'Size / 8;
end Machine_State_Length;
---------------
-- Pop_Frame --
---------------
procedure Pop_Frame (M : Machine_State) is
procedure Get_Prev_Invo_Handle (
Result : out Invo_Handle_Type; -- return value
ICB : Invo_Handle_Type);
pragma Import (External, Get_Prev_Invo_Handle);
pragma Import_Valued_Procedure
(Get_Prev_Invo_Handle, "LIB$GET_PREV_INVO_HANDLE",
(Invo_Handle_Type, Invo_Handle_Type),
(Value, Value));
Prev_Handle : aliased Invo_Handle_Type;
begin
Get_Prev_Invo_Handle (Prev_Handle, To_Invo_Handle_Access (M).all);
To_Invo_Handle_Access (M).all := Prev_Handle;
end Pop_Frame;
-----------------------
-- Set_Machine_State --
-----------------------
procedure Set_Machine_State (M : Machine_State) is
procedure Get_Curr_Invo_Context
(Invo_Context : out Invo_Context_Blk_Type);
pragma Import (External, Get_Curr_Invo_Context);
pragma Import_Valued_Procedure
(Get_Curr_Invo_Context, "LIB$GET_CURR_INVO_CONTEXT",
(Invo_Context_Blk_Type),
(Reference));
procedure Get_Invo_Handle (
Result : out Invo_Handle_Type; -- return value
Invo_Context : Invo_Context_Blk_Type);
pragma Import (External, Get_Invo_Handle);
pragma Import_Valued_Procedure (Get_Invo_Handle, "LIB$GET_INVO_HANDLE",
(Invo_Handle_Type, Invo_Context_Blk_Type),
(Value, Reference));
ICB : Invo_Context_Blk_Type;
Invo_Handle : aliased Invo_Handle_Type;
begin
Get_Curr_Invo_Context (ICB);
Get_Invo_Handle (Invo_Handle, ICB);
To_Invo_Handle_Access (M).all := Invo_Handle;
Pop_Frame (M, System.Null_Address);
end Set_Machine_State;
end System.Machine_State_Operations;

230
gcc/ada/s-memory-vms_64.adb
View File

@ -1,230 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . M E M O R Y --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the VMS 64 bit implementation of this package
-- This implementation assumes that the underlying malloc/free/realloc
-- implementation is thread safe, and thus, no additional lock is required.
-- Note that we still need to defer abort because on most systems, an
-- asynchronous signal (as used for implementing asynchronous abort of
-- task) cannot safely be handled while malloc is executing.
-- If you are not using Ada constructs containing the "abort" keyword, then
-- you can remove the calls to Abort_Defer.all and Abort_Undefer.all from
-- this unit.
pragma Compiler_Unit_Warning;
with Ada.Exceptions;
with System.Soft_Links;
with System.Parameters;
with System.CRTL;
package body System.Memory is
use Ada.Exceptions;
use System.Soft_Links;
function c_malloc (Size : System.CRTL.size_t) return System.Address
renames System.CRTL.malloc;
procedure c_free (Ptr : System.Address)
renames System.CRTL.free;
function c_realloc
(Ptr : System.Address; Size : System.CRTL.size_t) return System.Address
renames System.CRTL.realloc;
Gnat_Heap_Size : Integer;
pragma Import (C, Gnat_Heap_Size, "__gl_heap_size");
-- Set by Feature logical GNAT$NO_MALLOC_64 and/or Binder switch -Hnn
-----------
-- Alloc --
-----------
function Alloc (Size : size_t) return System.Address is
Result : System.Address;
Actual_Size : size_t := Size;
begin
if Gnat_Heap_Size = 32 then
return Alloc32 (Size);
end if;
if Size = size_t'Last then
Raise_Exception (Storage_Error'Identity, "object too large");
end if;
-- Change size from zero to non-zero. We still want a proper pointer
-- for the zero case because pointers to zero length objects have to
-- be distinct, but we can't just go ahead and allocate zero bytes,
-- since some malloc's return zero for a zero argument.
if Size = 0 then
Actual_Size := 1;
end if;
if Parameters.No_Abort then
Result := c_malloc (System.CRTL.size_t (Actual_Size));
else
Abort_Defer.all;
Result := c_malloc (System.CRTL.size_t (Actual_Size));
Abort_Undefer.all;
end if;
if Result = System.Null_Address then
Raise_Exception (Storage_Error'Identity, "heap exhausted");
end if;
return Result;
end Alloc;
-------------
-- Alloc32 --
-------------
function Alloc32 (Size : size_t) return System.Address is
Result : System.Address;
Actual_Size : size_t := Size;
begin
if Size = size_t'Last then
Raise_Exception (Storage_Error'Identity, "object too large");
end if;
-- Change size from zero to non-zero. We still want a proper pointer
-- for the zero case because pointers to zero length objects have to
-- be distinct, but we can't just go ahead and allocate zero bytes,
-- since some malloc's return zero for a zero argument.
if Size = 0 then
Actual_Size := 1;
end if;
if Parameters.No_Abort then
Result := C_malloc32 (Actual_Size);
else
Abort_Defer.all;
Result := C_malloc32 (Actual_Size);
Abort_Undefer.all;
end if;
if Result = System.Null_Address then
Raise_Exception (Storage_Error'Identity, "heap exhausted");
end if;
return Result;
end Alloc32;
----------
-- Free --
----------
procedure Free (Ptr : System.Address) is
begin
if Parameters.No_Abort then
c_free (Ptr);
else
Abort_Defer.all;
c_free (Ptr);
Abort_Undefer.all;
end if;
end Free;
-------------
-- Realloc --
-------------
function Realloc
(Ptr : System.Address;
Size : size_t)
return System.Address
is
Result : System.Address;
Actual_Size : constant size_t := Size;
begin
if Gnat_Heap_Size = 32 then
return Realloc32 (Ptr, Size);
end if;
if Size = size_t'Last then
Raise_Exception (Storage_Error'Identity, "object too large");
end if;
if Parameters.No_Abort then
Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size));
else
Abort_Defer.all;
Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size));
Abort_Undefer.all;
end if;
if Result = System.Null_Address then
Raise_Exception (Storage_Error'Identity, "heap exhausted");
end if;
return Result;
end Realloc;
---------------
-- Realloc32 --
---------------
function Realloc32
(Ptr : System.Address;
Size : size_t)
return System.Address
is
Result : System.Address;
Actual_Size : constant size_t := Size;
begin
if Size = size_t'Last then
Raise_Exception (Storage_Error'Identity, "object too large");
end if;
if Parameters.No_Abort then
Result := C_realloc32 (Ptr, Actual_Size);
else
Abort_Defer.all;
Result := C_realloc32 (Ptr, Actual_Size);
Abort_Undefer.all;
end if;
if Result = System.Null_Address then
Raise_Exception (Storage_Error'Identity, "heap exhausted");
end if;
return Result;
end Realloc32;
end System.Memory;

129
gcc/ada/s-memory-vms_64.ads
View File

@ -1,129 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . M E M O R Y --
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides the low level memory allocation/deallocation
-- mechanisms used by GNAT for VMS 64 bit.
-- To provide an alternate implementation, simply recompile the modified
-- body of this package with gnatmake -u -a -g s-memory.adb and make sure
-- that the ali and object files for this unit are found in the object
-- search path.
-- This unit may be used directly from an application program by providing
-- an appropriate WITH, and the interface can be expected to remain stable.
pragma Compiler_Unit_Warning;
package System.Memory is
pragma Elaborate_Body;
type size_t is mod 2 ** Standard'Address_Size;
-- Note: the reason we redefine this here instead of using the
-- definition in Interfaces.C is that we do not want to drag in
-- all of Interfaces.C just because System.Memory is used.
function Alloc (Size : size_t) return System.Address;
-- This is the low level allocation routine. Given a size in storage
-- units, it returns the address of a maximally aligned block of
-- memory. The implementation of this routine is guaranteed to be
-- task safe, and also aborts are deferred if necessary.
--
-- If size_t is set to size_t'Last on entry, then a Storage_Error
-- exception is raised with a message "object too large".
--
-- If size_t is set to zero on entry, then a minimal (but non-zero)
-- size block is allocated.
--
-- Note: this is roughly equivalent to the standard C malloc call
-- with the additional semantics as described above.
function Alloc32 (Size : size_t) return System.Address;
-- Equivalent to Alloc except on VMS 64 bit where it invokes
-- 32 bit malloc.
procedure Free (Ptr : System.Address);
-- This is the low level free routine. It frees a block previously
-- allocated with a call to Alloc. As in the case of Alloc, this
-- call is guaranteed task safe, and aborts are deferred.
--
-- Note: this is roughly equivalent to the standard C free call
-- with the additional semantics as described above.
function Realloc
(Ptr : System.Address;
Size : size_t) return System.Address;
-- This is the low level reallocation routine. It takes an existing
-- block address returned by a previous call to Alloc or Realloc,
-- and reallocates the block. The size can either be increased or
-- decreased. If possible the reallocation is done in place, so that
-- the returned result is the same as the value of Ptr on entry.
-- However, it may be necessary to relocate the block to another
-- address, in which case the information is copied to the new
-- block, and the old block is freed. The implementation of this
-- routine is guaranteed to be task safe, and also aborts are
-- deferred as necessary.
--
-- If size_t is set to size_t'Last on entry, then a Storage_Error
-- exception is raised with a message "object too large".
--
-- If size_t is set to zero on entry, then a minimal (but non-zero)
-- size block is allocated.
--
-- Note: this is roughly equivalent to the standard C realloc call
-- with the additional semantics as described above.
function Realloc32
(Ptr : System.Address;
Size : size_t) return System.Address;
-- Equivalent to Realloc except on VMS 64 bit where it invokes
-- 32 bit realloc.
private
-- The following names are used from the generated compiler code
pragma Export (C, Alloc, "__gnat_malloc");
pragma Export (C, Alloc32, "__gnat_malloc32");
pragma Export (C, Free, "__gnat_free");
pragma Export (C, Realloc, "__gnat_realloc");
pragma Export (C, Realloc32, "__gnat_realloc32");
function C_malloc32 (Size : size_t) return System.Address;
pragma Import (C, C_malloc32, "_malloc32");
-- An alias for malloc for allocating 32bit memory on 64bit VMS
function C_realloc32
(Ptr : System.Address;
Size : size_t) return System.Address;
pragma Import (C, C_realloc32, "_realloc32");
-- An alias for realloc for allocating 32bit memory on 64bit VMS
end System.Memory;

59
gcc/ada/s-osinte-vms.adb
View File

@ -1,59 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . O S _ I N T E R F A C E --
-- --
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2012, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is the OpenVMS version of this package
-- This package encapsulates all direct interfaces to OS services
-- that are needed by children of System.
pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during
-- tasking operations. It causes infinite loops and other problems.
with Interfaces.C; use Interfaces.C;
package body System.OS_Interface is
-----------------
-- sched_yield --
-----------------
function sched_yield return int is
procedure sched_yield_base;
pragma Import (C, sched_yield_base, "PTHREAD_YIELD_NP");
begin
sched_yield_base;
return 0;
end sched_yield;
end System.OS_Interface;

660
gcc/ada/s-osinte-vms.ads
View File

@ -1,660 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . O S _ I N T E R F A C E --
-- --
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is the OpenVMS version of this package
-- This package encapsulates all direct interfaces to OS services
-- that are needed by the tasking run-time (libgnarl).
-- PLEASE DO NOT add any with-clauses to this package or remove the pragma
-- Preelaborate. This package is designed to be a bottom-level (leaf) package.
with Interfaces.C;
with Ada.Unchecked_Conversion;
with System.Aux_DEC;
package System.OS_Interface is
pragma Preelaborate;
-- pragma Linker_Options ("--for-linker=/threads_enable");
-- Enable upcalls and multiple kernel threads.
subtype int is Interfaces.C.int;
subtype short is Interfaces.C.short;
subtype long is Interfaces.C.long;
subtype unsigned is Interfaces.C.unsigned;
subtype unsigned_short is Interfaces.C.unsigned_short;
subtype unsigned_long is Interfaces.C.unsigned_long;
subtype unsigned_char is Interfaces.C.unsigned_char;
subtype plain_char is Interfaces.C.plain_char;
subtype size_t is Interfaces.C.size_t;
-----------------------------
-- Signals (Interrupt IDs) --
-----------------------------
-- Type signal has an arbitrary limit of 31
Max_Interrupt : constant := 31;
type Signal is new unsigned range 0 .. Max_Interrupt;
for Signal'Size use unsigned'Size;
type sigset_t is array (Signal) of Boolean;
pragma Pack (sigset_t);
-- Interrupt_Number_Type
-- Unsigned long integer denoting the number of an interrupt
subtype Interrupt_Number_Type is unsigned_long;
-- OpenVMS system services return values of type Cond_Value_Type
subtype Cond_Value_Type is unsigned_long;
subtype Short_Cond_Value_Type is unsigned_short;
type IO_Status_Block_Type is record
Status : Short_Cond_Value_Type;
Count : unsigned_short;
Dev_Info : unsigned_long;
end record;
type AST_Handler is access procedure (Param : Address);
pragma Convention (C, AST_Handler);
No_AST_Handler : constant AST_Handler := null;
CMB_M_READONLY : constant := 16#00000001#;
CMB_M_WRITEONLY : constant := 16#00000002#;
AGN_M_READONLY : constant := 16#00000001#;
AGN_M_WRITEONLY : constant := 16#00000002#;
IO_WRITEVBLK : constant := 48; -- WRITE VIRTUAL BLOCK
IO_READVBLK : constant := 49; -- READ VIRTUAL BLOCK
----------------
-- Sys_Assign --
----------------
--
-- Assign I/O Channel
--
-- Status = returned status
-- Devnam = address of device name or logical name string
-- descriptor
-- Chan = address of word to receive channel number assigned
-- Acmode = access mode associated with channel
-- Mbxnam = address of mailbox logical name string descriptor, if
-- mailbox associated with device
-- Flags = optional channel flags longword for specifying options
-- for the $ASSIGN operation
--
procedure Sys_Assign
(Status : out Cond_Value_Type;
Devnam : String;
Chan : out unsigned_short;
Acmode : unsigned_short := 0;
Mbxnam : String := String'Null_Parameter;
Flags : unsigned_long := 0);
pragma Import (External, Sys_Assign);
pragma Import_Valued_Procedure
(Sys_Assign, "SYS$ASSIGN",
(Cond_Value_Type, String, unsigned_short,
unsigned_short, String, unsigned_long),
(Value, Descriptor (s), Reference,
Value, Descriptor (s), Value),
Flags);
----------------
-- Sys_Cantim --
----------------
--
-- Cancel Timer
--
-- Status = returned status
-- Reqidt = ID of timer to be cancelled
-- Acmode = Access mode
--
procedure Sys_Cantim
(Status : out Cond_Value_Type;
Reqidt : Address;
Acmode : unsigned);
pragma Import (External, Sys_Cantim);
pragma Import_Valued_Procedure
(Sys_Cantim, "SYS$CANTIM",
(Cond_Value_Type, Address, unsigned),
(Value, Value, Value));
----------------
-- Sys_Crembx --
----------------
--
-- Create mailbox
--
-- Status = returned status
-- Prmflg = permanent flag
-- Chan = channel
-- Maxmsg = maximum message
-- Bufquo = buufer quote
-- Promsk = protection mast
-- Acmode = access mode
-- Lognam = logical name
-- Flags = flags
--
procedure Sys_Crembx
(Status : out Cond_Value_Type;
Prmflg : unsigned_char;
Chan : out unsigned_short;
Maxmsg : unsigned_long := 0;
Bufquo : unsigned_long := 0;
Promsk : unsigned_short := 0;
Acmode : unsigned_short := 0;
Lognam : String;
Flags : unsigned_long := 0);
pragma Import (External, Sys_Crembx);
pragma Import_Valued_Procedure
(Sys_Crembx, "SYS$CREMBX",
(Cond_Value_Type, unsigned_char, unsigned_short,
unsigned_long, unsigned_long, unsigned_short,
unsigned_short, String, unsigned_long),
(Value, Value, Reference,
Value, Value, Value,
Value, Descriptor (s), Value));
-------------
-- Sys_QIO --
-------------
--
-- Queue I/O
--
-- Status = Returned status of call
-- EFN = event flag to be set when I/O completes
-- Chan = channel
-- Func = function
-- Iosb = I/O status block
-- Astadr = system trap to be generated when I/O completes
-- Astprm = AST parameter
-- P1-6 = optional parameters
procedure Sys_QIO
(Status : out Cond_Value_Type;
EFN : unsigned_long := 0;
Chan : unsigned_short;
Func : unsigned_long := 0;
Iosb : out IO_Status_Block_Type;
Astadr : AST_Handler := No_AST_Handler;
Astprm : Address := Null_Address;
P1 : unsigned_long := 0;
P2 : unsigned_long := 0;
P3 : unsigned_long := 0;
P4 : unsigned_long := 0;
P5 : unsigned_long := 0;
P6 : unsigned_long := 0);
procedure Sys_QIO
(Status : out Cond_Value_Type;
EFN : unsigned_long := 0;
Chan : unsigned_short;
Func : unsigned_long := 0;
Iosb : Address := Null_Address;
Astadr : AST_Handler := No_AST_Handler;
Astprm : Address := Null_Address;
P1 : unsigned_long := 0;
P2 : unsigned_long := 0;
P3 : unsigned_long := 0;
P4 : unsigned_long := 0;
P5 : unsigned_long := 0;
P6 : unsigned_long := 0);
pragma Import (External, Sys_QIO);
pragma Import_Valued_Procedure
(Sys_QIO, "SYS$QIO",
(Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long,
IO_Status_Block_Type, AST_Handler, Address,
unsigned_long, unsigned_long, unsigned_long,
unsigned_long, unsigned_long, unsigned_long),
(Value, Value, Value, Value,
Reference, Value, Value,
Value, Value, Value,
Value, Value, Value));
pragma Import_Valued_Procedure
(Sys_QIO, "SYS$QIO",
(Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long,
Address, AST_Handler, Address,
unsigned_long, unsigned_long, unsigned_long,
unsigned_long, unsigned_long, unsigned_long),
(Value, Value, Value, Value,
Value, Value, Value,
Value, Value, Value,
Value, Value, Value));
----------------
-- Sys_Setimr --
----------------
--
-- Set Timer
--
-- Status = Returned status of call
-- EFN = event flag to be set when timer expires
-- Tim = expiration time
-- AST = system trap to be generated when timer expires
-- Redidt = returned ID of timer (e.g. to cancel timer)
-- Flags = flags
--
procedure Sys_Setimr
(Status : out Cond_Value_Type;
EFN : unsigned_long;
Tim : Long_Integer;
AST : AST_Handler;
Reqidt : Address;
Flags : unsigned_long);
pragma Import (External, Sys_Setimr);
pragma Import_Valued_Procedure
(Sys_Setimr, "SYS$SETIMR",
(Cond_Value_Type, unsigned_long, Long_Integer,
AST_Handler, Address, unsigned_long),
(Value, Value, Reference,
Value, Value, Value));
Interrupt_ID_0 : constant := 0;
Interrupt_ID_1 : constant := 1;
Interrupt_ID_2 : constant := 2;
Interrupt_ID_3 : constant := 3;
Interrupt_ID_4 : constant := 4;
Interrupt_ID_5 : constant := 5;
Interrupt_ID_6 : constant := 6;
Interrupt_ID_7 : constant := 7;
Interrupt_ID_8 : constant := 8;
Interrupt_ID_9 : constant := 9;
Interrupt_ID_10 : constant := 10;
Interrupt_ID_11 : constant := 11;
Interrupt_ID_12 : constant := 12;
Interrupt_ID_13 : constant := 13;
Interrupt_ID_14 : constant := 14;
Interrupt_ID_15 : constant := 15;
Interrupt_ID_16 : constant := 16;
Interrupt_ID_17 : constant := 17;
Interrupt_ID_18 : constant := 18;
Interrupt_ID_19 : constant := 19;
Interrupt_ID_20 : constant := 20;
Interrupt_ID_21 : constant := 21;
Interrupt_ID_22 : constant := 22;
Interrupt_ID_23 : constant := 23;
Interrupt_ID_24 : constant := 24;
Interrupt_ID_25 : constant := 25;
Interrupt_ID_26 : constant := 26;
Interrupt_ID_27 : constant := 27;
Interrupt_ID_28 : constant := 28;
Interrupt_ID_29 : constant := 29;
Interrupt_ID_30 : constant := 30;
Interrupt_ID_31 : constant := 31;
-----------
-- Errno --
-----------
function errno return int;
pragma Import (C, errno, "__get_errno");
EINTR : constant := 4; -- Interrupted system call
EAGAIN : constant := 11; -- No more processes
ENOMEM : constant := 12; -- Not enough core
-------------------------
-- Priority Scheduling --
-------------------------
SCHED_FIFO : constant := 1;
SCHED_RR : constant := 2;
SCHED_OTHER : constant := 3;
SCHED_BG : constant := 4;
SCHED_LFI : constant := 5;
SCHED_LRR : constant := 6;
-------------
-- Process --
-------------
type pid_t is private;
function kill (pid : pid_t; sig : Signal) return int;
pragma Import (C, kill);
function getpid return pid_t;
pragma Import (C, getpid);
-------------
-- Threads --
-------------
type Thread_Body is access
function (arg : System.Address) return System.Address;
pragma Convention (C, Thread_Body);
function Thread_Body_Access is new
Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, Thread_Body);
type pthread_t is private;
subtype Thread_Id is pthread_t;
type pthread_mutex_t is limited private;
type pthread_cond_t is limited private;
type pthread_attr_t is limited private;
type pthread_mutexattr_t is limited private;
type pthread_condattr_t is limited private;
type pthread_key_t is private;
PTHREAD_CREATE_JOINABLE : constant := 0;
PTHREAD_CREATE_DETACHED : constant := 1;
PTHREAD_CANCEL_DISABLE : constant := 0;
PTHREAD_CANCEL_ENABLE : constant := 1;
PTHREAD_CANCEL_DEFERRED : constant := 0;
PTHREAD_CANCEL_ASYNCHRONOUS : constant := 1;
-- Don't use ERRORCHECK mutexes, they don't work when a thread is not
-- the owner. AST's, at least, unlock others threads mutexes. Even
-- if the error is ignored, they don't work.
PTHREAD_MUTEX_NORMAL_NP : constant := 0;
PTHREAD_MUTEX_RECURSIVE_NP : constant := 1;
PTHREAD_MUTEX_ERRORCHECK_NP : constant := 2;
PTHREAD_INHERIT_SCHED : constant := 0;
PTHREAD_EXPLICIT_SCHED : constant := 1;
function pthread_cancel (thread : pthread_t) return int;
pragma Import (C, pthread_cancel, "PTHREAD_CANCEL");
procedure pthread_testcancel;
pragma Import (C, pthread_testcancel, "PTHREAD_TESTCANCEL");
function pthread_setcancelstate
(newstate : int; oldstate : access int) return int;
pragma Import (C, pthread_setcancelstate, "PTHREAD_SETCANCELSTATE");
function pthread_setcanceltype
(newtype : int; oldtype : access int) return int;
pragma Import (C, pthread_setcanceltype, "PTHREAD_SETCANCELTYPE");
-------------------------
-- POSIX.1c Section 3 --
-------------------------
function pthread_lock_global_np return int;
pragma Import (C, pthread_lock_global_np, "PTHREAD_LOCK_GLOBAL_NP");
function pthread_unlock_global_np return int;
pragma Import (C, pthread_unlock_global_np, "PTHREAD_UNLOCK_GLOBAL_NP");
--------------------------
-- POSIX.1c Section 11 --
--------------------------
function pthread_mutexattr_init
(attr : access pthread_mutexattr_t) return int;
pragma Import (C, pthread_mutexattr_init, "PTHREAD_MUTEXATTR_INIT");
function pthread_mutexattr_destroy
(attr : access pthread_mutexattr_t) return int;
pragma Import (C, pthread_mutexattr_destroy, "PTHREAD_MUTEXATTR_DESTROY");
function pthread_mutexattr_settype_np
(attr : access pthread_mutexattr_t;
mutextype : int) return int;
pragma Import (C, pthread_mutexattr_settype_np,
"PTHREAD_MUTEXATTR_SETTYPE_NP");
function pthread_mutex_init
(mutex : access pthread_mutex_t;
attr : access pthread_mutexattr_t) return int;
pragma Import (C, pthread_mutex_init, "PTHREAD_MUTEX_INIT");
function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_mutex_destroy, "PTHREAD_MUTEX_DESTROY");
function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_mutex_lock, "PTHREAD_MUTEX_LOCK");
function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_mutex_unlock, "PTHREAD_MUTEX_UNLOCK");
function pthread_mutex_setname_np
(attr : access pthread_mutex_t;
name : System.Address;
mbz : System.Address) return int;
pragma Import (C, pthread_mutex_setname_np, "PTHREAD_MUTEX_SETNAME_NP");
function pthread_condattr_init
(attr : access pthread_condattr_t) return int;
pragma Import (C, pthread_condattr_init, "PTHREAD_CONDATTR_INIT");
function pthread_condattr_destroy
(attr : access pthread_condattr_t) return int;
pragma Import (C, pthread_condattr_destroy, "PTHREAD_CONDATTR_DESTROY");
function pthread_cond_init
(cond : access pthread_cond_t;
attr : access pthread_condattr_t) return int;
pragma Import (C, pthread_cond_init, "PTHREAD_COND_INIT");
function pthread_cond_destroy (cond : access pthread_cond_t) return int;
pragma Import (C, pthread_cond_destroy, "PTHREAD_COND_DESTROY");
function pthread_cond_signal (cond : access pthread_cond_t) return int;
pragma Import (C, pthread_cond_signal, "PTHREAD_COND_SIGNAL");
function pthread_cond_signal_int_np
(cond : access pthread_cond_t) return int;
pragma Import (C, pthread_cond_signal_int_np,
"PTHREAD_COND_SIGNAL_INT_NP");
function pthread_cond_wait
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_cond_wait, "PTHREAD_COND_WAIT");
--------------------------
-- POSIX.1c Section 13 --
--------------------------
function pthread_mutexattr_setprotocol
(attr : access pthread_mutexattr_t; protocol : int) return int;
pragma Import (C, pthread_mutexattr_setprotocol,
"PTHREAD_MUTEXATTR_SETPROTOCOL");
type struct_sched_param is record
sched_priority : int; -- scheduling priority
end record;
for struct_sched_param'Size use 8 * 4;
pragma Convention (C, struct_sched_param);
function pthread_setschedparam
(thread : pthread_t;
policy : int;
param : access struct_sched_param) return int;
pragma Import (C, pthread_setschedparam, "PTHREAD_SETSCHEDPARAM");
function pthread_attr_setscope
(attr : access pthread_attr_t;
contentionscope : int) return int;
pragma Import (C, pthread_attr_setscope, "PTHREAD_ATTR_SETSCOPE");
function pthread_attr_setinheritsched
(attr : access pthread_attr_t;
inheritsched : int) return int;
pragma Import (C, pthread_attr_setinheritsched,
"PTHREAD_ATTR_SETINHERITSCHED");
function pthread_attr_setschedpolicy
(attr : access pthread_attr_t; policy : int) return int;
pragma Import (C, pthread_attr_setschedpolicy,
"PTHREAD_ATTR_SETSCHEDPOLICY");
function pthread_attr_setschedparam
(attr : access pthread_attr_t;
sched_param : int) return int;
pragma Import (C, pthread_attr_setschedparam, "PTHREAD_ATTR_SETSCHEDPARAM");
function pthread_attr_setname_np
(attr : access pthread_attr_t;
name : System.Address;
mbz : System.Address) return int;
pragma Import (C, pthread_attr_setname_np, "PTHREAD_ATTR_SETNAME_NP");
function sched_yield return int;
--------------------------
-- P1003.1c Section 16 --
--------------------------
function pthread_attr_init (attributes : access pthread_attr_t) return int;
pragma Import (C, pthread_attr_init, "PTHREAD_ATTR_INIT");
function pthread_attr_destroy
(attributes : access pthread_attr_t) return int;
pragma Import (C, pthread_attr_destroy, "PTHREAD_ATTR_DESTROY");
function pthread_attr_setdetachstate
(attr : access pthread_attr_t;
detachstate : int) return int;
pragma Import (C, pthread_attr_setdetachstate,
"PTHREAD_ATTR_SETDETACHSTATE");
function pthread_attr_setstacksize
(attr : access pthread_attr_t;
stacksize : size_t) return int;
pragma Import (C, pthread_attr_setstacksize, "PTHREAD_ATTR_SETSTACKSIZE");
function pthread_create
(thread : access pthread_t;
attributes : access pthread_attr_t;
start_routine : Thread_Body;
arg : System.Address) return int;
pragma Import (C, pthread_create, "PTHREAD_CREATE");
procedure pthread_exit (status : System.Address);
pragma Import (C, pthread_exit, "PTHREAD_EXIT");
function pthread_self return pthread_t;
pragma Import (C, pthread_self, "PTHREAD_SELF");
--------------------------
-- POSIX.1c Section 17 --
--------------------------
function pthread_setspecific
(key : pthread_key_t;
value : System.Address) return int;
pragma Import (C, pthread_setspecific, "PTHREAD_SETSPECIFIC");
function pthread_getspecific (key : pthread_key_t) return System.Address;
pragma Import (C, pthread_getspecific, "PTHREAD_GETSPECIFIC");
type destructor_pointer is access procedure (arg : System.Address);
pragma Convention (C, destructor_pointer);
function pthread_key_create
(key : access pthread_key_t;
destructor : destructor_pointer) return int;
pragma Import (C, pthread_key_create, "PTHREAD_KEY_CREATE");
private
type pid_t is new int;
type pthreadLongAddr_p is mod 2 ** Long_Integer'Size;
type pthreadLongAddr_t is mod 2 ** Long_Integer'Size;
type pthreadLongAddr_t_ptr is mod 2 ** Long_Integer'Size;
type pthreadLongString_t is mod 2 ** Long_Integer'Size;
type pthreadLongUint_t is mod 2 ** Long_Integer'Size;
type pthreadLongUint_array is array (Natural range <>)
of pthreadLongUint_t;
type pthread_t is mod 2 ** Long_Integer'Size;
type pthread_cond_t is record
state : unsigned;
valid : unsigned;
name : pthreadLongString_t;
arg : unsigned;
sequence : unsigned;
block : pthreadLongAddr_t_ptr;
end record;
for pthread_cond_t'Size use 8 * 32;
pragma Convention (C, pthread_cond_t);
type pthread_attr_t is record
valid : long;
name : pthreadLongString_t;
arg : pthreadLongUint_t;
reserved : pthreadLongUint_array (0 .. 18);
end record;
for pthread_attr_t'Size use 8 * 176;
pragma Convention (C, pthread_attr_t);
type pthread_mutex_t is record
lock : unsigned;
valid : unsigned;
name : pthreadLongString_t;
arg : unsigned;
sequence : unsigned;
block : pthreadLongAddr_p;
owner : unsigned;
depth : unsigned;
end record;
for pthread_mutex_t'Size use 8 * 40;
pragma Convention (C, pthread_mutex_t);
type pthread_mutexattr_t is record
valid : long;
reserved : pthreadLongUint_array (0 .. 14);
end record;
for pthread_mutexattr_t'Size use 8 * 128;
pragma Convention (C, pthread_mutexattr_t);
type pthread_condattr_t is record
valid : long;
reserved : pthreadLongUint_array (0 .. 12);
end record;
for pthread_condattr_t'Size use 8 * 112;
pragma Convention (C, pthread_condattr_t);
type pthread_key_t is new unsigned;
pragma Inline (pthread_self);
end System.OS_Interface;

209
gcc/ada/s-osprim-vms.adb
View File

@ -1,209 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . O S _ P R I M I T I V E S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2012, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is the OpenVMS/Alpha version of this file
with System.Aux_DEC;
package body System.OS_Primitives is
--------------------------------------
-- Local functions and declarations --
--------------------------------------
function Get_GMToff return Integer;
pragma Import (C, Get_GMToff, "get_gmtoff");
-- Get the offset from GMT for this timezone
function VMS_Epoch_Offset return Long_Integer;
pragma Inline (VMS_Epoch_Offset);
-- The offset between the Unix Epoch and the VMS Epoch
subtype Cond_Value_Type is System.Aux_DEC.Unsigned_Longword;
-- Condition Value return type
----------------------
-- VMS_Epoch_Offset --
----------------------
function VMS_Epoch_Offset return Long_Integer is
begin
return 10_000_000 * (3_506_716_800 + Long_Integer (Get_GMToff));
end VMS_Epoch_Offset;
----------------
-- Sys_Schdwk --
----------------
--
-- Schedule Wakeup
--
-- status = returned status
-- pidadr = address of process id to be woken up
-- prcnam = name of process to be woken up
-- daytim = time to wake up
-- reptim = repetition interval of wakeup calls
--
procedure Sys_Schdwk
(
Status : out Cond_Value_Type;
Pidadr : Address := Null_Address;
Prcnam : String := String'Null_Parameter;
Daytim : Long_Integer;
Reptim : Long_Integer := Long_Integer'Null_Parameter
);
pragma Import (External, Sys_Schdwk);
-- VMS system call to schedule a wakeup event
pragma Import_Valued_Procedure
(Sys_Schdwk, "SYS$SCHDWK",
(Cond_Value_Type, Address, String, Long_Integer, Long_Integer),
(Value, Value, Descriptor (S), Reference, Reference)
);
----------------
-- Sys_Gettim --
----------------
--
-- Get System Time
--
-- status = returned status
-- tim = current system time
--
procedure Sys_Gettim
(
Status : out Cond_Value_Type;
Tim : out OS_Time
);
-- VMS system call to get the current system time
pragma Import (External, Sys_Gettim);
pragma Import_Valued_Procedure
(Sys_Gettim, "SYS$GETTIM",
(Cond_Value_Type, OS_Time),
(Value, Reference)
);
---------------
-- Sys_Hiber --
---------------
-- Hibernate (until woken up)
-- status = returned status
procedure Sys_Hiber (Status : out Cond_Value_Type);
-- VMS system call to hibernate the current process
pragma Import (External, Sys_Hiber);
pragma Import_Valued_Procedure
(Sys_Hiber, "SYS$HIBER",
(Cond_Value_Type),
(Value)
);
-----------
-- Clock --
-----------
function OS_Clock return OS_Time is
Status : Cond_Value_Type;
T : OS_Time;
begin
Sys_Gettim (Status, T);
return (T);
end OS_Clock;
-----------
-- Clock --
-----------
function Clock return Duration is
begin
return To_Duration (OS_Clock, Absolute_Calendar);
end Clock;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
null;
end Initialize;
---------------------
-- Monotonic_Clock --
---------------------
function Monotonic_Clock return Duration renames Clock;
-----------------
-- Timed_Delay --
-----------------
procedure Timed_Delay
(Time : Duration;
Mode : Integer)
is
Sleep_Time : OS_Time;
Status : Cond_Value_Type;
pragma Unreferenced (Status);
begin
Sleep_Time := To_OS_Time (Time, Mode);
Sys_Schdwk (Status => Status, Daytim => Sleep_Time);
Sys_Hiber (Status);
end Timed_Delay;
-----------------
-- To_Duration --
-----------------
function To_Duration (T : OS_Time; Mode : Integer) return Duration is
pragma Warnings (Off, Mode);
begin
return Duration'Fixed_Value (T - VMS_Epoch_Offset) * 100;
end To_Duration;
----------------
-- To_OS_Time --
----------------
function To_OS_Time (D : Duration; Mode : Integer) return OS_Time is
begin
if Mode = Relative then
return -(Long_Integer'Integer_Value (D) / 100);
else
return Long_Integer'Integer_Value (D) / 100 + VMS_Epoch_Offset;
end if;
end To_OS_Time;
end System.OS_Primitives;

110
gcc/ada/s-osprim-vms.ads
View File

@ -1,110 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . O S _ P R I M I T I V E S --
-- --
-- S p e c --
-- --
-- Copyright (C) 1998-2009, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides low level primitives used to implement clock and
-- delays in non tasking applications on Alpha/VMS.
-- The choice of the real clock/delay implementation (depending on whether
-- tasking is involved or not) is done via soft links (see s-soflin.ads)
-- NEVER add any dependency to tasking packages here
package System.OS_Primitives is
pragma Preelaborate;
subtype OS_Time is Long_Integer;
-- System time on VMS is used for performance reasons.
-- Note that OS_Time is *not* the same as Ada.Calendar.Time, the
-- difference being that relative OS_Time is negative, but relative
-- Calendar.Time is positive.
-- See Ada.Calendar.Delays for more information on VMS Time.
Max_Sensible_Delay : constant Duration :=
Duration'Min (183 * 24 * 60 * 60.0,
Duration'Last);
-- Max of half a year delay, needed to prevent exceptions for large delay
-- values. It seems unlikely that any test will notice this restriction,
-- except in the case of applications setting the clock at run time (see
-- s-tastim.adb). Also note that a larger value might cause problems (e.g
-- overflow, or more likely OS limitation in the primitives used). In the
-- case where half a year is too long (which occurs in high integrity mode
-- with 32-bit words, and possibly on some specific ports of GNAT),
-- Duration'Last is used instead.
procedure Initialize;
-- Initialize global settings related to this package. This procedure
-- should be called before any other subprograms in this package. Note
-- that this procedure can be called several times.
function OS_Clock return OS_Time;
-- Returns "absolute" time, represented as an offset
-- relative to "the Epoch", which is Nov 17, 1858 on VMS.
function Clock return Duration;
pragma Inline (Clock);
-- Returns "absolute" time, represented as an offset relative to "the
-- Epoch", which is Jan 1, 1970 00:00:00 UTC on UNIX systems. This
-- implementation is affected by system's clock changes.
function Monotonic_Clock return Duration;
pragma Inline (Monotonic_Clock);
-- Returns "absolute" time, represented as an offset relative to "the Unix
-- Epoch", which is Jan 1, 1970 00:00:00 UTC. This clock implementation is
-- immune to the system's clock changes.
Relative : constant := 0;
Absolute_Calendar : constant := 1;
Absolute_RT : constant := 2;
-- Values for Mode call below. Note that the compiler (exp_ch9.adb) relies
-- on these values. So any change here must be reflected in corresponding
-- changes in the compiler.
procedure Timed_Delay (Time : Duration; Mode : Integer);
-- Implements the semantics of the delay statement when no tasking is used
-- in the application.
--
-- Mode is one of the three values above
--
-- Time is a relative or absolute duration value, depending on Mode.
--
-- Note that currently Ada.Real_Time always uses the tasking run time,
-- so this procedure should never be called with Mode set to Absolute_RT.
-- This may change in future or bare board implementations.
function To_Duration (T : OS_Time; Mode : Integer) return Duration;
-- Convert VMS system time to Duration
-- Mode is one of the three values above
function To_OS_Time (D : Duration; Mode : Integer) return OS_Time;
-- Convert Duration to VMS system time
-- Mode is one of the three values above
end System.OS_Primitives;

215
gcc/ada/s-parame-vms-alpha.ads
View File

@ -1,215 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . P A R A M E T E R S --
-- --
-- S p e c --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the OpenVMS Alpha version
-- This package defines some system dependent parameters for GNAT. These
-- are values that are referenced by the runtime library and are therefore
-- relevant to the target machine.
-- The parameters whose value is defined in the spec are not generally
-- expected to be changed. If they are changed, it will be necessary to
-- recompile the run-time library.
-- The parameters which are defined by functions can be changed by modifying
-- the body of System.Parameters in file s-parame.adb. A change to this body
-- requires only rebinding and relinking of the application.
-- Note: do not introduce any pragma Inline statements into this unit, since
-- otherwise the relinking and rebinding capability would be deactivated.
package System.Parameters is
pragma Pure;
---------------------------------------
-- Task And Stack Allocation Control --
---------------------------------------
type Task_Storage_Size is new Integer;
-- Type used in tasking units for task storage size
type Size_Type is new Task_Storage_Size;
-- Type used to provide task storage size to runtime
Unspecified_Size : constant Size_Type := Size_Type'First;
-- Value used to indicate that no size type is set
subtype Percentage is Size_Type range -1 .. 100;
Dynamic : constant Size_Type := -1;
-- The secondary stack ratio is a constant between 0 and 100 which
-- determines the percentage of the allocated task stack that is
-- used by the secondary stack (the rest being the primary stack).
-- The special value of minus one indicates that the secondary
-- stack is to be allocated from the heap instead.
Sec_Stack_Percentage : constant Percentage := Dynamic;
-- This constant defines the handling of the secondary stack
Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic;
-- Convenient Boolean for testing for dynamic secondary stack
function Default_Stack_Size return Size_Type;
-- Default task stack size used if none is specified
function Minimum_Stack_Size return Size_Type;
-- Minimum task stack size permitted
function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
-- Given the storage size stored in the TCB, return the Storage_Size
-- value required by the RM for the Storage_Size attribute. The
-- required adjustment is as follows:
--
-- when Size = Unspecified_Size, return Default_Stack_Size
-- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
-- otherwise return given Size
Default_Env_Stack_Size : constant Size_Type := 8_192_000;
-- Assumed size of the environment task, if no other information
-- is available. This value is used when stack checking is
-- enabled and no GNAT_STACK_LIMIT environment variable is set.
Stack_Grows_Down : constant Boolean := True;
-- This constant indicates whether the stack grows up (False) or
-- down (True) in memory as functions are called. It is used for
-- proper implementation of the stack overflow check.
----------------------------------------------
-- Characteristics of types in Interfaces.C --
----------------------------------------------
long_bits : constant := 32;
-- 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.
ptr_bits : constant := 32;
subtype C_Address is System.Address
range -2 ** (ptr_bits - 1) .. 2 ** (ptr_bits - 1) - 1;
for C_Address'Object_Size use ptr_bits;
-- 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. System.Aux_DEC.Short_Address can't be used because of
-- elaboration circularity.
C_Malloc_Linkname : constant String := "__gnat_malloc32";
-- Name of runtime function used to allocate such a pointer
----------------------------------------------
-- Behavior of Pragma Finalize_Storage_Only --
----------------------------------------------
-- Garbage_Collected is a Boolean constant whose value indicates the
-- effect of the pragma Finalize_Storage_Entry on a controlled type.
-- Garbage_Collected = False
-- The system releases all storage on program termination only,
-- but not other garbage collection occurs, so finalization calls
-- are omitted only for outer level objects can be omitted if
-- pragma Finalize_Storage_Only is used.
-- Garbage_Collected = True
-- The system provides full garbage collection, so it is never
-- necessary to release storage for controlled objects for which
-- a pragma Finalize_Storage_Only is used.
Garbage_Collected : constant Boolean := False;
-- The storage mode for this system (release on program exit)
---------------------
-- Tasking Profile --
---------------------
-- In the following sections, constant parameters are defined to
-- allow some optimizations and fine tuning within the tasking run time
-- based on restrictions on the tasking features.
----------------------
-- Locking Strategy --
----------------------
Single_Lock : constant Boolean := True;
-- Indicates whether a single lock should be used within the tasking
-- run-time to protect internal structures. If True, a single lock
-- will be used, meaning less locking/unlocking operations, but also
-- more global contention. In general, Single_Lock should be set to
-- True on single processor machines, and to False to multi-processor
-- systems, but this can vary from application to application and also
-- depends on the scheduling policy.
-------------------
-- Task Abortion --
-------------------
No_Abort : constant Boolean := False;
-- This constant indicates whether abort statements and asynchronous
-- transfer of control (ATC) are disallowed. If set to True, it is
-- assumed that neither construct is used, and the run time does not
-- need to defer/undefer abort and check for pending actions at
-- completion points. A value of True for No_Abort corresponds to:
-- pragma Restrictions (No_Abort_Statements);
-- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
---------------------
-- Task Attributes --
---------------------
Max_Attribute_Count : constant := 32;
-- Number of task attributes stored in the task control block
--------------------
-- Runtime Traces --
--------------------
Runtime_Traces : constant Boolean := False;
-- This constant indicates whether the runtime outputs traces to a
-- predefined output or not (True means that traces are output).
-- See System.Traces for more details.
-----------------------
-- Task Image Length --
-----------------------
Max_Task_Image_Length : constant := 256;
-- This constant specifies the maximum length of a task's image
------------------------------
-- Exception Message Length --
------------------------------
Default_Exception_Msg_Max_Length : constant := 512;
-- This constant specifies the maximum number of characters to allow in an
-- exception message (see RM 11.4.1(18)). The value for VMS exceeds the
-- default minimum of 200 to allow for the length of chained VMS condition
-- handling messages.
end System.Parameters;

215
gcc/ada/s-parame-vms-ia64.ads
View File

@ -1,215 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . P A R A M E T E R S --
-- --
-- S p e c --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the Integrity OpenVMS version
-- This package defines some system dependent parameters for GNAT. These
-- are values that are referenced by the runtime library and are therefore
-- relevant to the target machine.
-- The parameters whose value is defined in the spec are not generally
-- expected to be changed. If they are changed, it will be necessary to
-- recompile the run-time library.
-- The parameters which are defined by functions can be changed by modifying
-- the body of System.Parameters in file s-parame.adb. A change to this body
-- requires only rebinding and relinking of the application.
-- Note: do not introduce any pragma Inline statements into this unit, since
-- otherwise the relinking and rebinding capability would be deactivated.
package System.Parameters is
pragma Pure;
---------------------------------------
-- Task And Stack Allocation Control --
---------------------------------------
type Task_Storage_Size is new Integer;
-- Type used in tasking units for task storage size
type Size_Type is new Task_Storage_Size;
-- Type used to provide task storage size to runtime
Unspecified_Size : constant Size_Type := Size_Type'First;
-- Value used to indicate that no size type is set
subtype Percentage is Size_Type range -1 .. 100;
Dynamic : constant Size_Type := -1;
-- The secondary stack ratio is a constant between 0 and 100 which
-- determines the percentage of the allocated task stack that is
-- used by the secondary stack (the rest being the primary stack).
-- The special value of minus one indicates that the secondary
-- stack is to be allocated from the heap instead.
Sec_Stack_Percentage : constant Percentage := Dynamic;
-- This constant defines the handling of the secondary stack
Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic;
-- Convenient Boolean for testing for dynamic secondary stack
function Default_Stack_Size return Size_Type;
-- Default task stack size used if none is specified
function Minimum_Stack_Size return Size_Type;
-- Minimum task stack size permitted
function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
-- Given the storage size stored in the TCB, return the Storage_Size
-- value required by the RM for the Storage_Size attribute. The
-- required adjustment is as follows:
--
-- when Size = Unspecified_Size, return Default_Stack_Size
-- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
-- otherwise return given Size
Default_Env_Stack_Size : constant Size_Type := 8_192_000;
-- Assumed size of the environment task, if no other information
-- is available. This value is used when stack checking is
-- enabled and no GNAT_STACK_LIMIT environment variable is set.
Stack_Grows_Down : constant Boolean := True;
-- This constant indicates whether the stack grows up (False) or
-- down (True) in memory as functions are called. It is used for
-- proper implementation of the stack overflow check.
----------------------------------------------
-- Characteristics of types in Interfaces.C --
----------------------------------------------
long_bits : constant := 32;
-- 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.
ptr_bits : constant := 32;
subtype C_Address is System.Address
range -2 ** (ptr_bits - 1) .. 2 ** (ptr_bits - 1) - 1;
for C_Address'Object_Size use ptr_bits;
-- 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. System.Aux_DEC.Short_Address can't be used because of
-- elaboration circularity.
C_Malloc_Linkname : constant String := "__gnat_malloc32";
-- Name of runtime function used to allocate such a pointer
----------------------------------------------
-- Behavior of Pragma Finalize_Storage_Only --
----------------------------------------------
-- Garbage_Collected is a Boolean constant whose value indicates the
-- effect of the pragma Finalize_Storage_Entry on a controlled type.
-- Garbage_Collected = False
-- The system releases all storage on program termination only,
-- but not other garbage collection occurs, so finalization calls
-- are omitted only for outer level objects can be omitted if
-- pragma Finalize_Storage_Only is used.
-- Garbage_Collected = True
-- The system provides full garbage collection, so it is never
-- necessary to release storage for controlled objects for which
-- a pragma Finalize_Storage_Only is used.
Garbage_Collected : constant Boolean := False;
-- The storage mode for this system (release on program exit)
---------------------
-- Tasking Profile --
---------------------
-- In the following sections, constant parameters are defined to
-- allow some optimizations and fine tuning within the tasking run time
-- based on restrictions on the tasking features.
----------------------
-- Locking Strategy --
----------------------
Single_Lock : constant Boolean := False;
-- Indicates whether a single lock should be used within the tasking
-- run-time to protect internal structures. If True, a single lock
-- will be used, meaning less locking/unlocking operations, but also
-- more global contention. In general, Single_Lock should be set to
-- True on single processor machines, and to False to multi-processor
-- systems, but this can vary from application to application and also
-- depends on the scheduling policy.
-------------------
-- Task Abortion --
-------------------
No_Abort : constant Boolean := False;
-- This constant indicates whether abort statements and asynchronous
-- transfer of control (ATC) are disallowed. If set to True, it is
-- assumed that neither construct is used, and the run time does not
-- need to defer/undefer abort and check for pending actions at
-- completion points. A value of True for No_Abort corresponds to:
-- pragma Restrictions (No_Abort_Statements);
-- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0);
---------------------
-- Task Attributes --
---------------------
Max_Attribute_Count : constant := 32;
-- Number of task attributes stored in the task control block
--------------------
-- Runtime Traces --
--------------------
Runtime_Traces : constant Boolean := False;
-- This constant indicates whether the runtime outputs traces to a
-- predefined output or not (True means that traces are output).
-- See System.Traces for more details.
-----------------------
-- Task Image Length --
-----------------------
Max_Task_Image_Length : constant := 256;
-- This constant specifies the maximum length of a task's image
------------------------------
-- Exception Message Length --
------------------------------
Default_Exception_Msg_Max_Length : constant := 512;
-- This constant specifies the maximum number of characters to allow in an
-- exception message (see RM 11.4.1(18)). The value for VMS exceeds the
-- default minimum of 200 to allow for the length of chained VMS condition
-- handling messages.
end System.Parameters;

51
gcc/ada/s-ransee-vms.adb
View File

@ -1,51 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . R A N D O M _ S E E D --
-- --
-- B o d y --
-- --
-- Copyright (C) 2011-2012, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Version used on OpenVMS systems, where Clock accuracy is too low for
-- RM A.5.2(45).
with Interfaces; use Interfaces;
package body System.Random_Seed is
function Sys_Rpcc_64 return Unsigned_64;
pragma Import (C, Sys_Rpcc_64, "SYS$RPCC_64");
--------------
-- Get_Seed --
--------------
function Get_Seed return Interfaces.Unsigned_64 is
begin
return Sys_Rpcc_64;
end Get_Seed;
end System.Random_Seed;

6
gcc/ada/s-taasde.adb
View File

@ -153,9 +153,9 @@ package body System.Tasking.Async_Delays is
STI.Undefer_Abort_Nestable (D.Self_Id);
end Cancel_Async_Delay;
---------------------------
-- Enqueue_Time_Duration --
---------------------------
----------------------
-- Enqueue_Duration --
----------------------
function Enqueue_Duration
(T : Duration;

1278
gcc/ada/s-taprop-vms.adb
View File

File diff suppressed because it is too large Load Diff

2159
gcc/ada/s-tasdeb-vms.adb
View File

File diff suppressed because it is too large Load Diff

125
gcc/ada/s-taspri-vms.ads
View File

@ -1,125 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T A S K _ P R I M I T I V E S --
-- --
-- S p e c --
-- --
-- Copyright (C) 1991-2011, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a OpenVMS/Alpha version of this package
-- This package provides low-level support for most tasking features
pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during tasking
-- operations. It causes infinite loops and other problems.
with Interfaces.C;
with System.OS_Interface;
with System.Aux_DEC;
package System.Task_Primitives is
pragma Preelaborate;
type Lock is limited private;
-- Should be used for implementation of protected objects
type RTS_Lock is limited private;
-- Should be used inside the runtime system. The difference between Lock
-- and the RTS_Lock is that the later one serves only as a semaphore so
-- that do not check for ceiling violations.
type Suspension_Object is limited private;
-- Should be used for the implementation of Ada.Synchronous_Task_Control
type Task_Body_Access is access procedure;
-- Pointer to the task body's entry point (or possibly a wrapper
-- declared local to the GNARL).
type Private_Data is limited private;
-- Any information that the GNULLI needs maintained on a per-task basis.
-- A component of this type is guaranteed to be included in the
-- Ada_Task_Control_Block.
subtype Task_Address is System.Aux_DEC.Short_Address;
-- 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 := System.Aux_DEC.Short_Address_Size;
-- The size of Task_Address
Alternate_Stack_Size : constant := 0;
-- No alternate signal stack is used on this platform
private
type Lock is record
L : aliased System.OS_Interface.pthread_mutex_t;
Prio : Interfaces.C.int;
Prio_Save : Interfaces.C.int;
end record;
type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
type Suspension_Object is record
State : Boolean;
pragma Atomic (State);
-- Boolean that indicates whether the object is open. This field is
-- marked Atomic to ensure that we can read its value without locking
-- the access to the Suspension_Object.
Waiting : Boolean;
-- Flag showing if there is a task already suspended on this object
L : aliased System.OS_Interface.pthread_mutex_t;
-- Protection for ensuring mutual exclusion on the Suspension_Object
CV : aliased System.OS_Interface.pthread_cond_t;
-- Condition variable used to queue threads until ondition is signaled
end record;
type Private_Data is record
Thread : aliased System.OS_Interface.pthread_t;
pragma Atomic (Thread);
-- Thread field may be updated by two different threads of control.
-- (See, Enter_Task and Create_Task in s-taprop.adb). They put the
-- same value (thr_self value). We do not want to use lock on those
-- operations and the only thing we have to make sure is that they
-- are updated in atomic fashion.
CV : aliased System.OS_Interface.pthread_cond_t;
L : aliased RTS_Lock;
-- Protection for all components is lock L
AST_Pending : Boolean;
-- Used to detect delay and sleep timeouts
end record;
end System.Task_Primitives;

161
gcc/ada/s-tpopde-vms.adb
View File

@ -1,161 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC --
-- --
-- B o d y --
-- --
-- Copyright (C) 2000-2009, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This package is for OpenVMS/Alpha
with System.OS_Interface;
with System.Parameters;
with System.Tasking;
with Ada.Unchecked_Conversion;
with System.Soft_Links;
package body System.Task_Primitives.Operations.DEC is
use System.OS_Interface;
use System.Parameters;
use System.Tasking;
use System.Aux_DEC;
use type Interfaces.C.int;
package SSL renames System.Soft_Links;
-- The FAB_RAB_Type specifies where the context field (the calling
-- task) is stored. Other fields defined for FAB_RAB arent' need and
-- so are ignored.
type FAB_RAB_Type is record
CTX : Unsigned_Longword;
end record;
for FAB_RAB_Type use record
CTX at 24 range 0 .. 31;
end record;
for FAB_RAB_Type'Size use 224;
type FAB_RAB_Access_Type is access all FAB_RAB_Type;
-----------------------
-- Local Subprograms --
-----------------------
function To_Unsigned_Longword is new
Ada.Unchecked_Conversion (Task_Id, Unsigned_Longword);
function To_Task_Id is new
Ada.Unchecked_Conversion (Unsigned_Longword, Task_Id);
function To_FAB_RAB is new
Ada.Unchecked_Conversion (Address, FAB_RAB_Access_Type);
---------------------------
-- Interrupt_AST_Handler --
---------------------------
procedure Interrupt_AST_Handler (ID : Address) is
Result : Interfaces.C.int;
AST_Self_ID : constant Task_Id := To_Task_Id (ID);
begin
Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access);
pragma Assert (Result = 0);
end Interrupt_AST_Handler;
---------------------
-- RMS_AST_Handler --
---------------------
procedure RMS_AST_Handler (ID : Address) is
AST_Self_ID : constant Task_Id := To_Task_Id (To_FAB_RAB (ID).CTX);
Result : Interfaces.C.int;
begin
AST_Self_ID.Common.LL.AST_Pending := False;
Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access);
pragma Assert (Result = 0);
end RMS_AST_Handler;
----------
-- Self --
----------
function Self return Unsigned_Longword is
Self_ID : constant Task_Id := Self;
begin
Self_ID.Common.LL.AST_Pending := True;
return To_Unsigned_Longword (Self);
end Self;
-------------------------
-- Starlet_AST_Handler --
-------------------------
procedure Starlet_AST_Handler (ID : Address) is
Result : Interfaces.C.int;
AST_Self_ID : constant Task_Id := To_Task_Id (ID);
begin
AST_Self_ID.Common.LL.AST_Pending := False;
Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access);
pragma Assert (Result = 0);
end Starlet_AST_Handler;
----------------
-- Task_Synch --
----------------
procedure Task_Synch is
Synch_Self_ID : constant Task_Id := Self;
begin
if Single_Lock then
Lock_RTS;
else
Write_Lock (Synch_Self_ID);
end if;
SSL.Abort_Defer.all;
Synch_Self_ID.Common.State := AST_Server_Sleep;
while Synch_Self_ID.Common.LL.AST_Pending loop
Sleep (Synch_Self_ID, AST_Server_Sleep);
end loop;
Synch_Self_ID.Common.State := Runnable;
if Single_Lock then
Unlock_RTS;
else
Unlock (Synch_Self_ID);
end if;
SSL.Abort_Undefer.all;
end Task_Synch;
end System.Task_Primitives.Operations.DEC;

53
gcc/ada/s-tpopde-vms.ads
View File

@ -1,53 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC --
-- --
-- S p e c --
-- --
-- Copyright (C) 2000-2011, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This package is for OpenVMS/Alpha.
--
with System.Aux_DEC;
package System.Task_Primitives.Operations.DEC is
procedure Interrupt_AST_Handler (ID : Address);
pragma Convention (C, Interrupt_AST_Handler);
-- Handles the AST for Ada 95 Interrupts
procedure RMS_AST_Handler (ID : Address);
-- Handles the AST for RMS_Asynch_Operations
function Self return System.Aux_DEC.Unsigned_Longword;
-- Returns the task identification for the AST
procedure Starlet_AST_Handler (ID : Address);
-- Handles the AST for Starlet Tasking_Services
procedure Task_Synch;
-- Synchronizes the task after the system service completes
end System.Task_Primitives.Operations.DEC;

103
gcc/ada/s-tpopsp-vms.adb
View File

@ -1,103 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a VMS version of this package where foreign threads are
-- recognized.
separate (System.Task_Primitives.Operations)
package body Specific is
----------------
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_Id) is
pragma Warnings (Off, Environment_Task);
Result : Interfaces.C.int;
begin
Result := pthread_key_create (ATCB_Key'Access, null);
pragma Assert (Result = 0);
end Initialize;
-------------------
-- Is_Valid_Task --
-------------------
function Is_Valid_Task return Boolean is
begin
return pthread_getspecific (ATCB_Key) /= System.Null_Address;
end Is_Valid_Task;
---------
-- Set --
---------
procedure Set (Self_Id : Task_Id) is
Result : Interfaces.C.int;
begin
Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
pragma Assert (Result = 0);
end Set;
----------
-- Self --
----------
-- To make Ada tasks and C threads interoperate better, we have added some
-- functionality to Self. Suppose a C main program (with threads) calls an
-- Ada procedure and the Ada procedure calls the tasking runtime system.
-- Eventually, a call will be made to self. Since the call is not coming
-- from an Ada task, there will be no corresponding ATCB.
-- What we do in Self is to catch references that do not come from
-- recognized Ada tasks, and create an ATCB for the calling thread.
-- The new ATCB will be "detached" from the normal Ada task master
-- hierarchy, much like the existing implicitly created signal-server
-- tasks.
function Self return Task_Id is
Result : System.Address;
begin
Result := pthread_getspecific (ATCB_Key);
-- If the key value is Null then it is a non-Ada task
if Result /= System.Null_Address then
return To_Task_Id (Result);
else
return Register_Foreign_Thread;
end if;
end Self;
end Specific;

65
gcc/ada/s-traent-vms.adb
View File

@ -1,65 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . T R A C E B A C K _ E N T R I E S --
-- --
-- B o d y --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
pragma Polling (Off);
-- We must turn polling off for this unit, because otherwise we get
-- elaboration circularities with Ada.Exceptions.
package body System.Traceback_Entries is
------------
-- PC_For --
------------
function PC_For (TB_Entry : Traceback_Entry) return System.Address is
begin
return TB_Entry.PC;
end PC_For;
------------
-- PV_For --
------------
function PV_For (TB_Entry : Traceback_Entry) return System.Address is
begin
return TB_Entry.PV;
end PV_For;
------------------
-- TB_Entry_For --
------------------
function TB_Entry_For (PC : System.Address) return Traceback_Entry is
begin
return (PC => PC, PV => System.Null_Address);
end TB_Entry_For;
end System.Traceback_Entries;

66
gcc/ada/s-traent-vms.ads
View File

@ -1,66 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . T R A C E B A C K _ E N T R I E S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2003-2014, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the Alpha/OpenVMS version of this package
pragma Polling (Off);
-- We must turn polling off for this unit, because otherwise we get
-- elaboration circularities with Ada.Exceptions.
package System.Traceback_Entries is
pragma Preelaborate;
-- Symbolization is performed by a VMS service which requires more
-- than an instruction pointer.
type Traceback_Entry is record
PC : System.Address; -- Program Counter
PV : System.Address; -- Procedure Value
end record;
pragma Suppress_Initialization (Traceback_Entry);
Null_TB_Entry : constant Traceback_Entry :=
(PC => System.Null_Address,
PV => System.Null_Address);
type Tracebacks_Array is array (Positive range <>) of Traceback_Entry;
function PC_For (TB_Entry : Traceback_Entry) return System.Address;
function PV_For (TB_Entry : Traceback_Entry) return System.Address;
function TB_Entry_For (PC : System.Address) return Traceback_Entry;
end System.Traceback_Entries;

695
gcc/ada/s-vaflop-vms-alpha.adb
View File

@ -1,695 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1997-2012, Free Software Foundation, Inc. --
-- (Version for Alpha OpenVMS) --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with System.IO;
with System.Machine_Code; use System.Machine_Code;
package body System.Vax_Float_Operations is
-- Declare the functions that do the conversions between floating-point
-- formats. Call the operands IEEE float so they get passed in
-- FP registers.
function Cvt_G_T (X : T) return T;
function Cvt_T_G (X : T) return T;
function Cvt_T_F (X : T) return S;
pragma Import (C, Cvt_G_T, "OTS$CVT_FLOAT_G_T");
pragma Import (C, Cvt_T_G, "OTS$CVT_FLOAT_T_G");
pragma Import (C, Cvt_T_F, "OTS$CVT_FLOAT_T_F");
-- In each of the conversion routines that are done with OTS calls,
-- we define variables of the corresponding IEEE type so that they are
-- passed and kept in the proper register class.
Debug_String_Buffer : String (1 .. 32);
-- Buffer used by all Debug_String_x routines for returning result
------------
-- D_To_G --
------------
function D_To_G (X : D) return G is
A, B : T;
C : G;
begin
Asm ("ldg %0,%1", T'Asm_Output ("=f", A), D'Asm_Input ("m", X));
Asm ("cvtdg %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B));
return C;
end D_To_G;
------------
-- F_To_G --
------------
function F_To_G (X : F) return G is
A : T;
B : G;
begin
Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X));
Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
return B;
end F_To_G;
------------
-- F_To_S --
------------
function F_To_S (X : F) return S is
A : T;
B : S;
begin
-- Because converting to a wider FP format is a no-op, we say
-- A is 64-bit even though we are loading 32 bits into it.
Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X));
B := S (Cvt_G_T (A));
return B;
end F_To_S;
------------
-- G_To_D --
------------
function G_To_D (X : G) return D is
A, B : T;
C : D;
begin
Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
Asm ("cvtgd %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
Asm ("stg %1,%0", D'Asm_Output ("=m", C), T'Asm_Input ("f", B));
return C;
end G_To_D;
------------
-- G_To_F --
------------
function G_To_F (X : G) return F is
A : T;
B : S;
C : F;
begin
Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
Asm ("cvtgf %1,%0", S'Asm_Output ("=f", B), T'Asm_Input ("f", A));
Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
return C;
end G_To_F;
------------
-- G_To_Q --
------------
function G_To_Q (X : G) return Q is
A : T;
B : Q;
begin
Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
Asm ("cvtgq %1,%0", Q'Asm_Output ("=f", B), T'Asm_Input ("f", A));
return B;
end G_To_Q;
------------
-- G_To_T --
------------
function G_To_T (X : G) return T is
A, B : T;
begin
Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
B := Cvt_G_T (A);
return B;
end G_To_T;
------------
-- F_To_Q --
------------
function F_To_Q (X : F) return Q is
begin
return G_To_Q (F_To_G (X));
end F_To_Q;
------------
-- Q_To_F --
------------
function Q_To_F (X : Q) return F is
A : S;
B : F;
begin
Asm ("cvtqf %1,%0", S'Asm_Output ("=f", A), Q'Asm_Input ("f", X));
Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A));
return B;
end Q_To_F;
------------
-- Q_To_G --
------------
function Q_To_G (X : Q) return G is
A : T;
B : G;
begin
Asm ("cvtqg %1,%0", T'Asm_Output ("=f", A), Q'Asm_Input ("f", X));
Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
return B;
end Q_To_G;
------------
-- S_To_F --
------------
function S_To_F (X : S) return F is
A : S;
B : F;
begin
A := Cvt_T_F (T (X));
Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A));
return B;
end S_To_F;
------------
-- T_To_G --
------------
function T_To_G (X : T) return G is
A : T;
B : G;
begin
A := Cvt_T_G (X);
Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A));
return B;
end T_To_G;
------------
-- T_To_D --
------------
function T_To_D (X : T) return D is
begin
return G_To_D (T_To_G (X));
end T_To_D;
-----------
-- Abs_F --
-----------
function Abs_F (X : F) return F is
A, B : S;
C : F;
begin
Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X));
Asm ("cpys $f31,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A));
Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
return C;
end Abs_F;
-----------
-- Abs_G --
-----------
function Abs_G (X : G) return G is
A, B : T;
C : G;
begin
Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
Asm ("cpys $f31,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B));
return C;
end Abs_G;
-----------
-- Add_F --
-----------
function Add_F (X, Y : F) return F is
X1, Y1, R : S;
R1 : F;
begin
Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
Asm ("addf %1,%2,%0", S'Asm_Output ("=f", R),
(S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
return R1;
end Add_F;
-----------
-- Add_G --
-----------
function Add_G (X, Y : G) return G is
X1, Y1, R : T;
R1 : G;
begin
Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
Asm ("addg %1,%2,%0", T'Asm_Output ("=f", R),
(T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
return R1;
end Add_G;
--------------------
-- Debug_Output_D --
--------------------
procedure Debug_Output_D (Arg : D) is
begin
System.IO.Put (D'Image (Arg));
end Debug_Output_D;
--------------------
-- Debug_Output_F --
--------------------
procedure Debug_Output_F (Arg : F) is
begin
System.IO.Put (F'Image (Arg));
end Debug_Output_F;
--------------------
-- Debug_Output_G --
--------------------
procedure Debug_Output_G (Arg : G) is
begin
System.IO.Put (G'Image (Arg));
end Debug_Output_G;
--------------------
-- Debug_String_D --
--------------------
function Debug_String_D (Arg : D) return System.Address is
Image_String : constant String := D'Image (Arg) & ASCII.NUL;
Image_Size : constant Integer := Image_String'Length;
begin
Debug_String_Buffer (1 .. Image_Size) := Image_String;
return Debug_String_Buffer (1)'Address;
end Debug_String_D;
--------------------
-- Debug_String_F --
--------------------
function Debug_String_F (Arg : F) return System.Address is
Image_String : constant String := F'Image (Arg) & ASCII.NUL;
Image_Size : constant Integer := Image_String'Length;
begin
Debug_String_Buffer (1 .. Image_Size) := Image_String;
return Debug_String_Buffer (1)'Address;
end Debug_String_F;
--------------------
-- Debug_String_G --
--------------------
function Debug_String_G (Arg : G) return System.Address is
Image_String : constant String := G'Image (Arg) & ASCII.NUL;
Image_Size : constant Integer := Image_String'Length;
begin
Debug_String_Buffer (1 .. Image_Size) := Image_String;
return Debug_String_Buffer (1)'Address;
end Debug_String_G;
-----------
-- Div_F --
-----------
function Div_F (X, Y : F) return F is
X1, Y1, R : S;
R1 : F;
begin
Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
Asm ("divf %1,%2,%0", S'Asm_Output ("=f", R),
(S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
return R1;
end Div_F;
-----------
-- Div_G --
-----------
function Div_G (X, Y : G) return G is
X1, Y1, R : T;
R1 : G;
begin
Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
Asm ("divg %1,%2,%0", T'Asm_Output ("=f", R),
(T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
return R1;
end Div_G;
----------
-- Eq_F --
----------
function Eq_F (X, Y : F) return Boolean is
X1, Y1, R : S;
begin
Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
Asm ("cmpgeq %1,%2,%0", S'Asm_Output ("=f", R),
(S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
return R /= 0.0;
end Eq_F;
----------
-- Eq_G --
----------
function Eq_G (X, Y : G) return Boolean is
X1, Y1, R : T;
begin
Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
Asm ("cmpgeq %1,%2,%0", T'Asm_Output ("=f", R),
(T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
return R /= 0.0;
end Eq_G;
----------
-- Le_F --
----------
function Le_F (X, Y : F) return Boolean is
X1, Y1, R : S;
begin
Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
Asm ("cmpgle %1,%2,%0", S'Asm_Output ("=f", R),
(S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
return R /= 0.0;
end Le_F;
----------
-- Le_G --
----------
function Le_G (X, Y : G) return Boolean is
X1, Y1, R : T;
begin
Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
Asm ("cmpgle %1,%2,%0", T'Asm_Output ("=f", R),
(T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
return R /= 0.0;
end Le_G;
----------
-- Lt_F --
----------
function Lt_F (X, Y : F) return Boolean is
X1, Y1, R : S;
begin
Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
Asm ("cmpglt %1,%2,%0", S'Asm_Output ("=f", R),
(S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
return R /= 0.0;
end Lt_F;
----------
-- Lt_G --
----------
function Lt_G (X, Y : G) return Boolean is
X1, Y1, R : T;
begin
Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
Asm ("cmpglt %1,%2,%0", T'Asm_Output ("=f", R),
(T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
return R /= 0.0;
end Lt_G;
-----------
-- Mul_F --
-----------
function Mul_F (X, Y : F) return F is
X1, Y1, R : S;
R1 : F;
begin
Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
Asm ("mulf %1,%2,%0", S'Asm_Output ("=f", R),
(S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
return R1;
end Mul_F;
-----------
-- Mul_G --
-----------
function Mul_G (X, Y : G) return G is
X1, Y1, R : T;
R1 : G;
begin
Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
Asm ("mulg %1,%2,%0", T'Asm_Output ("=f", R),
(T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
return R1;
end Mul_G;
----------
-- Ne_F --
----------
function Ne_F (X, Y : F) return Boolean is
X1, Y1, R : S;
begin
Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
Asm ("cmpgeq %1,%2,%0", S'Asm_Output ("=f", R),
(S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
return R = 0.0;
end Ne_F;
----------
-- Ne_G --
----------
function Ne_G (X, Y : G) return Boolean is
X1, Y1, R : T;
begin
Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
Asm ("cmpgeq %1,%2,%0", T'Asm_Output ("=f", R),
(T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
return R = 0.0;
end Ne_G;
-----------
-- Neg_F --
-----------
function Neg_F (X : F) return F is
A, B : S;
C : F;
begin
Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X));
Asm ("subf $f31,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A));
Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B));
return C;
end Neg_F;
-----------
-- Neg_G --
-----------
function Neg_G (X : G) return G is
A, B : T;
C : G;
begin
Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X));
Asm ("subg $f31,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A));
Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B));
return C;
end Neg_G;
--------
-- pd --
--------
procedure pd (Arg : D) is
begin
System.IO.Put_Line (D'Image (Arg));
end pd;
--------
-- pf --
--------
procedure pf (Arg : F) is
begin
System.IO.Put_Line (F'Image (Arg));
end pf;
--------
-- pg --
--------
procedure pg (Arg : G) is
begin
System.IO.Put_Line (G'Image (Arg));
end pg;
--------------
-- Return_D --
--------------
function Return_D (X : D) return D is
R : D;
begin
-- The return value is already in $f0 so we need to trick the compiler
-- into thinking that we're moving X to $f0.
Asm ("cvtdg $f0,$f0", Inputs => D'Asm_Input ("g", X), Clobber => "$f0",
Volatile => True);
Asm ("stg $f0,%0", D'Asm_Output ("=m", R), Volatile => True);
return R;
end Return_D;
--------------
-- Return_F --
--------------
function Return_F (X : F) return F is
R : F;
begin
-- The return value is already in $f0 so we need to trick the compiler
-- into thinking that we're moving X to $f0.
Asm ("stf $f0,%0", F'Asm_Output ("=m", R), F'Asm_Input ("g", X),
Clobber => "$f0", Volatile => True);
return R;
end Return_F;
--------------
-- Return_G --
--------------
function Return_G (X : G) return G is
R : G;
begin
-- The return value is already in $f0 so we need to trick the compiler
-- into thinking that we're moving X to $f0.
Asm ("stg $f0,%0", G'Asm_Output ("=m", R), G'Asm_Input ("g", X),
Clobber => "$f0", Volatile => True);
return R;
end Return_G;
-----------
-- Sub_F --
-----------
function Sub_F (X, Y : F) return F is
X1, Y1, R : S;
R1 : F;
begin
Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X));
Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y));
Asm ("subf %1,%2,%0", S'Asm_Output ("=f", R),
(S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1)));
Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R));
return R1;
end Sub_F;
-----------
-- Sub_G --
-----------
function Sub_G (X, Y : G) return G is
X1, Y1, R : T;
R1 : G;
begin
Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X));
Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y));
Asm ("subg %1,%2,%0", T'Asm_Output ("=f", R),
(T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1)));
Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R));
return R1;
end Sub_G;
-------------
-- Valid_D --
-------------
-- For now, convert to IEEE and do Valid test on result. This is not quite
-- accurate, but is good enough in practice.
function Valid_D (Arg : D) return Boolean is
Val : constant T := G_To_T (D_To_G (Arg));
begin
return Val'Valid;
end Valid_D;
-------------
-- Valid_F --
-------------
-- For now, convert to IEEE and do Valid test on result. This is not quite
-- accurate, but is good enough in practice.
function Valid_F (Arg : F) return Boolean is
Val : constant S := F_To_S (Arg);
begin
return Val'Valid;
end Valid_F;
-------------
-- Valid_G --
-------------
-- For now, convert to IEEE and do Valid test on result. This is not quite
-- accurate, but is good enough in practice.
function Valid_G (Arg : G) return Boolean is
Val : constant T := G_To_T (Arg);
begin
return Val'Valid;
end Valid_G;
end System.Vax_Float_Operations;

18
gcc/ada/sem_ch13.adb
View File

@ -10614,15 +10614,15 @@ package body Sem_Ch13 is
Nam : Name_Id) return Boolean
is
function All_Static_Case_Alternatives (L : List_Id) return Boolean;
-- Given a list of case expression alternatives, returns True if
-- all the alternatives are static (have all static choices, and a
-- static expression).
-- Given a list of case expression alternatives, returns True if all
-- the alternatives are static (have all static choices, and a static
-- expression).
function All_Static_Choices (L : List_Id) return Boolean;
-- Returns true if all elements of the list are OK static choices
-- as defined below for Is_Static_Choice. Used for case expression
-- alternatives and for the right operand of a membership test.
-- An others_choice is static if the corresponding expression is static.
-- alternatives and for the right operand of a membership test. An
-- others_choice is static if the corresponding expression is static.
-- The staticness of the bounds is checked separately.
function Is_Static_Choice (N : Node_Id) return Boolean;
@ -10636,10 +10636,10 @@ package body Sem_Ch13 is
function Is_Type_Ref (N : Node_Id) return Boolean;
pragma Inline (Is_Type_Ref);
-- Returns True if N is a reference to the type for the predicate in
-- the expression (i.e. if it is an identifier whose Chars field matches
-- the Nam given in the call). N must not be parenthesized, if the type
-- name appears in parens, this routine will return False.
-- Returns True if N is a reference to the type for the predicate in the
-- expression (i.e. if it is an identifier whose Chars field matches the
-- Nam given in the call). N must not be parenthesized, if the type name
-- appears in parens, this routine will return False.
----------------------------------
-- All_Static_Case_Alternatives --

4
gcc/ada/sem_ch3.adb
View File

@ -4514,8 +4514,8 @@ package body Sem_Ch3 is
when Enumeration_Kind =>
Set_Ekind (Id, E_Enumeration_Subtype);
Set_Has_Dynamic_Predicate_Aspect (Id,
Has_Dynamic_Predicate_Aspect (T));
Set_Has_Dynamic_Predicate_Aspect
(Id, Has_Dynamic_Predicate_Aspect (T));
Set_First_Literal (Id, First_Literal (Base_Type (T)));
Set_Scalar_Range (Id, Scalar_Range (T));
Set_Is_Character_Type (Id, Is_Character_Type (T));

318
gcc/ada/symbols-processing-vms-alpha.adb
View File

@ -1,318 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y M B O L S . P R O C E S S I N G --
-- --
-- B o d y --
-- --
-- Copyright (C) 2003-2010, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the VMS Alpha version of this package
separate (Symbols)
package body Processing is
type Number is mod 2**16;
-- 16 bits unsigned number for number of characters
EMH : constant Number := 8;
-- Code for the Module Header section
GSD : constant Number := 10;
-- Code for the Global Symbol Definition section
C_SYM : constant Number := 1;
-- Code for a Symbol subsection
V_DEF_Mask : constant Number := 2 ** 1;
V_NORM_Mask : constant Number := 2 ** 6;
-- Comments ???
B : Byte;
Number_Of_Characters : Natural := 0;
-- The number of characters of each section
Native_Format : Boolean;
-- True if records are decoded by the system (like on VMS)
Has_Pad : Boolean;
-- If true, a pad byte must be skipped before reading the next record
-- The following variables are used by procedure Process when reading an
-- object file.
Code : Number := 0;
Length : Natural := 0;
Dummy : Number;
Nchars : Natural := 0;
Flags : Number := 0;
Symbol : String (1 .. 255);
LSymb : Natural;
procedure Get (N : out Number);
-- Read two bytes from the object file LSB first as unsigned 16 bit number
procedure Get (N : out Natural);
-- Read two bytes from the object file, LSByte first, as a Natural
---------
-- Get --
---------
procedure Get (N : out Number) is
C : Byte;
LSByte : Number;
begin
Read (File, C);
LSByte := Byte'Pos (C);
Read (File, C);
N := LSByte + (256 * Byte'Pos (C));
end Get;
procedure Get (N : out Natural) is
Result : Number;
begin
Get (Result);
N := Natural (Result);
end Get;
-------------
-- Process --
-------------
procedure Process
(Object_File : String;
Success : out Boolean)
is
OK : Boolean := True;
begin
-- Open the object file with Byte_IO. Return with Success = False if
-- this fails.
begin
Open (File, In_File, Object_File);
exception
when others =>
Put_Line
("*** Unable to open object file """ & Object_File & """");
Success := False;
return;
end;
-- Assume that the object file has a correct format
Success := True;
-- Check the file format in case of cross-tool
Get (Code);
Get (Number_Of_Characters);
Get (Dummy);
if Code = Dummy and then Number_Of_Characters = Natural (EMH) then
-- Looks like a cross tool
Native_Format := False;
Number_Of_Characters := Natural (Dummy) - 4;
Has_Pad := (Number_Of_Characters mod 2) = 1;
elsif Code = EMH then
Native_Format := True;
Number_Of_Characters := Number_Of_Characters - 6;
Has_Pad := False;
else
Put_Line ("file """ & Object_File & """ is not an object file");
Close (File);
Success := False;
return;
end if;
-- Skip the EMH section
for J in 1 .. Number_Of_Characters loop
Read (File, B);
end loop;
-- Get the different sections one by one from the object file
while not End_Of_File (File) loop
if not Native_Format then
-- Skip pad byte if present
if Has_Pad then
Get (B);
end if;
-- Skip record length
Get (Dummy);
end if;
Get (Code);
Get (Number_Of_Characters);
if not Native_Format then
if Natural (Dummy) /= Number_Of_Characters then
-- Format error
raise Constraint_Error;
end if;
Has_Pad := (Number_Of_Characters mod 2) = 1;
end if;
-- The header is 4 bytes length
Number_Of_Characters := Number_Of_Characters - 4;
-- If this is not a Global Symbol Definition section, skip to the
-- next section.
if Code /= GSD then
for J in 1 .. Number_Of_Characters loop
Read (File, B);
end loop;
else
-- Skip over the next 4 bytes
Get (Dummy);
Get (Dummy);
Number_Of_Characters := Number_Of_Characters - 4;
-- Get each subsection in turn
loop
Get (Code);
Get (Nchars);
Get (Dummy);
Get (Flags);
Number_Of_Characters := Number_Of_Characters - 8;
Nchars := Nchars - 8;
-- If this is a symbol and the V_DEF flag is set, get symbol
if Code = C_SYM and then ((Flags and V_DEF_Mask) /= 0) then
-- First, reach the symbol length
for J in 1 .. 25 loop
Read (File, B);
Nchars := Nchars - 1;
Number_Of_Characters := Number_Of_Characters - 1;
end loop;
Length := Byte'Pos (B);
LSymb := 0;
-- Get the symbol characters
for J in 1 .. Nchars loop
Read (File, B);
Number_Of_Characters := Number_Of_Characters - 1;
if Length > 0 then
LSymb := LSymb + 1;
Symbol (LSymb) := B;
Length := Length - 1;
end if;
end loop;
-- Check if it is a symbol from a generic body
OK := True;
for J in 1 .. LSymb - 2 loop
if Symbol (J) = 'G' and then Symbol (J + 1) = 'P'
and then Symbol (J + 2) in '0' .. '9'
then
OK := False;
exit;
end if;
end loop;
if OK then
-- Create the new Symbol
declare
S_Data : Symbol_Data;
begin
S_Data.Name := new String'(Symbol (1 .. LSymb));
-- The symbol kind (Data or Procedure) depends on the
-- V_NORM flag.
if (Flags and V_NORM_Mask) = 0 then
S_Data.Kind := Data;
else
S_Data.Kind := Proc;
end if;
-- Put the new symbol in the table
Symbol_Table.Append (Complete_Symbols, S_Data);
end;
end if;
else
-- As it is not a symbol subsection, skip to the next
-- subsection.
for J in 1 .. Nchars loop
Read (File, B);
Number_Of_Characters := Number_Of_Characters - 1;
end loop;
end if;
-- Exit the GSD section when number of characters reaches zero
exit when Number_Of_Characters = 0;
end loop;
end if;
end loop;
-- The object file has been processed, close it
Close (File);
exception
-- For any exception, output an error message, close the object file
-- and return with Success = False.
when X : others =>
Put_Line ("unexpected exception raised while processing """
& Object_File & """");
Put_Line (Exception_Information (X));
Close (File);
Success := False;
end Process;
end Processing;

430
gcc/ada/symbols-processing-vms-ia64.adb
View File

@ -1,430 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y M B O L S . P R O C E S S I N G --
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2009, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the VMS/IA64 version of this package
with Ada.IO_Exceptions;
with Ada.Unchecked_Deallocation;
separate (Symbols)
package body Processing is
type String_Array is array (Positive range <>) of String_Access;
type Strings_Ptr is access String_Array;
procedure Free is
new Ada.Unchecked_Deallocation (String_Array, Strings_Ptr);
type Section_Header is record
Shname : Integer;
Shtype : Integer;
Shoffset : Integer;
Shsize : Integer;
Shlink : Integer;
end record;
type Section_Header_Array is array (Natural range <>) of Section_Header;
type Section_Header_Ptr is access Section_Header_Array;
procedure Free is
new Ada.Unchecked_Deallocation (Section_Header_Array, Section_Header_Ptr);
-------------
-- Process --
-------------
procedure Process
(Object_File : String;
Success : out Boolean)
is
B : Byte;
W : Integer;
Str : String (1 .. 1000) := (others => ' ');
Str_Last : Natural;
Strings : Strings_Ptr;
Shoff : Integer;
Shnum : Integer;
Shentsize : Integer;
Shname : Integer;
Shtype : Integer;
Shoffset : Integer;
Shsize : Integer;
Shlink : Integer;
Symtab_Index : Natural := 0;
String_Table_Index : Natural := 0;
End_Symtab : Integer;
Stname : Integer;
Stinfo : Character;
Stother : Character;
Sttype : Integer;
Stbind : Integer;
Stshndx : Integer;
Stvis : Integer;
STV_Internal : constant := 1;
STV_Hidden : constant := 2;
Section_Headers : Section_Header_Ptr;
Offset : Natural := 0;
OK : Boolean := True;
procedure Get_Byte (B : out Byte);
-- Read one byte from the object file
procedure Get_Half (H : out Integer);
-- Read one half work from the object file
procedure Get_Word (W : out Integer);
-- Read one full word from the object file
procedure Reset;
-- Restart reading the object file
procedure Skip_Half;
-- Read and disregard one half word from the object file
--------------
-- Get_Byte --
--------------
procedure Get_Byte (B : out Byte) is
begin
Byte_IO.Read (File, B);
Offset := Offset + 1;
end Get_Byte;
--------------
-- Get_Half --
--------------
procedure Get_Half (H : out Integer) is
C1, C2 : Character;
begin
Get_Byte (C1); Get_Byte (C2);
H :=
Integer'(Character'Pos (C2)) * 256 + Integer'(Character'Pos (C1));
end Get_Half;
--------------
-- Get_Word --
--------------
procedure Get_Word (W : out Integer) is
H1, H2 : Integer;
begin
Get_Half (H1); Get_Half (H2);
W := H2 * 256 * 256 + H1;
end Get_Word;
-----------
-- Reset --
-----------
procedure Reset is
begin
Offset := 0;
Byte_IO.Reset (File);
end Reset;
---------------
-- Skip_Half --
---------------
procedure Skip_Half is
B : Byte;
pragma Unreferenced (B);
begin
Byte_IO.Read (File, B);
Byte_IO.Read (File, B);
Offset := Offset + 2;
end Skip_Half;
-- Start of processing for Process
begin
-- Open the object file with Byte_IO. Return with Success = False if
-- this fails.
begin
Open (File, In_File, Object_File);
exception
when others =>
Put_Line
("*** Unable to open object file """ & Object_File & """");
Success := False;
return;
end;
-- Assume that the object file has a correct format
Success := True;
-- Skip ELF identification
while Offset < 16 loop
Get_Byte (B);
end loop;
-- Skip e_type
Skip_Half;
-- Skip e_machine
Skip_Half;
-- Skip e_version
Get_Word (W);
-- Skip e_entry
for J in 1 .. 8 loop
Get_Byte (B);
end loop;
-- Skip e_phoff
for J in 1 .. 8 loop
Get_Byte (B);
end loop;
Get_Word (Shoff);
-- Skip upper half of Shoff
for J in 1 .. 4 loop
Get_Byte (B);
end loop;
-- Skip e_flags
Get_Word (W);
-- Skip e_ehsize
Skip_Half;
-- Skip e_phentsize
Skip_Half;
-- Skip e_phnum
Skip_Half;
Get_Half (Shentsize);
Get_Half (Shnum);
Section_Headers := new Section_Header_Array (0 .. Shnum - 1);
-- Go to Section Headers
while Offset < Shoff loop
Get_Byte (B);
end loop;
-- Reset Symtab_Index
Symtab_Index := 0;
for J in Section_Headers'Range loop
-- Get the data for each Section Header
Get_Word (Shname);
Get_Word (Shtype);
for K in 1 .. 16 loop
Get_Byte (B);
end loop;
Get_Word (Shoffset);
Get_Word (W);
Get_Word (Shsize);
Get_Word (W);
Get_Word (Shlink);
while (Offset - Shoff) mod Shentsize /= 0 loop
Get_Byte (B);
end loop;
-- If this is the Symbol Table Section Header, record its index
if Shtype = 2 then
Symtab_Index := J;
end if;
Section_Headers (J) := (Shname, Shtype, Shoffset, Shsize, Shlink);
end loop;
if Symtab_Index = 0 then
Success := False;
return;
end if;
End_Symtab :=
Section_Headers (Symtab_Index).Shoffset +
Section_Headers (Symtab_Index).Shsize;
String_Table_Index := Section_Headers (Symtab_Index).Shlink;
Strings :=
new String_Array (1 .. Section_Headers (String_Table_Index).Shsize);
-- Go get the String Table section for the Symbol Table
Reset;
while Offset < Section_Headers (String_Table_Index).Shoffset loop
Get_Byte (B);
end loop;
Offset := 0;
Get_Byte (B); -- zero
while Offset < Section_Headers (String_Table_Index).Shsize loop
Str_Last := 0;
loop
Get_Byte (B);
if B /= ASCII.NUL then
Str_Last := Str_Last + 1;
Str (Str_Last) := B;
else
Strings (Offset - Str_Last - 1) :=
new String'(Str (1 .. Str_Last));
exit;
end if;
end loop;
end loop;
-- Go get the Symbol Table
Reset;
while Offset < Section_Headers (Symtab_Index).Shoffset loop
Get_Byte (B);
end loop;
while Offset < End_Symtab loop
Get_Word (Stname);
Get_Byte (Stinfo);
Get_Byte (Stother);
Get_Half (Stshndx);
for J in 1 .. 4 loop
Get_Word (W);
end loop;
Sttype := Integer'(Character'Pos (Stinfo)) mod 16;
Stbind := Integer'(Character'Pos (Stinfo)) / 16;
Stvis := Integer'(Character'Pos (Stother)) mod 4;
if (Sttype = 1 or else Sttype = 2)
and then Stbind /= 0
and then Stshndx /= 0
and then Stvis /= STV_Internal
and then Stvis /= STV_Hidden
then
-- Check if this is a symbol from a generic body
OK := True;
for J in Strings (Stname)'First .. Strings (Stname)'Last - 2 loop
if Strings (Stname) (J) = 'G'
and then Strings (Stname) (J + 1) = 'P'
and then Strings (Stname) (J + 2) in '0' .. '9'
then
OK := False;
exit;
end if;
end loop;
if OK then
declare
S_Data : Symbol_Data;
begin
S_Data.Name := new String'(Strings (Stname).all);
if Sttype = 1 then
S_Data.Kind := Data;
else
S_Data.Kind := Proc;
end if;
-- Put the new symbol in the table
Symbol_Table.Append (Complete_Symbols, S_Data);
end;
end if;
end if;
end loop;
-- The object file has been processed, close it
Close (File);
-- Free the allocated memory
Free (Section_Headers);
for J in Strings'Range loop
if Strings (J) /= null then
Free (Strings (J));
end if;
end loop;
Free (Strings);
exception
-- For any exception, output an error message, close the object file
-- and return with Success = False.
when Ada.IO_Exceptions.End_Error =>
Close (File);
when X : others =>
Put_Line ("unexpected exception raised while processing """
& Object_File & """");
Put_Line (Exception_Information (X));
Close (File);
Success := False;
end Process;
end Processing;

637
gcc/ada/symbols-vms.adb
View File

@ -1,637 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y M B O L S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2003-2007, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the VMS version of this package
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Sequential_IO;
with Ada.Text_IO; use Ada.Text_IO;
package body Symbols is
Case_Sensitive : constant String := "case_sensitive=";
Symbol_Vector : constant String := "SYMBOL_VECTOR=(";
Equal_Data : constant String := "=DATA)";
Equal_Procedure : constant String := "=PROCEDURE)";
Gsmatch : constant String := "gsmatch=";
Gsmatch_Lequal : constant String := "gsmatch=lequal,";
Symbol_File_Name : String_Access := null;
-- Name of the symbol file
Long_Symbol_Length : constant := 100;
-- Magic length of symbols, over which the lines are split
Sym_Policy : Policy := Autonomous;
-- The symbol policy. Set by Initialize
Major_ID : Integer := 1;
-- The Major ID. May be modified by Initialize if Library_Version is
-- specified or if it is read from the reference symbol file.
Soft_Major_ID : Boolean := True;
-- False if library version is specified in procedure Initialize.
-- When True, Major_ID may be modified if found in the reference symbol
-- file.
Minor_ID : Natural := 0;
-- The Minor ID. May be modified if read from the reference symbol file
Soft_Minor_ID : Boolean := True;
-- False if symbol policy is Autonomous, if library version is specified
-- in procedure Initialize and is not the same as the major ID read from
-- the reference symbol file. When True, Minor_ID may be increased in
-- Compliant symbol policy.
subtype Byte is Character;
-- Object files are stream of bytes, but some of these bytes, those for
-- the names of the symbols, are ASCII characters.
package Byte_IO is new Ada.Sequential_IO (Byte);
use Byte_IO;
File : Byte_IO.File_Type;
-- Each object file is read as a stream of bytes (characters)
function Equal (Left, Right : Symbol_Data) return Boolean;
-- Test for equality of symbols
function Image (N : Integer) return String;
-- Returns the image of N, without the initial space
-----------
-- Equal --
-----------
function Equal (Left, Right : Symbol_Data) return Boolean is
begin
return Left.Name /= null and then
Right.Name /= null and then
Left.Name.all = Right.Name.all and then
Left.Kind = Right.Kind and then
Left.Present = Right.Present;
end Equal;
-----------
-- Image --
-----------
function Image (N : Integer) return String is
Result : constant String := N'Img;
begin
if Result (Result'First) = ' ' then
return Result (Result'First + 1 .. Result'Last);
else
return Result;
end if;
end Image;
----------------
-- Initialize --
----------------
procedure Initialize
(Symbol_File : String;
Reference : String;
Symbol_Policy : Policy;
Quiet : Boolean;
Version : String;
Success : out Boolean)
is
File : Ada.Text_IO.File_Type;
Line : String (1 .. 2_000);
Last : Natural;
Offset : Natural;
begin
-- Record the symbol file name
Symbol_File_Name := new String'(Symbol_File);
-- Record the policy
Sym_Policy := Symbol_Policy;
-- Record the version (Major ID)
if Version = "" then
Major_ID := 1;
Soft_Major_ID := True;
else
begin
Major_ID := Integer'Value (Version);
Soft_Major_ID := False;
if Major_ID <= 0 then
raise Constraint_Error;
end if;
exception
when Constraint_Error =>
if not Quiet then
Put_Line ("Version """ & Version & """ is illegal.");
Put_Line ("On VMS, version must be a positive number");
end if;
Success := False;
return;
end;
end if;
Minor_ID := 0;
Soft_Minor_ID := Sym_Policy /= Autonomous;
-- Empty the symbol tables
Symbol_Table.Set_Last (Original_Symbols, 0);
Symbol_Table.Set_Last (Complete_Symbols, 0);
-- Assume that everything will be fine
Success := True;
-- If policy is Compliant or Controlled, attempt to read the reference
-- file. If policy is Restricted, attempt to read the symbol file.
if Sym_Policy /= Autonomous then
case Sym_Policy is
when Autonomous | Direct =>
null;
when Compliant | Controlled =>
begin
Open (File, In_File, Reference);
exception
when Ada.Text_IO.Name_Error =>
Success := False;
return;
when X : others =>
if not Quiet then
Put_Line ("could not open """ & Reference & """");
Put_Line (Exception_Message (X));
end if;
Success := False;
return;
end;
when Restricted =>
begin
Open (File, In_File, Symbol_File);
exception
when Ada.Text_IO.Name_Error =>
Success := False;
return;
when X : others =>
if not Quiet then
Put_Line ("could not open """ & Symbol_File & """");
Put_Line (Exception_Message (X));
end if;
Success := False;
return;
end;
end case;
-- Read line by line
while not End_Of_File (File) loop
Offset := 0;
loop
Get_Line (File, Line (Offset + 1 .. Line'Last), Last);
exit when Line (Last) /= '-';
if End_Of_File (File) then
if not Quiet then
Put_Line ("symbol file """ & Reference &
""" is incorrectly formatted:");
Put_Line ("""" & Line (1 .. Last) & """");
end if;
Close (File);
Success := False;
return;
else
Offset := Last - 1;
end if;
end loop;
-- Ignore empty lines
if Last = 0 then
null;
-- Ignore lines starting with "case_sensitive="
elsif Last > Case_Sensitive'Length
and then Line (1 .. Case_Sensitive'Length) = Case_Sensitive
then
null;
-- Line starting with "SYMBOL_VECTOR=("
elsif Last > Symbol_Vector'Length
and then Line (1 .. Symbol_Vector'Length) = Symbol_Vector
then
-- SYMBOL_VECTOR=(<symbol>=DATA)
if Last > Symbol_Vector'Length + Equal_Data'Length and then
Line (Last - Equal_Data'Length + 1 .. Last) = Equal_Data
then
Symbol_Table.Append (Original_Symbols,
(Name =>
new String'(Line (Symbol_Vector'Length + 1 ..
Last - Equal_Data'Length)),
Kind => Data,
Present => True));
-- SYMBOL_VECTOR=(<symbol>=PROCEDURE)
elsif Last > Symbol_Vector'Length + Equal_Procedure'Length
and then
Line (Last - Equal_Procedure'Length + 1 .. Last) =
Equal_Procedure
then
Symbol_Table.Append (Original_Symbols,
(Name =>
new String'(Line (Symbol_Vector'Length + 1 ..
Last - Equal_Procedure'Length)),
Kind => Proc,
Present => True));
-- Anything else is incorrectly formatted
else
if not Quiet then
Put_Line ("symbol file """ & Reference &
""" is incorrectly formatted:");
Put_Line ("""" & Line (1 .. Last) & """");
end if;
Close (File);
Success := False;
return;
end if;
-- Lines with "gsmatch=lequal," or "gsmatch=equal,"
elsif Last > Gsmatch'Length
and then Line (1 .. Gsmatch'Length) = Gsmatch
then
declare
Start : Positive := Gsmatch'Length + 1;
Finish : Positive := Start;
OK : Boolean := True;
ID : Integer;
begin
-- First, look for the first coma
loop
if Start >= Last - 1 then
OK := False;
exit;
elsif Line (Start) = ',' then
Start := Start + 1;
exit;
else
Start := Start + 1;
end if;
end loop;
Finish := Start;
-- If the comma is found, get the Major and the Minor IDs
if OK then
loop
if Line (Finish) not in '0' .. '9'
or else Finish >= Last - 1
then
OK := False;
exit;
end if;
exit when Line (Finish + 1) = ',';
Finish := Finish + 1;
end loop;
end if;
if OK then
ID := Integer'Value (Line (Start .. Finish));
OK := ID /= 0;
-- If Soft_Major_ID is True, it means that
-- Library_Version was not specified.
if Soft_Major_ID then
Major_ID := ID;
-- If the Major ID in the reference file is different
-- from the Library_Version, then the Minor ID will be 0
-- because there is no point in taking the Minor ID in
-- the reference file, or incrementing it. So, we set
-- Soft_Minor_ID to False, so that we don't modify
-- the Minor_ID later.
elsif Major_ID /= ID then
Soft_Minor_ID := False;
end if;
Start := Finish + 2;
Finish := Start;
loop
if Line (Finish) not in '0' .. '9' then
OK := False;
exit;
end if;
exit when Finish = Last;
Finish := Finish + 1;
end loop;
-- Only set Minor_ID if Soft_Minor_ID is True (see above)
if OK and then Soft_Minor_ID then
Minor_ID := Integer'Value (Line (Start .. Finish));
end if;
end if;
-- If OK is not True, that means the line is not correctly
-- formatted.
if not OK then
if not Quiet then
Put_Line ("symbol file """ & Reference &
""" is incorrectly formatted");
Put_Line ("""" & Line (1 .. Last) & """");
end if;
Close (File);
Success := False;
return;
end if;
end;
-- Anything else is incorrectly formatted
else
if not Quiet then
Put_Line ("unexpected line in symbol file """ &
Reference & """");
Put_Line ("""" & Line (1 .. Last) & """");
end if;
Close (File);
Success := False;
return;
end if;
end loop;
Close (File);
end if;
end Initialize;
----------------
-- Processing --
----------------
package body Processing is separate;
--------------
-- Finalize --
--------------
procedure Finalize
(Quiet : Boolean;
Success : out Boolean)
is
File : Ada.Text_IO.File_Type;
-- The symbol file
S_Data : Symbol_Data;
-- A symbol
Cur : Positive := 1;
-- Most probable index in the Complete_Symbols of the current symbol
-- in Original_Symbol.
Found : Boolean;
begin
-- Nothing to be done if Initialize has never been called
if Symbol_File_Name = null then
Success := False;
else
-- First find if the symbols in the reference symbol file are also
-- in the object files. Note that this is not done if the policy is
-- Autonomous, because no reference symbol file has been read.
-- Expect the first symbol in the symbol file to also be the first
-- in Complete_Symbols.
Cur := 1;
for Index_1 in 1 .. Symbol_Table.Last (Original_Symbols) loop
S_Data := Original_Symbols.Table (Index_1);
Found := False;
First_Object_Loop :
for Index_2 in Cur .. Symbol_Table.Last (Complete_Symbols) loop
if Equal (S_Data, Complete_Symbols.Table (Index_2)) then
Cur := Index_2 + 1;
Complete_Symbols.Table (Index_2).Present := False;
Found := True;
exit First_Object_Loop;
end if;
end loop First_Object_Loop;
-- If the symbol could not be found between Cur and Last, try
-- before Cur.
if not Found then
Second_Object_Loop :
for Index_2 in 1 .. Cur - 1 loop
if Equal (S_Data, Complete_Symbols.Table (Index_2)) then
Cur := Index_2 + 1;
Complete_Symbols.Table (Index_2).Present := False;
Found := True;
exit Second_Object_Loop;
end if;
end loop Second_Object_Loop;
end if;
-- If the symbol is not found, mark it as such in the table
if not Found then
if (not Quiet) or else Sym_Policy = Controlled then
Put_Line ("symbol """ & S_Data.Name.all &
""" is no longer present in the object files");
end if;
if Sym_Policy = Controlled or else Sym_Policy = Restricted then
Success := False;
return;
-- Any symbol that is undefined in the reference symbol file
-- triggers an increase of the Major ID, because the new
-- version of the library is no longer compatible with
-- existing executables.
elsif Soft_Major_ID then
Major_ID := Major_ID + 1;
Minor_ID := 0;
Soft_Major_ID := False;
Soft_Minor_ID := False;
end if;
Original_Symbols.Table (Index_1).Present := False;
Free (Original_Symbols.Table (Index_1).Name);
if Soft_Minor_ID then
Minor_ID := Minor_ID + 1;
Soft_Minor_ID := False;
end if;
end if;
end loop;
if Sym_Policy /= Restricted then
-- Append additional symbols, if any, to the Original_Symbols
-- table.
for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop
S_Data := Complete_Symbols.Table (Index);
if S_Data.Present then
if Sym_Policy = Controlled then
Put_Line ("symbol """ & S_Data.Name.all &
""" is not in the reference symbol file");
Success := False;
return;
elsif Soft_Minor_ID then
Minor_ID := Minor_ID + 1;
Soft_Minor_ID := False;
end if;
Symbol_Table.Append (Original_Symbols, S_Data);
Complete_Symbols.Table (Index).Present := False;
end if;
end loop;
-- Create the symbol file
Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all);
Put (File, Case_Sensitive);
Put_Line (File, "yes");
-- Put a line in the symbol file for each symbol in symbol table
for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop
if Original_Symbols.Table (Index).Present then
Put (File, Symbol_Vector);
-- Split the line if symbol name length is too large
if Original_Symbols.Table (Index).Name'Length >
Long_Symbol_Length
then
Put_Line (File, "-");
end if;
Put (File, Original_Symbols.Table (Index).Name.all);
if Original_Symbols.Table (Index).Name'Length >
Long_Symbol_Length
then
Put_Line (File, "-");
end if;
if Original_Symbols.Table (Index).Kind = Data then
Put_Line (File, Equal_Data);
else
Put_Line (File, Equal_Procedure);
end if;
Free (Original_Symbols.Table (Index).Name);
end if;
end loop;
Put (File, Case_Sensitive);
Put_Line (File, "NO");
-- Put the version IDs
Put (File, Gsmatch_Lequal);
Put (File, Image (Major_ID));
Put (File, ',');
Put_Line (File, Image (Minor_ID));
-- And we are done
Close (File);
-- Reset both tables
Symbol_Table.Set_Last (Original_Symbols, 0);
Symbol_Table.Set_Last (Complete_Symbols, 0);
-- Clear the symbol file name
Free (Symbol_File_Name);
end if;
Success := True;
end if;
exception
when X : others =>
Put_Line ("unexpected exception raised while finalizing """
& Symbol_File_Name.all & """");
Put_Line (Exception_Information (X));
Success := False;
end Finalize;
end Symbols;

257
gcc/ada/system-vms-ia64.ads
View File

@ -1,257 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M --
-- --
-- S p e c --
-- (OpenVMS 64bit Itanium GCC_ZCX DEC Threads Version) --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package System is
pragma Pure;
-- Note that we take advantage of the implementation permission to make
-- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
-- 2005, this is Pure in any case (AI-362).
type Name is (SYSTEM_NAME_GNAT);
System_Name : constant Name := SYSTEM_NAME_GNAT;
-- System-Dependent Named Numbers
Min_Int : constant := Long_Long_Integer'First;
Max_Int : constant := Long_Long_Integer'Last;
Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
-- Storage-related Declarations
type Address is new Long_Integer;
Null_Address : constant Address;
-- Although this is declared as an integer type, no arithmetic operations
-- are available (see abstract declarations below), and furthermore there
-- is special processing in the compiler that prevents the use of integer
-- literals with this type (use To_Address to convert integer literals).
--
-- Conversion to and from Short_Address is however freely permitted, and
-- is indeed the reason that Address is declared as an integer type.
Storage_Unit : constant := 8;
Word_Size : constant := 64;
Memory_Size : constant := 2 ** 64;
-- Address comparison
function "<" (Left, Right : Address) return Boolean;
function "<=" (Left, Right : Address) return Boolean;
function ">" (Left, Right : Address) return Boolean;
function ">=" (Left, Right : Address) return Boolean;
function "=" (Left, Right : Address) return Boolean;
pragma Import (Intrinsic, "<");
pragma Import (Intrinsic, "<=");
pragma Import (Intrinsic, ">");
pragma Import (Intrinsic, ">=");
pragma Import (Intrinsic, "=");
-- Abstract declarations for arithmetic operations on type address.
-- These declarations are needed when Address is non-private. They
-- avoid excessive visibility of arithmetic operations on address
-- which are typically available elsewhere (e.g. Storage_Elements)
-- and which would cause excessive ambiguities in application code.
function "+" (Left, Right : Address) return Address is abstract;
function "-" (Left, Right : Address) return Address is abstract;
function "/" (Left, Right : Address) return Address is abstract;
function "*" (Left, Right : Address) return Address is abstract;
function "mod" (Left, Right : Address) return Address is abstract;
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
Default_Bit_Order : constant Bit_Order := Low_Order_First;
pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-- Priority-related Declarations (RM D.1)
Max_Priority : constant Positive := 30;
Max_Interrupt_Priority : constant Positive := 31;
subtype Any_Priority is Integer range 0 .. 31;
subtype Priority is Any_Priority range 0 .. 30;
subtype Interrupt_Priority is Any_Priority range 31 .. 31;
Default_Priority : constant Priority := 15;
private
Null_Address : constant Address := 0;
--------------------------------------
-- System Implementation Parameters --
--------------------------------------
-- These parameters provide information about the target that is used
-- by the compiler. They are in the private part of System, where they
-- can be accessed using the special circuitry in the Targparm unit
-- whose source should be consulted for more detailed descriptions
-- of the individual switch values.
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := True;
Command_Line_Args : constant Boolean := True;
Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := True;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := True;
VAX_Float : constant Boolean := False;
Preallocated_Stacks : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := True;
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
Support_Atomic_Primitives : constant Boolean := True;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
Always_Compatible_Rep : constant Boolean := True;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := True;
--------------------------
-- Underlying Priorities --
---------------------------
-- Important note: this section of the file must come AFTER the
-- definition of the system implementation parameters to ensure
-- that the value of these parameters is available for analysis
-- of the declarations here (using Rtsfind at compile time).
-- The underlying priorities table provides a generalized mechanism
-- for mapping from Ada priorities to system priorities. In some
-- cases a 1-1 mapping is not the convenient or optimal choice.
-- For DEC Threads OpenVMS, we use the full range of 31 priorities
-- in the Ada model, but map them by compression onto the more limited
-- range of priorities available in OpenVMS.
-- To replace the default values of the Underlying_Priorities mapping,
-- copy this source file into your build directory, edit the file to
-- reflect your desired behavior, and recompile with the command:
-- $ gcc -c -O3 -gnatpgn system.ads
-- then recompile the run-time parts that depend on this package:
-- $ gnatmake -a -gnatn -O3 <your application>
-- then force rebuilding your application if you need different options:
-- $ gnatmake -f <your options> <your application>
type Priorities_Mapping is array (Any_Priority) of Integer;
pragma Suppress_Initialization (Priorities_Mapping);
-- Suppress initialization in case gnat.adc specifies Normalize_Scalars
Underlying_Priorities : constant Priorities_Mapping :=
(Priority'First => 16,
1 => 17,
2 => 18,
3 => 18,
4 => 18,
5 => 18,
6 => 19,
7 => 19,
8 => 19,
9 => 20,
10 => 20,
11 => 21,
12 => 21,
13 => 22,
14 => 23,
Default_Priority => 24,
16 => 25,
17 => 25,
18 => 25,
19 => 26,
20 => 26,
21 => 26,
22 => 27,
23 => 27,
24 => 27,
25 => 28,
26 => 28,
27 => 29,
28 => 29,
29 => 30,
Priority'Last => 30,
Interrupt_Priority => 31);
----------------------------
-- Special VMS Interfaces --
----------------------------
procedure Lib_Stop (Cond_Value : Integer);
pragma Import (C, Lib_Stop);
pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value));
-- Interface to VMS condition handling. Used by RTSfind and pragma
-- {Import,Export}_Exception. Put here because this is the only
-- VMS specific package that doesn't drag in tasking.
ADA_GNAT : constant Boolean := True;
pragma Export_Object (ADA_GNAT, "ADA$GNAT");
-- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug.
-- Do not remove.
pragma Ident ("GNAT"); -- Gnat_Static_Version_String
-- Default ident for all VMS images.
end System;

257
gcc/ada/system-vms_64.ads
View File

@ -1,257 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M --
-- --
-- S p e c --
-- (OpenVMS 64bit GCC_ZCX DEC Threads Version) --
-- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package System is
pragma Pure;
-- Note that we take advantage of the implementation permission to make
-- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
-- 2005, this is Pure in any case (AI-362).
type Name is (SYSTEM_NAME_GNAT);
System_Name : constant Name := SYSTEM_NAME_GNAT;
-- System-Dependent Named Numbers
Min_Int : constant := Long_Long_Integer'First;
Max_Int : constant := Long_Long_Integer'Last;
Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := 0.01;
-- Storage-related Declarations
type Address is new Long_Integer;
Null_Address : constant Address;
-- Although this is declared as an integer type, no arithmetic operations
-- are available (see abstract declarations below), and furthermore there
-- is special processing in the compiler that prevents the use of integer
-- literals with this type (use To_Address to convert integer literals).
--
-- Conversion to and from Short_Address is however freely permitted, and
-- is indeed the reason that Address is declared as an integer type.
Storage_Unit : constant := 8;
Word_Size : constant := 64;
Memory_Size : constant := 2 ** 64;
-- Address comparison
function "<" (Left, Right : Address) return Boolean;
function "<=" (Left, Right : Address) return Boolean;
function ">" (Left, Right : Address) return Boolean;
function ">=" (Left, Right : Address) return Boolean;
function "=" (Left, Right : Address) return Boolean;
pragma Import (Intrinsic, "<");
pragma Import (Intrinsic, "<=");
pragma Import (Intrinsic, ">");
pragma Import (Intrinsic, ">=");
pragma Import (Intrinsic, "=");
-- Abstract declarations for arithmetic operations on type address.
-- These declarations are needed when Address is non-private. They
-- avoid excessive visibility of arithmetic operations on address
-- which are typically available elsewhere (e.g. Storage_Elements)
-- and which would cause excessive ambiguities in application code.
function "+" (Left, Right : Address) return Address is abstract;
function "-" (Left, Right : Address) return Address is abstract;
function "/" (Left, Right : Address) return Address is abstract;
function "*" (Left, Right : Address) return Address is abstract;
function "mod" (Left, Right : Address) return Address is abstract;
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
Default_Bit_Order : constant Bit_Order := Low_Order_First;
pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-- Priority-related Declarations (RM D.1)
Max_Priority : constant Positive := 30;
Max_Interrupt_Priority : constant Positive := 31;
subtype Any_Priority is Integer range 0 .. 31;
subtype Priority is Any_Priority range 0 .. 30;
subtype Interrupt_Priority is Any_Priority range 31 .. 31;
Default_Priority : constant Priority := 15;
private
Null_Address : constant Address := 0;
--------------------------------------
-- System Implementation Parameters --
--------------------------------------
-- These parameters provide information about the target that is used
-- by the compiler. They are in the private part of System, where they
-- can be accessed using the special circuitry in the Targparm unit
-- whose source should be consulted for more detailed descriptions
-- of the individual switch values.
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := True;
Command_Line_Args : constant Boolean := True;
Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := False;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := True;
VAX_Float : constant Boolean := False;
Preallocated_Stacks : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := True;
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
Support_Atomic_Primitives : constant Boolean := True;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
Always_Compatible_Rep : constant Boolean := True;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := True;
--------------------------
-- Underlying Priorities --
---------------------------
-- Important note: this section of the file must come AFTER the
-- definition of the system implementation parameters to ensure
-- that the value of these parameters is available for analysis
-- of the declarations here (using Rtsfind at compile time).
-- The underlying priorities table provides a generalized mechanism
-- for mapping from Ada priorities to system priorities. In some
-- cases a 1-1 mapping is not the convenient or optimal choice.
-- For DEC Threads OpenVMS, we use the full range of 31 priorities
-- in the Ada model, but map them by compression onto the more limited
-- range of priorities available in OpenVMS.
-- To replace the default values of the Underlying_Priorities mapping,
-- copy this source file into your build directory, edit the file to
-- reflect your desired behavior, and recompile with the command:
-- $ gcc -c -O3 -gnatpgn system.ads
-- then recompile the run-time parts that depend on this package:
-- $ gnatmake -a -gnatn -O3 <your application>
-- then force rebuilding your application if you need different options:
-- $ gnatmake -f <your options> <your application>
type Priorities_Mapping is array (Any_Priority) of Integer;
pragma Suppress_Initialization (Priorities_Mapping);
-- Suppress initialization in case gnat.adc specifies Normalize_Scalars
Underlying_Priorities : constant Priorities_Mapping :=
(Priority'First => 16,
1 => 17,
2 => 18,
3 => 18,
4 => 18,
5 => 18,
6 => 19,
7 => 19,
8 => 19,
9 => 20,
10 => 20,
11 => 21,
12 => 21,
13 => 22,
14 => 23,
Default_Priority => 24,
16 => 25,
17 => 25,
18 => 25,
19 => 26,
20 => 26,
21 => 26,
22 => 27,
23 => 27,
24 => 27,
25 => 28,
26 => 28,
27 => 29,
28 => 29,
29 => 30,
Priority'Last => 30,
Interrupt_Priority => 31);
----------------------------
-- Special VMS Interfaces --
----------------------------
procedure Lib_Stop (Cond_Value : Integer);
pragma Import (C, Lib_Stop);
pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value));
-- Interface to VMS condition handling. Used by RTSfind and pragma
-- {Import,Export}_Exception. Put here because this is the only
-- VMS specific package that doesn't drag in tasking.
ADA_GNAT : constant Boolean := True;
pragma Export_Object (ADA_GNAT, "ADA$GNAT");
-- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug.
-- Do not remove.
pragma Ident ("GNAT"); -- Gnat_Static_Version_String
-- Default ident for all VMS images.
end System;