Skip to content

R
riscv-gcc-1
Commit 90376fad by Arnaud Charlet Committed by Arnaud Charlet
Options

a-numaux-vms.ads, [...]: New files. 

2011-12-15  Arnaud Charlet  <charlet@adacore.com>

        * a-numaux-vms.ads, s-asthan-vms-ia64.adb, s-auxdec-vms-ia64.adb,       
        s-memory-vms_64.adb, s-memory-vms_64.ads, s-osinte-vms-ia64.adb,
        s-osinte-vms-ia64.ads, s-tasdeb-vms.adb: New files.

From-SVN: r182374
parent 0c5c7b00
Showing with 527 additions and 0 deletions
gcc/ada/ChangeLog
2011-12-15 Arnaud Charlet <charlet@adacore.com>
* a-numaux-vms.ads, s-asthan-vms-ia64.adb, s-auxdec-vms-ia64.adb,
s-memory-vms_64.adb, s-memory-vms_64.ads, s-osinte-vms-ia64.adb,
s-osinte-vms-ia64.ads, s-tasdeb-vms.adb: New files.
2011-12-15 Vincent Pucci <pucci@adacore.com>
* aspects.adb, aspects.ads Aspect_Dimension and
......
gcc/ada/a-numaux-vms.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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-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. --
-- --
-- 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;
gcc/ada/s-memory-vms_64.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . M E M O R Y --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-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. --
-- --
-- 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;
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;
gcc/ada/s-memory-vms_64.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . M E M O R Y --
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-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. --
-- --
-- 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;
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;
gcc/ada/s-osinte-vms-ia64.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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) 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. --
-- --
-- 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/IA64 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;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment