Skip to content

R
riscv-gcc-1
Commit cacbc350 by Richard Kenner
Options

New Language: Ada 

From-SVN: r45957
parent 19235870
Showing with 4933 additions and 0 deletions
gcc/ada/s-addima.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . A D D R E S S _ I M A G E --
-- --
-- B o d y --
-- --
-- $Revision: 1.6 $ --
-- --
-- Copyright (C) 1992,1993,1994,1995,1996 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Unchecked_Conversion;
function System.Address_Image (A : Address) return String is
Result : String (1 .. 2 * Address'Size / Storage_Unit);
type Byte is mod 2 ** 8;
for Byte'Size use 8;
Hexdigs :
constant array (Byte range 0 .. 15) of Character := "0123456789ABCDEF";
type Bytes is array (1 .. Address'Size / Storage_Unit) of Byte;
for Bytes'Size use Address'Size;
function To_Bytes is new Unchecked_Conversion (Address, Bytes);
Byte_Sequence : constant Bytes := To_Bytes (A);
LE : constant := Standard'Default_Bit_Order;
BE : constant := 1 - LE;
-- Set to 1/0 for True/False for Little-Endian/Big-Endian
Start : constant Natural := BE * (1) + LE * (Bytes'Length);
Incr : constant Integer := BE * (1) + LE * (-1);
-- Start and increment for accessing characters of address string
Ptr : Natural;
-- Scan address string
begin
Ptr := Start;
for N in Bytes'Range loop
Result (2 * N - 1) := Hexdigs (Byte_Sequence (Ptr) / 16);
Result (2 * N) := Hexdigs (Byte_Sequence (Ptr) mod 16);
Ptr := Ptr + Incr;
end loop;
return Result;
end System.Address_Image;
gcc/ada/s-addima.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . A D D R E S S _ I M A G E --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This is a GNAT specific addition which provides a useful debugging
-- procedure that gives an (implementation dependent) string which
-- identifies an address.
function System.Address_Image (A : Address) return String;
pragma Pure (System.Address_Image);
-- Returns string (hexadecimal digits with upper case letters) representing
-- the address (string is 8/16 bytes for 32/64-bit machines).
gcc/ada/s-arit64.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . A R I T H _ 6 4 --
-- --
-- S p e c --
-- --
-- $Revision: 1.7 $ --
-- --
-- Copyright (C) 1994,1995,1996 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This unit provides software routines for doing arithmetic on 64-bit
-- signed integer values in cases where either overflow checking is
-- required, or intermediate results are longer than 64 bits.
with Interfaces;
package System.Arith_64 is
pragma Pure (Arith_64);
subtype Int64 is Interfaces.Integer_64;
function Add_With_Ovflo_Check (X, Y : Int64) return Int64;
-- Raises Constraint_Error if sum of operands overflows 64 bits,
-- otherwise returns the 64-bit signed integer sum.
function Subtract_With_Ovflo_Check (X, Y : Int64) return Int64;
-- Raises Constraint_Error if difference of operands overflows 64
-- bits, otherwise returns the 64-bit signed integer difference.
function Multiply_With_Ovflo_Check (X, Y : Int64) return Int64;
-- Raises Constraint_Error if product of operands overflows 64
-- bits, otherwise returns the 64-bit signed integer difference.
procedure Scaled_Divide
(X, Y, Z : Int64;
Q, R : out Int64;
Round : Boolean);
-- Performs the division of (X * Y) / Z, storing the quotient in Q
-- and the remainder in R. Constraint_Error is raised if Z is zero,
-- or if the quotient does not fit in 64-bits. Round indicates if
-- the result should be rounded. If Round is False, then Q, R are
-- the normal quotient and remainder from a truncating division.
-- If Round is True, then Q is the rounded quotient. the remainder
-- R is not affected by the setting of the Round flag.
procedure Double_Divide
(X, Y, Z : Int64;
Q, R : out Int64;
Round : Boolean);
-- Performs the division X / (Y * Z), storing the quotient in Q and
-- the remainder in R. Constraint_Error is raised if Y or Z is zero.
-- Round indicates if the result should be rounded. If Round is False,
-- then Q, R are the normal quotient and remainder from a truncating
-- division. If Round is True, then Q is the rounded quotient. The
-- remainder R is not affected by the setting of the Round flag. The
-- result is known to be in range except for the noted possibility of
-- Y or Z being zero, so no other overflow checks are required.
end System.Arith_64;
gcc/ada/s-assert.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . A S S E R T I O N S --
-- --
-- B o d y --
-- --
-- $Revision: 1.6 $ --
-- --
-- Copyright (C) 1992-1997 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Exceptions;
package body System.Assertions is
--------------------------
-- Raise_Assert_Failure --
--------------------------
procedure Raise_Assert_Failure (Msg : String) is
begin
Ada.Exceptions.Raise_Exception (Assert_Failure'Identity, Msg);
end Raise_Assert_Failure;
end System.Assertions;
gcc/ada/s-assert.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . A S S E R T I O N S --
-- --
-- S p e c --
-- --
-- $Revision: 1.11 $ --
-- --
-- Copyright (C) 1992-1998 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package System.Assertions is
Assert_Failure : exception;
-- Exception raised when assertion fails
procedure Raise_Assert_Failure (Msg : String);
pragma No_Return (Raise_Assert_Failure);
-- Called to raise Assert_Failure with given message
end System.Assertions;
gcc/ada/s-asthan.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNT-TIME COMPONENTS --
-- --
-- S Y S T E M . A S T _ H A N D L I N G --
-- --
-- B o d y --
-- --
-- $Revision: 1.5 $ --
-- --
-- Copyright (C) 1996-1998 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This is the dummy version used on non-VMS systems
with Ada.Exceptions;
with Ada.Task_Identification;
with System.Aux_DEC;
package body System.AST_Handling is
------------------------
-- Create_AST_Handler --
------------------------
function Create_AST_Handler
(Taskid : Ada.Task_Identification.Task_Id;
Entryno : Natural)
return System.Aux_DEC.AST_Handler
is
begin
Ada.Exceptions.Raise_Exception
(E => Program_Error'Identity,
Message => "AST is implemented only on VMS systems");
return System.Aux_DEC.No_AST_Handler;
end Create_AST_Handler;
procedure Expand_AST_Packet_Pool
(Requested_Packets : in Natural;
Actual_Number : out Natural;
Total_Number : out Natural)
is
begin
Ada.Exceptions.Raise_Exception
(E => Program_Error'Identity,
Message => "AST is implemented only on VMS systems");
Actual_Number := 0;
Total_Number := 0;
end Expand_AST_Packet_Pool;
end System.AST_Handling;
gcc/ada/s-asthan.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . A S T _ H A N D L I N G --
-- --
-- S p e c --
-- --
-- $Revision: 1.4 $ --
-- --
-- Copyright (C) 1996 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Runtime support for Handling of AST's (Used on VMS implementations only)
with Ada.Task_Identification;
with System;
with System.Aux_DEC;
package System.AST_Handling is
function Create_AST_Handler
(Taskid : Ada.Task_Identification.Task_Id;
Entryno : Natural)
return System.Aux_DEC.AST_Handler;
-- This function implements the appropriate semantics for a use of the
-- AST_Entry pragma. See body for details of implementation approach.
-- The parameters are the Task_Id for the task containing the entry
-- and the entry Index for the specified entry.
procedure Expand_AST_Packet_Pool
(Requested_Packets : in Natural;
Actual_Number : out Natural;
Total_Number : out Natural);
-- This function takes a request for zero or more extra AST packets and
-- returns the number actually added to the pool and the total number
-- now available or in use.
-- This function is not yet fully implemented.
end System.AST_Handling;
gcc/ada/s-atacco.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . A D D R E S S _ T O _ A C C E S S _ C O N V E R S I O N S --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Unchecked_Conversion;
package body System.Address_To_Access_Conversions is
----------------
-- To_Address --
----------------
function To_Address (Value : Object_Pointer) return Address is
begin
if Value = null then
return Null_Address;
else
return Value.all'Address;
end if;
end To_Address;
----------------
-- To_Pointer --
----------------
function To_Pointer (Value : Address) return Object_Pointer is
function A_To_P is new Unchecked_Conversion (Address, Object_Pointer);
begin
return A_To_P (Value);
end To_Pointer;
end System.Address_To_Access_Conversions;
gcc/ada/s-atacco.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . A D D R E S S _ T O _ A C C E S S _ C O N V E R S I O N S --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- This specification is adapted from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
generic
type Object (<>) is limited private;
package System.Address_To_Access_Conversions is
pragma Preelaborate (Address_To_Access_Conversions);
type Object_Pointer is access all Object;
for Object_Pointer'Size use Standard'Address_Size;
function To_Pointer (Value : Address) return Object_Pointer;
function To_Address (Value : Object_Pointer) return Address;
pragma Convention (Intrinsic, To_Pointer);
pragma Convention (Intrinsic, To_Address);
end System.Address_To_Access_Conversions;
gcc/ada/s-bitops.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . B I T _ O P S --
-- --
-- B o d y --
-- --
-- $Revision: 1.10 $
-- --
-- Copyright (C) 1996-2000 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with GNAT.Exceptions; use GNAT.Exceptions;
with System; use System;
with System.Unsigned_Types; use System.Unsigned_Types;
with Unchecked_Conversion;
package body System.Bit_Ops is
subtype Bits_Array is System.Unsigned_Types.Packed_Bytes1 (Positive);
-- Unconstrained array used to interprete the address values. We use the
-- unaligned version always, since this will handle both the aligned and
-- unaligned cases, and we always do these operations by bytes anyway.
-- Note: we use a ones origin array here so that the computations of the
-- length in bytes work correctly (give a non-negative value) for the
-- case of zero length bit strings).
type Bits is access Bits_Array;
-- This is the actual type into which address values are converted
function To_Bits is new Unchecked_Conversion (Address, Bits);
LE : constant := Standard'Default_Bit_Order;
-- Static constant set to 0 for big-endian, 1 for little-endian
-- The following is an array of masks used to mask the final byte, either
-- at the high end (big-endian case) or the low end (little-endian case).
Masks : constant array (1 .. 7) of Packed_Byte := (
(1 - LE) * 2#1000_0000# + LE * 2#0000_0001#,
(1 - LE) * 2#1100_0000# + LE * 2#0000_0011#,
(1 - LE) * 2#1110_0000# + LE * 2#0000_0111#,
(1 - LE) * 2#1111_0000# + LE * 2#0000_1111#,
(1 - LE) * 2#1111_1000# + LE * 2#0001_1111#,
(1 - LE) * 2#1111_1100# + LE * 2#0011_1111#,
(1 - LE) * 2#1111_1110# + LE * 2#0111_1111#);
-----------------------
-- Local Subprograms --
-----------------------
procedure Raise_Error;
-- Raise Constraint_Error, complaining about unequal lengths
-------------
-- Bit_And --
-------------
procedure Bit_And
(Left : Address;
Llen : Natural;
Right : Address;
Rlen : Natural;
Result : Address)
is
LeftB : constant Bits := To_Bits (Left);
RightB : constant Bits := To_Bits (Right);
ResultB : constant Bits := To_Bits (Result);
begin
if Llen /= Rlen then
Raise_Error;
end if;
for J in 1 .. (Rlen + 7) / 8 loop
ResultB (J) := LeftB (J) and RightB (J);
end loop;
end Bit_And;
------------
-- Bit_Eq --
------------
function Bit_Eq
(Left : Address;
Llen : Natural;
Right : Address;
Rlen : Natural)
return Boolean
is
LeftB : constant Bits := To_Bits (Left);
RightB : constant Bits := To_Bits (Right);
begin
if Llen /= Rlen then
return False;
else
declare
BLen : constant Natural := Llen / 8;
Bitc : constant Natural := Llen mod 8;
begin
if Llen /= Rlen then
return False;
elsif LeftB (1 .. BLen) /= RightB (1 .. BLen) then
return False;
elsif Bitc /= 0 then
return
((LeftB (BLen + 1) xor RightB (BLen + 1))
and Masks (Bitc)) = 0;
else -- Bitc = 0
return True;
end if;
end;
end if;
end Bit_Eq;
-------------
-- Bit_Not --
-------------
procedure Bit_Not
(Opnd : System.Address;
Len : Natural;
Result : System.Address)
is
OpndB : constant Bits := To_Bits (Opnd);
ResultB : constant Bits := To_Bits (Result);
begin
for J in 1 .. (Len + 7) / 8 loop
ResultB (J) := not OpndB (J);
end loop;
end Bit_Not;
------------
-- Bit_Or --
------------
procedure Bit_Or
(Left : Address;
Llen : Natural;
Right : Address;
Rlen : Natural;
Result : Address)
is
LeftB : constant Bits := To_Bits (Left);
RightB : constant Bits := To_Bits (Right);
ResultB : constant Bits := To_Bits (Result);
begin
if Llen /= Rlen then
Raise_Error;
end if;
for J in 1 .. (Rlen + 7) / 8 loop
ResultB (J) := LeftB (J) or RightB (J);
end loop;
end Bit_Or;
-------------
-- Bit_Xor --
-------------
procedure Bit_Xor
(Left : Address;
Llen : Natural;
Right : Address;
Rlen : Natural;
Result : Address)
is
LeftB : constant Bits := To_Bits (Left);
RightB : constant Bits := To_Bits (Right);
ResultB : constant Bits := To_Bits (Result);
begin
if Llen /= Rlen then
Raise_Error;
end if;
for J in 1 .. (Rlen + 7) / 8 loop
ResultB (J) := LeftB (J) xor RightB (J);
end loop;
end Bit_Xor;
-----------------
-- Raise_Error --
-----------------
procedure Raise_Error is
begin
Raise_Exception (CE, "unequal lengths in logical operation");
end Raise_Error;
end System.Bit_Ops;
gcc/ada/s-bitops.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . B I T _ O P S --
-- --
-- S p e c --
-- --
-- $Revision: 1.6 $
-- --
-- Copyright (C) 1992-1999, 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Operations on packed bit strings
with System;
package System.Bit_Ops is
-- Note: in all the following routines, the System.Address parameters
-- represent the address of the first byte of an array used to represent
-- a packed array (of type System.Unsigned_Types.Packed_Bytes{1,2,4})
-- The length in bits is passed as a separate parameter.
procedure Bit_And
(Left : System.Address;
Llen : Natural;
Right : Address;
Rlen : Natural;
Result : System.Address);
-- Bitwise "and" of given bit string with result being placed in Result.
-- The or operation is allowed to destroy unused bits in the last byte,
-- i.e. to leave them set in an undefined manner. Note that Left, Right
-- and Result always have the same length in bits (Len).
function Bit_Eq
(Left : System.Address;
Llen : Natural;
Right : System.Address;
Rlen : Natural)
return Boolean;
-- Left and Right are the addresses of two bit packed arrays with Llen
-- and Rlen being the respective length in bits. The routine compares the
-- two bit strings for equality, being careful not to include the unused
-- bits in the final byte. Note that the result is always False if Rlen
-- is not equal to Llen.
procedure Bit_Not
(Opnd : System.Address;
Len : Natural;
Result : System.Address);
-- Bitwise "not" of given bit string with result being placed in Result.
-- The not operation is allowed to destroy unused bits in the last byte,
-- i.e. to leave them set in an undefined manner. Note that Result and
-- Opnd always have the same length in bits (Len).
procedure Bit_Or
(Left : System.Address;
Llen : Natural;
Right : Address;
Rlen : Natural;
Result : System.Address);
-- Bitwise "or" of given bit string with result being placed in Result.
-- The or operation is allowed to destroy unused bits in the last byte,
-- i.e. to leave them set in an undefined manner. Note that Left, Right
-- and Result always have the same length in bits (Len).
procedure Bit_Xor
(Left : System.Address;
Llen : Natural;
Right : Address;
Rlen : Natural;
Result : System.Address);
-- Bitwise "xor" of given bit string with result being placed in Result.
-- The or operation is allowed to destroy unused bits in the last byte,
-- i.e. to leave them set in an undefined manner. Note that Left, Right
-- and Result always have the same length in bits (Len).
end System.Bit_Ops;
gcc/ada/s-chepoo.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . C H E C K E D _ P O O L S --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $ --
-- --
-- Copyright (C) 1992,1993,1994,1995,1996 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System.Storage_Elements;
with System.Storage_Pools;
package System.Checked_Pools is
type Checked_Pool is abstract
new System.Storage_Pools.Root_Storage_Pool with private;
-- Equivalent of storage pools with the addition that Dereference is
-- called on each implicit or explicit dereference of a pointer which
-- has such a storage pool
procedure Allocate
(Pool : in out Checked_Pool;
Storage_Address : out Address;
Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
Alignment : in System.Storage_Elements.Storage_Count)
is abstract;
procedure Deallocate
(Pool : in out Checked_Pool;
Storage_Address : in Address;
Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
Alignment : in System.Storage_Elements.Storage_Count)
is abstract;
function Storage_Size
(Pool : Checked_Pool)
return System.Storage_Elements.Storage_Count
is abstract;
procedure Dereference
(Pool : in out Checked_Pool;
Storage_Address : in Address;
Size_In_Storage_Elements : in System.Storage_Elements.Storage_Count;
Alignment : in System.Storage_Elements.Storage_Count)
is abstract;
-- Called each time a pointer to a checked pool is dereferenced
private
type Checked_Pool is abstract
new System.Storage_Pools.Root_Storage_Pool with null record;
end System.Checked_Pools;
gcc/ada/s-direio.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . D I R E C T _ I O --
-- --
-- S p e c --
-- --
-- $Revision: 1.10 $ --
-- --
-- Copyright (C) 1992,1993,1994,1995,1996 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package contains the declaration of the control block used for
-- Direct_IO. This must be declared at the outer library level. It also
-- contains code that is shared between instances of Direct_IO.
with Interfaces.C_Streams;
with Ada.Streams;
with System.File_Control_Block;
with System.Storage_Elements;
package System.Direct_IO is
package FCB renames System.File_Control_Block;
type Operation is (Op_Read, Op_Write, Op_Other);
-- Type used to record last operation (to optimize sequential operations)
subtype Count is Interfaces.C_Streams.long;
-- The Count type in each instantiation is derived from this type
subtype Positive_Count is Count range 1 .. Count'Last;
type Direct_AFCB is new FCB.AFCB with record
Index : Count := 1;
-- Current Index value
Bytes : Interfaces.C_Streams.size_t;
-- Length of item in bytes (set from inside generic template)
Last_Op : Operation := Op_Other;
-- Last operation performed on file, used to avoid unnecessary
-- repositioning between successive read or write operations.
end record;
function AFCB_Allocate (Control_Block : Direct_AFCB) return FCB.AFCB_Ptr;
procedure AFCB_Close (File : access Direct_AFCB);
procedure AFCB_Free (File : access Direct_AFCB);
procedure Read
(File : in out Direct_AFCB;
Item : out Ada.Streams.Stream_Element_Array;
Last : out Ada.Streams.Stream_Element_Offset);
-- Required overriding of Read, not actually used for Direct_IO
procedure Write
(File : in out Direct_AFCB;
Item : in Ada.Streams.Stream_Element_Array);
-- Required overriding of Write, not actually used for Direct_IO
type File_Type is access all Direct_AFCB;
-- File_Type in individual instantiations is derived from this type
procedure Create
(File : in out File_Type;
Mode : in FCB.File_Mode := FCB.Inout_File;
Name : in String := "";
Form : in String := "");
function End_Of_File (File : in File_Type) return Boolean;
function Index (File : in File_Type) return Positive_Count;
procedure Open
(File : in out File_Type;
Mode : in FCB.File_Mode;
Name : in String;
Form : in String := "");
procedure Read
(File : in File_Type;
Item : System.Address;
Size : in Interfaces.C_Streams.size_t;
From : in Positive_Count);
procedure Read
(File : in File_Type;
Item : System.Address;
Size : in Interfaces.C_Streams.size_t);
procedure Reset (File : in out File_Type; Mode : in FCB.File_Mode);
procedure Reset (File : in out File_Type);
procedure Set_Index (File : in File_Type; To : in Positive_Count);
function Size (File : in File_Type) return Count;
procedure Write
(File : in File_Type;
Item : System.Address;
Size : in Interfaces.C_Streams.size_t;
Zeroes : System.Storage_Elements.Storage_Array);
-- Note: Zeroes is the buffer of zeroes used to fill out partial records
end System.Direct_IO;
gcc/ada/s-errrep.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . E R R O R _ R E P O R T I N G --
-- --
-- B o d y --
-- --
-- $Revision: 1.14 $ --
-- --
-- Copyright (C) 1991-2000 Florida State University --
-- --
-- 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 2, or (at your option) any later ver- --
-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. It is --
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
-- State University (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package must not depend on anything else, since it may be
-- called during elaboration of other packages.
package body System.Error_Reporting is
procedure Write (fildes : Integer; buf : System.Address; nbyte : Integer);
pragma Import (C, Write, "write");
procedure Prog_Exit (Status : Integer);
pragma No_Return (Prog_Exit);
pragma Import (C, Prog_Exit, "exit");
Shutdown_Message : String := "failed run-time assertion : ";
End_Of_Line : String := "" & ASCII.LF;
--------------
-- Shutdown --
--------------
function Shutdown (M : in String) return Boolean is
begin
Write (2, Shutdown_Message'Address, Shutdown_Message'Length);
Write (2, M'Address, M'Length);
Write (2, End_Of_Line'Address, End_Of_Line'Length);
-- This call should never return
Prog_Exit (1);
-- Return is just to keep Ada happy (return required)
return False;
end Shutdown;
end System.Error_Reporting;
gcc/ada/s-errrep.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . E R R O R _ R E P O R T I N G --
-- --
-- S p e c --
-- --
-- $Revision: 1.11 $ --
-- --
-- Copyright (C) 1991-1998 Florida State University --
-- --
-- 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 2, or (at your option) any later ver- --
-- sion. GNARL 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 GNARL; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNARL was developed by the GNARL team at Florida State University. It is --
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
-- State University (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package must not depend on anything else, since it may be
-- called during elaboration of other packages.
package System.Error_Reporting is
pragma Preelaborate;
function Shutdown (M : in String) return Boolean;
-- Perform emergency shutdown of the entire program.
-- Msg is an error message to be printed to the console.
-- This is to be used only for nonrecoverable errors.
end System.Error_Reporting;
gcc/ada/s-exctab.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . E X C E P T I O N _ T A B L E --
-- --
-- B o d y --
-- --
-- $Revision: 1.14 $
-- --
-- Copyright (C) 1996-2001 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with GNAT.HTable;
package body System.Exception_Table is
use System.Standard_Library;
type HTable_Headers is range 1 .. 37;
procedure Set_HT_Link (T : Exception_Data_Ptr; Next : Exception_Data_Ptr);
function Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr;
function Hash (F : Big_String_Ptr) return HTable_Headers;
function Equal (A, B : Big_String_Ptr) return Boolean;
function Get_Key (T : Exception_Data_Ptr) return Big_String_Ptr;
package Exception_HTable is new GNAT.HTable.Static_HTable (
Header_Num => HTable_Headers,
Element => Exception_Data,
Elmt_Ptr => Exception_Data_Ptr,
Null_Ptr => null,
Set_Next => Set_HT_Link,
Next => Get_HT_Link,
Key => Big_String_Ptr,
Get_Key => Get_Key,
Hash => Hash,
Equal => Equal);
-----------
-- Equal --
-----------
function Equal (A, B : Big_String_Ptr) return Boolean is
J : Integer := 1;
begin
loop
if A (J) /= B (J) then
return False;
elsif A (J) = ASCII.NUL then
return True;
else
J := J + 1;
end if;
end loop;
end Equal;
-----------------
-- Get_HT_Link --
-----------------
function Get_HT_Link (T : Exception_Data_Ptr) return Exception_Data_Ptr is
begin
return T.HTable_Ptr;
end Get_HT_Link;
-------------
-- Get_Key --
-------------
function Get_Key (T : Exception_Data_Ptr) return Big_String_Ptr is
begin
return T.Full_Name;
end Get_Key;
----------
-- Hash --
----------
function Hash (F : Big_String_Ptr) return HTable_Headers is
type S is mod 2**8;
Size : constant S := S (HTable_Headers'Last - HTable_Headers'First + 1);
Tmp : S := 0;
J : Positive;
begin
J := 1;
loop
if F (J) = ASCII.NUL then
return HTable_Headers'First + HTable_Headers'Base (Tmp mod Size);
else
Tmp := Tmp xor S (Character'Pos (F (J)));
end if;
J := J + 1;
end loop;
end Hash;
------------------------
-- Internal_Exception --
------------------------
type String_Ptr is access all String;
function Internal_Exception (X : String) return Exception_Data_Ptr is
Copy : aliased String (X'First .. X'Last + 1);
Res : Exception_Data_Ptr;
Dyn_Copy : String_Ptr;
begin
Copy (X'Range) := X;
Copy (Copy'Last) := ASCII.NUL;
Res := Exception_HTable.Get (To_Ptr (Copy'Address));
-- If unknown exception, create it on the heap. This is a legitimate
-- situation in the distributed case when an exception is defined only
-- in a partition
if Res = null then
Dyn_Copy := new String'(Copy);
Res :=
new Exception_Data'
(Not_Handled_By_Others => False,
Lang => 'A',
Name_Length => Copy'Length,
Full_Name => To_Ptr (Dyn_Copy.all'Address),
HTable_Ptr => null,
Import_Code => 0);
Register_Exception (Res);
end if;
return Res;
end Internal_Exception;
------------------------
-- Register_Exception --
------------------------
procedure Register_Exception (X : Exception_Data_Ptr) is
begin
Exception_HTable.Set (X);
end Register_Exception;
-----------------
-- Set_HT_Link --
-----------------
procedure Set_HT_Link
(T : Exception_Data_Ptr;
Next : Exception_Data_Ptr)
is
begin
T.HTable_Ptr := Next;
end Set_HT_Link;
begin
Register_Exception (Abort_Signal_Def'Access);
Register_Exception (Tasking_Error_Def'Access);
Register_Exception (Storage_Error_Def'Access);
Register_Exception (Program_Error_Def'Access);
Register_Exception (Numeric_Error_Def'Access);
Register_Exception (Constraint_Error_Def'Access);
end System.Exception_Table;
gcc/ada/s-exctab.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . E X C E P T I O N _ T A B L E --
-- --
-- S p e c --
-- --
-- $Revision: 1.4 $
-- --
-- Copyright (C) 1996-1999 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System.Standard_Library;
package System.Exception_Table is
pragma Elaborate_Body;
package SSL renames System.Standard_Library;
procedure Register_Exception (X : SSL.Exception_Data_Ptr);
pragma Inline (Register_Exception);
-- Register an exception in the hash table mapping
function Internal_Exception (X : String) return SSL.Exception_Data_Ptr;
-- Given an exception_name X, returns a pointer to the actual internal
-- exception data.
end System.Exception_Table;
gcc/ada/s-exnflt.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X N _ F L T --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Float exponentiation (checks off)
with System.Exn_Gen;
package System.Exn_Flt is
pragma Pure (Exn_Flt);
function Exn_Float is
new System.Exn_Gen.Exn_Float_Type (Float);
end System.Exn_Flt;
gcc/ada/s-exngen.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X N _ G E N --
-- --
-- B o d y --
-- --
-- $Revision: 1.9 $
-- --
-- Copyright (C) 1992-2001, 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body System.Exn_Gen is
--------------------
-- Exn_Float_Type --
--------------------
function Exn_Float_Type
(Left : Type_Of_Base;
Right : Integer)
return Type_Of_Base
is
pragma Suppress (Division_Check);
pragma Suppress (Overflow_Check);
pragma Suppress (Range_Check);
Result : Type_Of_Base := 1.0;
Factor : Type_Of_Base := Left;
Exp : Integer := Right;
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2. For positive exponents we
-- multiply the result by this factor, for negative exponents, we
-- Division by this factor.
if Exp >= 0 then
loop
if Exp rem 2 /= 0 then
Result := Result * Factor;
end if;
Exp := Exp / 2;
exit when Exp = 0;
Factor := Factor * Factor;
end loop;
return Result;
-- Negative exponent. For a zero base, we should arguably return an
-- infinity of the right sign, but it is not clear that there is
-- proper authorization to do so, so for now raise Constraint_Error???
elsif Factor = 0.0 then
raise Constraint_Error;
-- Here we have a non-zero base and a negative exponent
else
-- For the negative exponent case, a constraint error during this
-- calculation happens if Factor gets too large, and the proper
-- response is to return 0.0, since what we essentially have is
-- 1.0 / infinity, and the closest model number will be zero.
begin
loop
if Exp rem 2 /= 0 then
Result := Result * Factor;
end if;
Exp := Exp / 2;
exit when Exp = 0;
Factor := Factor * Factor;
end loop;
return 1.0 / Result;
exception
when Constraint_Error =>
return 0.0;
end;
end if;
end Exn_Float_Type;
----------------------
-- Exn_Integer_Type --
----------------------
-- Note that negative exponents get a constraint error because the
-- subtype of the Right argument (the exponent) is Natural.
function Exn_Integer_Type
(Left : Type_Of_Base;
Right : Natural)
return Type_Of_Base
is
pragma Suppress (Division_Check);
pragma Suppress (Overflow_Check);
Result : Type_Of_Base := 1;
Factor : Type_Of_Base := Left;
Exp : Natural := Right;
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2.
-- Note: it is not worth special casing the cases of base values -1,0,+1
-- since the expander does this when the base is a literal, and other
-- cases will be extremely rare.
if Exp /= 0 then
loop
if Exp rem 2 /= 0 then
Result := Result * Factor;
end if;
Exp := Exp / 2;
exit when Exp = 0;
Factor := Factor * Factor;
end loop;
end if;
return Result;
end Exn_Integer_Type;
end System.Exn_Gen;
gcc/ada/s-exngen.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X N _ G E N --
-- --
-- S p e c --
-- --
-- $Revision: 1.6 $ --
-- --
-- Copyright (C) 1992,1993,1994,1995 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package contains the generic functions which are instantiated with
-- predefined integer and real types to generate the runtime exponentiation
-- functions called by expanded code generated by Expand_Op_Expon. This
-- version of the package contains routines that are compiled with overflow
-- checks suppressed, so they are called for exponentiation operations which
-- do not require overflow checking
package System.Exn_Gen is
pragma Pure (System.Exn_Gen);
-- Exponentiation for float types (checks off)
generic
type Type_Of_Base is digits <>;
function Exn_Float_Type
(Left : Type_Of_Base;
Right : Integer)
return Type_Of_Base;
-- Exponentiation for signed integer base
generic
type Type_Of_Base is range <>;
function Exn_Integer_Type
(Left : Type_Of_Base;
Right : Natural)
return Type_Of_Base;
end System.Exn_Gen;
gcc/ada/s-exnint.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X N _ I N T --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- Copyright (C) 1992,1993 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Integer exponentiation (checks off)
with System.Exn_Gen;
package System.Exn_Int is
pragma Pure (Exn_Int);
function Exn_Integer is
new System.Exn_Gen.Exn_Integer_Type (Integer);
end System.Exn_Int;
gcc/ada/s-exnlfl.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X N _ L F L T --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Long_Float exponentiation (checks on)
with System.Exn_Gen;
package System.Exn_LFlt is
pragma Pure (Exn_LFlt);
function Exn_Long_Float is
new System.Exn_Gen.Exn_Float_Type (Long_Float);
end System.Exn_LFlt;
gcc/ada/s-exnlin.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X N _ L I N T --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Long_Integer exponentiation (checks off)
with System.Exn_Gen;
package System.Exn_LInt is
pragma Pure (Exn_LInt);
function Exn_Long_Integer is
new System.Exn_Gen.Exn_Integer_Type (Long_Integer);
end System.Exn_LInt;
gcc/ada/s-exnllf.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X N _ L L F --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Long_Long_Float exponentiation (checks off)
with System.Exn_Gen;
package System.Exn_LLF is
pragma Pure (Exn_LLF);
function Exn_Long_Long_Float is
new System.Exn_Gen.Exn_Float_Type (Long_Long_Float);
end System.Exn_LLF;
gcc/ada/s-exnlli.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X N _ L L I --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- Copyright (C) 1992,1993 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Long_Long_Integer exponentiation (checks off)
with System.Exn_Gen;
package System.Exn_LLI is
pragma Pure (Exn_LLI);
function Exn_Long_Long_Integer is
new System.Exn_Gen.Exn_Integer_Type (Long_Long_Integer);
end System.Exn_LLI;
gcc/ada/s-exnsfl.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X N _ S F L T --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Short_Float exponentiation (checks off)
with System.Exn_Gen;
package System.Exn_SFlt is
pragma Pure (Exn_SFlt);
function Exn_Short_Float is
new System.Exn_Gen.Exn_Float_Type (Short_Float);
end System.Exn_SFlt;
gcc/ada/s-exnsin.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X N _ S I N T --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Short_Integer exponentiation (checks off)
with System.Exn_Gen;
package System.Exn_SInt is
pragma Pure (Exn_SInt);
function Exn_Short_Integer is
new System.Exn_Gen.Exn_Integer_Type (Short_Integer);
end System.Exn_SInt;
gcc/ada/s-exnssi.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X N _ S S I --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Short_Short_Integer exponentiation (checks off)
with System.Exn_Gen;
package System.Exn_SSI is
pragma Pure (Exn_SSI);
function Exn_Short_Short_Integer is
new System.Exn_Gen.Exn_Integer_Type (Short_Short_Integer);
end System.Exn_SSI;
gcc/ada/s-expflt.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X P F L T --
-- --
-- S p e c --
-- --
-- $Revision: 1.10 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Float exponentiation (checks on)
with System.Exp_Gen;
package System.Exp_Flt is
pragma Pure (Exp_Flt);
function Exp_Float is new System.Exp_Gen.Exp_Float_Type (Float);
end System.Exp_Flt;
gcc/ada/s-expgen.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X P _ G E N --
-- --
-- B o d y --
-- --
-- $Revision: 1.11 $
-- --
-- Copyright (C) 1992-2001, 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body System.Exp_Gen is
--------------------
-- Exp_Float_Type --
--------------------
function Exp_Float_Type
(Left : Type_Of_Base;
Right : Integer)
return Type_Of_Base
is
Result : Type_Of_Base := 1.0;
Factor : Type_Of_Base := Left;
Exp : Integer := Right;
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2. For positive exponents we
-- multiply the result by this factor, for negative exponents, we
-- divide by this factor.
if Exp >= 0 then
-- For a positive exponent, if we get a constraint error during
-- this loop, it is an overflow, and the constraint error will
-- simply be passed on to the caller.
loop
if Exp rem 2 /= 0 then
declare
pragma Unsuppress (All_Checks);
begin
Result := Result * Factor;
end;
end if;
Exp := Exp / 2;
exit when Exp = 0;
declare
pragma Unsuppress (All_Checks);
begin
Factor := Factor * Factor;
end;
end loop;
return Result;
-- Now we know that the exponent is negative, check for case of
-- base of 0.0 which always generates a constraint error.
elsif Factor = 0.0 then
raise Constraint_Error;
-- Here we have a negative exponent with a non-zero base
else
-- For the negative exponent case, a constraint error during this
-- calculation happens if Factor gets too large, and the proper
-- response is to return 0.0, since what we essenmtially have is
-- 1.0 / infinity, and the closest model number will be zero.
begin
loop
if Exp rem 2 /= 0 then
declare
pragma Unsuppress (All_Checks);
begin
Result := Result * Factor;
end;
end if;
Exp := Exp / 2;
exit when Exp = 0;
declare
pragma Unsuppress (All_Checks);
begin
Factor := Factor * Factor;
end;
end loop;
declare
pragma Unsuppress (All_Checks);
begin
return 1.0 / Result;
end;
exception
when Constraint_Error =>
return 0.0;
end;
end if;
end Exp_Float_Type;
----------------------
-- Exp_Integer_Type --
----------------------
-- Note that negative exponents get a constraint error because the
-- subtype of the Right argument (the exponent) is Natural.
function Exp_Integer_Type
(Left : Type_Of_Base;
Right : Natural)
return Type_Of_Base
is
Result : Type_Of_Base := 1;
Factor : Type_Of_Base := Left;
Exp : Natural := Right;
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2.
-- Note: it is not worth special casing the cases of base values -1,0,+1
-- since the expander does this when the base is a literal, and other
-- cases will be extremely rare.
if Exp /= 0 then
loop
if Exp rem 2 /= 0 then
declare
pragma Unsuppress (All_Checks);
begin
Result := Result * Factor;
end;
end if;
Exp := Exp / 2;
exit when Exp = 0;
declare
pragma Unsuppress (All_Checks);
begin
Factor := Factor * Factor;
end;
end loop;
end if;
return Result;
end Exp_Integer_Type;
end System.Exp_Gen;
gcc/ada/s-expgen.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X P _ G E N --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $ --
-- --
-- Copyright (C) 1992,1993,1994,1995 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package contains the generic functions which are instantiated with
-- predefined integer and real types to generate the runtime exponentiation
-- functions called by expanded code generated by Expand_Op_Expon. This
-- version of the package contains routines that are compiled with overflow
-- checks enabled, so they are called for exponentiation operations which
-- require overflow checking
package System.Exp_Gen is
pragma Pure (System.Exp_Gen);
-- Exponentiation for float types (checks on)
generic
type Type_Of_Base is digits <>;
function Exp_Float_Type
(Left : Type_Of_Base;
Right : Integer)
return Type_Of_Base;
-- Exponentiation for signed integer types (checks on)
generic
type Type_Of_Base is range <>;
function Exp_Integer_Type
(Left : Type_Of_Base;
Right : Natural)
return Type_Of_Base;
end System.Exp_Gen;
gcc/ada/s-expint.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X P I N T --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $ --
-- --
-- Copyright (C) 1992,1993 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Integer exponentiation (checks on)
with System.Exp_Gen;
package System.Exp_Int is
pragma Pure (Exp_Int);
function Exp_Integer is new System.Exp_Gen.Exp_Integer_Type (Integer);
end System.Exp_Int;
gcc/ada/s-explfl.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X P _ L F L T --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Long_Float exponentiation (checks on)
with System.Exp_Gen;
package System.Exp_LFlt is
pragma Pure (Exp_LFlt);
function Exp_Long_Float is
new System.Exp_Gen.Exp_Float_Type (Long_Float);
end System.Exp_LFlt;
gcc/ada/s-explin.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X P _ L I N T --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Long_Integer exponentiation (checks on)
with System.Exp_Gen;
package System.Exp_LInt is
pragma Pure (Exp_LInt);
function Exp_Long_Integer is
new System.Exp_Gen.Exp_Integer_Type (Long_Integer);
end System.Exp_LInt;
gcc/ada/s-expllf.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X P _ L L F --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Long_Long_Float exponentiation (checks on)
with System.Exp_Gen;
package System.Exp_LLF is
pragma Pure (Exp_LLF);
function Exp_Long_Long_Float is
new System.Exp_Gen.Exp_Float_Type (Long_Long_Float);
end System.Exp_LLF;
gcc/ada/s-explli.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X P _ L L I --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $ --
-- --
-- Copyright (C) 1992,1993 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Long_Long_Integer exponentiation
with System.Exp_Gen;
package System.Exp_LLI is
pragma Pure (Exp_LLI);
function Exp_Long_Long_Integer is
new System.Exp_Gen.Exp_Integer_Type (Long_Long_Integer);
end System.Exp_LLI;
gcc/ada/s-expllu.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . X P _ B M L --
-- --
-- B o d y --
-- --
-- $Revision: 1.7 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System.Unsigned_Types; use System.Unsigned_Types;
package body System.Exp_LLU is
----------------------------
-- Exp_Long_Long_Unsigned --
----------------------------
function Exp_Long_Long_Unsigned
(Left : Long_Long_Unsigned;
Right : Natural)
return Long_Long_Unsigned
is
Result : Long_Long_Unsigned := 1;
Factor : Long_Long_Unsigned := Left;
Exp : Natural := Right;
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2.
-- Note: it is not worth special casing the cases of base values -1,0,+1
-- since the expander does this when the base is a literal, and other
-- cases will be extremely rare.
if Exp /= 0 then
loop
if Exp rem 2 /= 0 then
Result := Result * Factor;
end if;
Exp := Exp / 2;
exit when Exp = 0;
Factor := Factor * Factor;
end loop;
end if;
return Result;
end Exp_Long_Long_Unsigned;
end System.Exp_LLU;
gcc/ada/s-expllu.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X P _ L L U --
-- --
-- S p e c --
-- --
-- $Revision: 1.7 $ --
-- --
-- Copyright (C) 1992-1997 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This procedure performs exponentiation of unsigned types (with binary
-- modulus values exceeding that of Unsigned_Types.Unsigned). The result
-- is always full width, the caller must do a masking operation if the
-- modulus is less than 2 ** (Long_Long_Unsigned'Size).
with System.Unsigned_Types;
package System.Exp_LLU is
pragma Pure (Exp_LLU);
function Exp_Long_Long_Unsigned
(Left : System.Unsigned_Types.Long_Long_Unsigned;
Right : Natural)
return System.Unsigned_Types.Long_Long_Unsigned;
end System.Exp_LLU;
gcc/ada/s-expmod.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X P _ M O D --
-- --
-- B o d y --
-- --
-- $Revision: 1.7 $ --
-- --
-- Copyright (C) 1992,1993,1994,1995 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body System.Exp_Mod is
-----------------
-- Exp_Modular --
-----------------
function Exp_Modular
(Left : Integer;
Modulus : Integer;
Right : Natural)
return Integer
is
Result : Integer := 1;
Factor : Integer := Left;
Exp : Natural := Right;
function Mult (X, Y : Integer) return Integer;
pragma Inline (Mult);
-- Modular multiplication. Note that we can't take advantage of the
-- compiler's circuit, because the modulus is not known statically.
function Mult (X, Y : Integer) return Integer is
begin
return Integer
(Long_Long_Integer (X) * Long_Long_Integer (Y)
mod Long_Long_Integer (Modulus));
end Mult;
-- Start of processing for Exp_Modular
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2.
-- Note: it is not worth special casing the cases of base values -1,0,+1
-- since the expander does this when the base is a literal, and other
-- cases will be extremely rare.
if Exp /= 0 then
loop
if Exp rem 2 /= 0 then
Result := Mult (Result, Factor);
end if;
Exp := Exp / 2;
exit when Exp = 0;
Factor := Mult (Factor, Factor);
end loop;
end if;
return Result;
end Exp_Modular;
end System.Exp_Mod;
gcc/ada/s-expmod.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X P _ M O D --
-- --
-- S p e c --
-- --
-- $Revision: 1.6 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This procedure performs exponentiation of a modular type with non-binary
-- modulus values. Arithmetic is done in Long_Long_Unsigned, with explicit
-- accounting for the modulus value which is passed as the second argument.
package System.Exp_Mod is
pragma Pure (Exp_Mod);
function Exp_Modular
(Left : Integer;
Modulus : Integer;
Right : Natural)
return Integer;
end System.Exp_Mod;
gcc/ada/s-expsfl.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X P _ S F L T --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Short_Float exponentiation (checks on)
with System.Exp_Gen;
package System.Exp_SFlt is
pragma Pure (Exp_SFlt);
function Exp_Short_Float is
new System.Exp_Gen.Exp_Float_Type (Short_Float);
end System.Exp_SFlt;
gcc/ada/s-expsin.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X P _ S I N T --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Short_Integer exponentiation (checks on)
with System.Exp_Gen;
package System.Exp_SInt is
pragma Pure (Exp_SInt);
function Exp_Short_Integer is
new System.Exp_Gen.Exp_Integer_Type (Short_Integer);
end System.Exp_SInt;
gcc/ada/s-expssi.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X P S S I --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Short_Short_Integer exponentiation (checks on)
with System.Exp_Gen;
package System.Exp_SSI is
pragma Pure (Exp_SSI);
function Exp_Short_Short_Integer is
new System.Exp_Gen.Exp_Integer_Type (Short_Short_Integer);
end System.Exp_SSI;
gcc/ada/s-expuns.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X P _ U N S --
-- --
-- B o d y --
-- --
-- $Revision: 1.10 $ --
-- --
-- Copyright (C) 1992-1997 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System.Unsigned_Types; use System.Unsigned_Types;
package body System.Exp_Uns is
------------------
-- Exp_Unsigned --
------------------
function Exp_Unsigned
(Left : Unsigned;
Right : Natural)
return Unsigned
is
Result : Unsigned := 1;
Factor : Unsigned := Left;
Exp : Natural := Right;
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2.
-- Note: it is not worth special casing the cases of base values -1,0,+1
-- since the expander does this when the base is a literal, and other
-- cases will be extremely rare.
if Exp /= 0 then
loop
if Exp rem 2 /= 0 then
Result := Result * Factor;
end if;
Exp := Exp / 2;
exit when Exp = 0;
Factor := Factor * Factor;
end loop;
end if;
return Result;
end Exp_Unsigned;
end System.Exp_Uns;
gcc/ada/s-expuns.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . E X P _ U N S --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $ --
-- --
-- Copyright (C) 1992-1997 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This procedure performs exponentiation of unsigned types (with binary
-- modulus values up to and including that of Unsigned_Types.Unsigned).
-- The result is always full width, the caller must do a masking operation
-- the modulus is less than 2 ** (Unsigned'Size).
with System.Unsigned_Types;
package System.Exp_Uns is
pragma Pure (Exp_Uns);
function Exp_Unsigned
(Left : System.Unsigned_Types.Unsigned;
Right : Natural)
return System.Unsigned_Types.Unsigned;
end System.Exp_Uns;
gcc/ada/s-fatflt.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . F A T _ F L T --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- Copyright (C) 1992,1993,1994,1995,1996 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package contains an instantiation of the floating-point attribute
-- runtime routines for the type Float.
with System.Fat_Gen;
package System.Fat_Flt is
pragma Pure (Fat_Flt);
-- Note the only entity from this package that is acccessed by Rtsfind
-- is the name of the package instantiation. Entities within this package
-- (i.e. the individual floating-point attribute routines) are accessed
-- by name using selected notation.
package Fat_Float is new System.Fat_Gen (Float);
end System.Fat_Flt;
gcc/ada/s-fatgen.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . F A T _ G E N --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $
-- --
-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This generic package provides a target independent implementation of the
-- floating-point attributes that denote functions. The implementations here
-- are portable, but very slow. The runtime contains a set of instantiations
-- of this package for all predefined floating-point types, and these should
-- be replaced by efficient assembly language code where possible.
generic
type T is digits <>;
package System.Fat_Gen is
pragma Pure (Fat_Gen);
subtype UI is Integer;
-- The runtime representation of universal integer for the purposes of
-- this package is integer. The expander generates conversions for the
-- actual type used. For functions returning universal integer, there
-- is no problem, since the result always is in range of integer. For
-- input arguments, the expander has to do some special casing to deal
-- with the (very annoying!) cases of out of range values. If we used
-- Long_Long_Integer to represent universal, then there would be no
-- problem, but the resulting inefficiency would be annoying.
function Adjacent (X, Towards : T) return T;
function Ceiling (X : T) return T;
function Compose (Fraction : T; Exponent : UI) return T;
function Copy_Sign (Value, Sign : T) return T;
function Exponent (X : T) return UI;
function Floor (X : T) return T;
function Fraction (X : T) return T;
function Leading_Part (X : T; Radix_Digits : UI) return T;
function Machine (X : T) return T;
function Model (X : T) return T;
function Pred (X : T) return T;
function Remainder (X, Y : T) return T;
function Rounding (X : T) return T;
function Scaling (X : T; Adjustment : UI) return T;
function Succ (X : T) return T;
function Truncation (X : T) return T;
function Unbiased_Rounding (X : T) return T;
function Valid (X : access T) return Boolean;
-- The argument must be passed by reference here, as T may be
-- an abnormal value that can be passed in a floating point register.
private
pragma Inline (Machine);
pragma Inline (Model);
pragma Inline_Always (Valid);
end System.Fat_Gen;
gcc/ada/s-fatlfl.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . F A T _ L F L T --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- Copyright (C) 1992,1993,1994,1995,1996 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package contains an instantiation of the floating-point attribute
-- runtime routines for the type Long_Float.
with System.Fat_Gen;
package System.Fat_LFlt is
pragma Pure (Fat_LFlt);
-- Note the only entity from this package that is acccessed by Rtsfind
-- is the name of the package instantiation. Entities within this package
-- (i.e. the individual floating-point attribute routines) are accessed
-- by name using selected notation.
package Fat_Long_Float is new System.Fat_Gen (Long_Float);
end System.Fat_LFlt;
gcc/ada/s-fatllf.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . F A T _ L L F --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- Copyright (C) 1992,1993,1994,1995,1996 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package contains an instantiation of the floating-point attribute
-- runtime routines for the type Long_Long_Float.
with System.Fat_Gen;
package System.Fat_LLF is
pragma Pure (Fat_LLF);
-- Note the only entity from this package that is acccessed by Rtsfind
-- is the name of the package instantiation. Entities within this package
-- (i.e. the individual floating-point attribute routines) are accessed
-- by name using selected notation.
package Fat_Long_Long_Float is new System.Fat_Gen (Long_Long_Float);
end System.Fat_LLF;
gcc/ada/s-fatsfl.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . F A T _ S F L T --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- Copyright (C) 1992,1993,1994,1995,1996 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package contains an instantiation of the floating-point attribute
-- runtime routines for the type Short_Float.
with System.Fat_Gen;
package System.Fat_SFlt is
pragma Pure (Fat_SFlt);
-- Note the only entity from this package that is acccessed by Rtsfind
-- is the name of the package instantiation. Entities within this package
-- (i.e. the individual floating-point attribute routines) are accessed
-- by name using selected notation.
package Fat_Short_Float is new System.Fat_Gen (Short_Float);
end System.Fat_SFlt;
gcc/ada/s-ficobl.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . F I L E _ C O N T R O L _ B L O C K --
-- --
-- S p e c --
-- --
-- $Revision: 1.9 $
-- --
-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package contains the declaration of the basic file control block
-- shared between Text_IO, Sequential_IO, Direct_IO and Streams.Stream_IO.
-- The actual control blocks are derived from this block by extension. The
-- control block is itself derived from Ada.Streams.Root_Stream_Type which
-- facilitates implementation of Stream_IO.Stream and Text_Streams.Stream.
with Ada.Streams;
with Interfaces.C_Streams;
package System.File_Control_Block is
-----------------------------
-- Ada File Control Block --
-----------------------------
-- The Ada file control block is an abstract extension of the root
-- stream type. This allows a file to be treated directly as a stream
-- for the purposes of Stream_IO, or stream operations on a text file.
-- The individual I/O packages extend this type with package specific
-- fields to create the concrete types to which the routines in this
-- package can be applied.
-- The type File_Type in the individual packages is an access to the
-- extended file control block. The value is null if the file is not
-- open, and a pointer to the control block if the file is open.
type Pstring is access all String;
-- Used to hold name and form strings
type File_Mode is (In_File, Inout_File, Out_File, Append_File);
-- File mode (union of file modes permitted by individual packages,
-- the types File_Mode in the individual packages are declared to
-- allow easy conversion to and from this general type.
type Shared_Status_Type is (Yes, No, None);
-- This type is used to define the sharing status of a file. The default
-- setting of None is used if no "shared=xxx" appears in the form string
-- when a file is created or opened. For a file with Shared_Status set to
-- None, Use_Error will be raised if any other file is opened or created
-- with the same full name. Yes/No are set in response to the presence
-- of "shared=yes" or "shared=no" in the form string. In either case it
-- is permissible to have multiple files opened with the same full name.
-- All files opened simultaneously with "shared=yes" will share the same
-- stream with the semantics specified in the RM for file sharing. All
-- files opened with "shared=no" will have their own stream.
type AFCB;
type AFCB_Ptr is access all AFCB'Class;
type AFCB is abstract new Ada.Streams.Root_Stream_Type with record
Stream : Interfaces.C_Streams.FILEs;
-- The file descriptor
Name : Pstring;
-- A pointer to the file name. The file name is null for temporary
-- files, and also for standard files (stdin, stdout, stderr). The
-- name is always null-terminated if it is non-null.
Form : Pstring;
-- A pointer to the form string. This is the string used in the
-- fopen call, and must be supplied by the caller (there are no
-- defaults at this level). The string is always null-terminated.
Mode : File_Mode;
-- The file mode. No checks are made that the mode is consistent
-- with the form used to fopen the file.
Is_Regular_File : Boolean;
-- A flag indicating if the file is a regular file
Is_Temporary_File : Boolean;
-- A flag set only for temporary files (i.e. files created using the
-- Create function with a null name parameter, using tmpfile). This
-- is currently not used since temporary files are deleted by the
-- operating system, but it is set properly in case some systems
-- need this information in the future.
Is_System_File : Boolean;
-- A flag set only for system files (stdin, stdout, stderr)
Is_Text_File : Boolean;
-- A flag set if the file was opened in text mode
Shared_Status : Shared_Status_Type;
-- Indicates sharing status of file, see description of type above
Access_Method : Character;
-- Set to 'Q', 'S', 'T, 'D' for Sequential_IO, Stream_IO, Text_IO
-- Direct_IO file (used to validate file sharing request).
Next : AFCB_Ptr;
Prev : AFCB_Ptr;
-- All open files are kept on a doubly linked chain, with these
-- pointers used to maintain the next and previous pointers.
end record;
----------------------------------
-- Primitive Operations of AFCB --
----------------------------------
-- Note that we inherit the abstract operations Read and Write from
-- the base type. These must be overridden by the individual file
-- access methods to provide Stream Read/Write access.
function AFCB_Allocate (Control_Block : AFCB) return AFCB_Ptr is abstract;
-- Given a control block, allocate space for a control block of the same
-- type on the heap, and return the pointer to this allocated block. Note
-- that the argument Control_Block is not used other than as the argument
-- that controls which version of AFCB_Allocate is called.
procedure AFCB_Close (File : access AFCB) is abstract;
-- Performs any specialized close actions on a file before the file is
-- actually closed at the system level. This is called by Close, and
-- the reason we need the primitive operation is for the automatic
-- close operations done as part of finalization.
procedure AFCB_Free (File : access AFCB) is abstract;
-- Frees the AFCB referenced by the given parameter. It is not necessary
-- to free the strings referenced by the Form and Name fields, but if the
-- extension has any other heap objects, they must be freed as well. This
-- procedure must be overridden by each individual file package.
end System.File_Control_Block;
gcc/ada/s-finimp.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . F I N A L I Z A T I O N _ I M P L E M E N T A T I O N --
-- --
-- S p e c --
-- --
-- $Revision: 1.31 $ --
-- --
-- Copyright (C) 1992-1998 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System.Finalization_Root;
package System.Finalization_Implementation is
pragma Elaborate_Body (Finalization_Implementation);
package SFR renames System.Finalization_Root;
------------------------------------------------
-- Finalization Management Abstract Interface --
------------------------------------------------
Global_Final_List : SFR.Finalizable_Ptr;
-- This list stores the controlled objects defined in library-level
-- packages. They will be finalized after the main program completion.
procedure Finalize_Global_List;
-- The procedure to be called in order to finalize the global list;
procedure Attach_To_Final_List
(L : in out SFR.Finalizable_Ptr;
Obj : in out SFR.Finalizable;
Nb_Link : Short_Short_Integer);
-- Attach finalizable object Obj to the linked list L. Nb_Link controls
-- the number of link of the linked_list, and can be either 0 for no
-- attachement, 1 for simple linked lists or 2 for doubly linked lists
-- or even 3 for a simple attachement of a whole array of elements.
-- Attachement to a simply linked list is not protected against
-- concurrent access and should only be used in context where it
-- doesn't matter, such as for objects allocated on the stack. In the
-- case of an attachment on a doubly linked list, L must not be null
-- and Obj will be inserted AFTER the first element and the attachment
-- is protected against concurrent call. Typically used to attach to
-- a dynamically allocated object to a List_Controller (whose first
-- element is always a dummy element)
procedure Finalize_List (L : SFR.Finalizable_Ptr);
-- Call Finalize on each element of the list L;
procedure Finalize_One (Obj : in out SFR.Finalizable);
-- Call Finalize on Obj and remove its final list.
---------------------
-- Deep Procedures --
---------------------
procedure Deep_Tag_Initialize
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Short_Short_Integer);
-- Generic initialize for tagged objects with controlled components. A
-- is the address of the object, L the finalization list when it needs
-- to be attached and B the attachement level (see Attach_To_Final_List)
procedure Deep_Tag_Adjust
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Short_Short_Integer);
-- Generic adjust for tagged objects with controlled components. A
-- is the address of the object, L the finalization list when it needs
-- to be attached and B the attachement level (see Attach_To_Final_List)
procedure Deep_Tag_Finalize
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Boolean);
-- Generic finalize for tagged objects with controlled components. A
-- is the address of the object, L the finalization list when it needs
-- to be attached and B the attachement level (see Attach_To_Final_List)
procedure Deep_Tag_Attach
(L : in out SFR.Finalizable_Ptr;
A : System.Address;
B : Short_Short_Integer);
-- Generic attachement for tagged objects with controlled components. A
-- is the address of the object, L the finalization list when it needs
-- to be attached and B the attachement level (see Attach_To_Final_List)
-----------------------------
-- Record Controller Types --
-----------------------------
-- Definition of the types of the controller component that is included
-- in records containing controlled components. This controller is
-- attached to the finalization chain of the upper-level and carries
-- the pointer of the finalization chain for the lower level
type Limited_Record_Controller is new SFR.Root_Controlled with record
F : SFR.Finalizable_Ptr;
end record;
procedure Initialize (Object : in out Limited_Record_Controller);
-- Does nothing
procedure Finalize (Object : in out Limited_Record_Controller);
-- Finalize the controlled components of the enclosing record by
-- following the list starting at Object.F
type Record_Controller is
new Limited_Record_Controller with record
My_Address : System.Address;
end record;
procedure Initialize (Object : in out Record_Controller);
-- Initialize the field My_Address to the Object'Address
procedure Adjust (Object : in out Record_Controller);
-- Adjust the components and their finalization pointers by substracting
-- by the offset of the target and the source addresses of the assignment
-- Inherit Finalize from Limited_Record_Controller
procedure Detach_From_Final_List (Obj : in out SFR.Finalizable);
-- Remove the specified object from its Final list which must be a
-- doubly linked list.
end System.Finalization_Implementation;
gcc/ada/s-finroo.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . F I N A L I Z A T I O N _ R O O T --
-- --
-- S p e c --
-- --
-- $Revision: 1.8 $
-- --
-- Copyright (C) 1992-2001 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body System.Finalization_Root is
-- It should not be possible to call any of these subprograms
------------
-- Adjust --
------------
procedure Adjust (Object : in out Root_Controlled) is
begin
raise Program_Error;
end Adjust;
--------------
-- Finalize --
--------------
procedure Finalize (Object : in out Root_Controlled) is
begin
raise Program_Error;
end Finalize;
----------------
-- Initialize --
----------------
procedure Initialize (Object : in out Root_Controlled) is
begin
raise Program_Error;
end Initialize;
----------
-- Read --
----------
-- Read and Write must be empty in order to avoid copying the
-- finalization pointers.
pragma Warnings (Off);
-- Suppress warning for out paramater Item which is not assigned
-- because it is pretty much empty.
procedure Read (Stream : access Ada.Streams.Root_Stream_Type'Class;
Item : out Root_Controlled)
is
begin
null;
end Read;
-----------
-- Write --
-----------
-- Read and Write must be empty in order to avoid copying the
-- finalization pointers.
procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class;
Item : in Root_Controlled)
is
begin
null;
end Write;
end System.Finalization_Root;
gcc/ada/s-finroo.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . F I N A L I Z A T I O N _ R O O T --
-- --
-- S p e c --
-- --
-- $Revision: 1.7 $
-- --
-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Streams;
package System.Finalization_Root is
pragma Preelaborate (Finalization_Root);
type Root_Controlled;
type Finalizable_Ptr is access all Root_Controlled'Class;
type Empty_Root_Controlled is abstract tagged null record;
-- Just for the sake of Controlled equality (see Ada.Finalization)
type Root_Controlled is new Empty_Root_Controlled with record
Prev, Next : Finalizable_Ptr;
end record;
subtype Finalizable is Root_Controlled'Class;
procedure Initialize (Object : in out Root_Controlled);
procedure Finalize (Object : in out Root_Controlled);
procedure Adjust (Object : in out Root_Controlled);
procedure Write (Stream : access Ada.Streams.Root_Stream_Type'Class;
Item : in Root_Controlled);
procedure Read (Stream : access Ada.Streams.Root_Stream_Type'Class;
Item : out Root_Controlled);
for Root_Controlled'Read use Read;
for Root_Controlled'Write use Write;
end System.Finalization_Root;
gcc/ada/s-fore.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . F O R E --
-- --
-- B o d y --
-- --
-- $Revision: 1.3 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body System.Fore is
----------
-- Fore --
----------
function Fore (Lo, Hi : Long_Long_Float) return Natural is
T : Long_Long_Float := Long_Long_Float'Max (abs Lo, abs Hi);
R : Natural;
begin
-- Initial value of 2 allows for sign and mandatory single digit
R := 2;
-- Loop to increase Fore as needed to include full range of values
while T >= 10.0 loop
T := T / 10.0;
R := R + 1;
end loop;
return R;
end Fore;
end System.Fore;
gcc/ada/s-fore.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . F O R E --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package contains the routine used for the 'Fore attribute
package System.Fore is
pragma Pure (Fore);
function Fore (Lo, Hi : Long_Long_Float) return Natural;
-- Compute Fore attribute value for a fixed-point type. The parameters
-- are the low and high bounds values, converted to Long_Long_Float.
end System.Fore;
gcc/ada/s-gloloc.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . G L O B A L _ L O C K S --
-- --
-- B o d y --
-- --
-- $Revision: 1.6 $ --
-- --
-- Copyright (C) 1999-2001 Ada Core Technologies, 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with GNAT.Task_Lock;
package body System.Global_Locks is
type String_Access is access String;
package TSL renames GNAT.Task_Lock;
Dir_Separator : Character;
pragma Import (C, Dir_Separator, "__gnat_dir_separator");
type Lock_File_Entry is
record
Dir : String_Access;
File : String_Access;
end record;
Last_Lock : Lock_Type := Null_Lock;
Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry;
procedure Lock_File
(Dir : String;
File : String;
Wait : Duration := 0.1;
Retries : Natural := Natural'Last);
-- Create a lock file File in directory Dir. If the file cannot be
-- locked because someone already owns the lock, this procedure
-- waits Wait seconds and retries at most Retries times. If the file
-- still cannot be locked, Lock_Error is raised. The default is to try
-- every second, almost forever (Natural'Last times).
------------------
-- Acquire_Lock --
------------------
procedure Acquire_Lock
(Lock : in out Lock_Type)
is
begin
Lock_File
(Lock_Table (Lock).Dir.all,
Lock_Table (Lock).File.all);
end Acquire_Lock;
-----------------
-- Create_Lock --
-----------------
procedure Create_Lock
(Lock : out Lock_Type;
Name : in String)
is
L : Lock_Type;
begin
TSL.Lock;
Last_Lock := Last_Lock + 1;
L := Last_Lock;
TSL.Unlock;
if L > Lock_Table'Last then
raise Lock_Error;
end if;
for J in reverse Name'Range loop
if Name (J) = Dir_Separator then
Lock_Table (L).Dir
:= new String'(Name (Name'First .. J - 1));
Lock_Table (L).File
:= new String'(Name (J + 1 .. Name'Last));
exit;
end if;
end loop;
if Lock_Table (L).Dir = null then
Lock_Table (L).Dir := new String'(".");
Lock_Table (L).File := new String'(Name);
end if;
Lock := L;
end Create_Lock;
---------------
-- Lock_File --
---------------
procedure Lock_File
(Dir : String;
File : String;
Wait : Duration := 0.1;
Retries : Natural := Natural'Last)
is
C_Dir : aliased String := Dir & ASCII.NUL;
C_File : aliased String := File & ASCII.NUL;
function Try_Lock (Dir, File : System.Address) return Integer;
pragma Import (C, Try_Lock, "__gnat_try_lock");
begin
for I in 0 .. Retries loop
if Try_Lock (C_Dir'Address, C_File'Address) = 1 then
return;
end if;
exit when I = Retries;
delay Wait;
end loop;
raise Lock_Error;
end Lock_File;
------------------
-- Release_Lock --
------------------
procedure Release_Lock
(Lock : in out Lock_Type)
is
S : aliased String :=
Lock_Table (Lock).Dir.all & Dir_Separator &
Lock_Table (Lock).File.all & ASCII.NUL;
procedure unlink (A : System.Address);
pragma Import (C, unlink, "unlink");
begin
unlink (S'Address);
end Release_Lock;
end System.Global_Locks;
gcc/ada/s-gloloc.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . G L O B A L _ L O C K S --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $
-- --
-- Copyright (C) 1999-2001 Ada Core Technologies, 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- This package contains the necessary routines to provide
-- reliable system wide locking capability.
package System.Global_Locks is
Lock_Error : exception;
-- Exception raised if a request cannot be executed on a lock.
type Lock_Type is private;
-- Such a lock is a global lock between partitions. This lock is
-- uniquely defined between the partitions because of its name.
Null_Lock : constant Lock_Type;
procedure Create_Lock
(Lock : out Lock_Type;
Name : in String);
-- Create or retrieve a global lock for the current partition using
-- its Name.
procedure Acquire_Lock
(Lock : in out Lock_Type);
-- If the lock cannot be acquired because someone already owns it, this
-- procedure is supposed to wait and retry forever.
procedure Release_Lock
(Lock : in out Lock_Type);
private
type Lock_Type is new Natural;
Null_Lock : constant Lock_Type := 0;
end System.Global_Locks;
gcc/ada/s-imgbiu.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . I M G _ B I U --
-- --
-- B o d y --
-- --
-- $Revision: 1.6 $ --
-- --
-- Copyright (C) 1992,1993,1994,1995 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with System.Unsigned_Types; use System.Unsigned_Types;
package body System.Img_BIU is
-----------------------------
-- Set_Image_Based_Integer --
-----------------------------
procedure Set_Image_Based_Integer
(V : Integer;
B : Natural;
W : Integer;
S : out String;
P : in out Natural)
is
Start : Natural;
begin
-- Positive case can just use the unsigned circuit directly
if V >= 0 then
Set_Image_Based_Unsigned (Unsigned (V), B, W, S, P);
-- Negative case has to set a minus sign. Note also that we have to be
-- careful not to generate overflow with the largest negative number.
else
P := P + 1;
S (P) := ' ';
Start := P;
declare
pragma Suppress (Overflow_Check);
pragma Suppress (Range_Check);
begin
Set_Image_Based_Unsigned (Unsigned (-V), B, W - 1, S, P);
end;
-- Set minus sign in last leading blank location. Because of the
-- code above, there must be at least one such location.
while S (Start + 1) = ' ' loop
Start := Start + 1;
end loop;
S (Start) := '-';
end if;
end Set_Image_Based_Integer;
------------------------------
-- Set_Image_Based_Unsigned --
------------------------------
procedure Set_Image_Based_Unsigned
(V : Unsigned;
B : Natural;
W : Integer;
S : out String;
P : in out Natural)
is
Start : constant Natural := P;
F, T : Natural;
BU : constant Unsigned := Unsigned (B);
Hex : constant array
(Unsigned range 0 .. 15) of Character := "0123456789ABCDEF";
procedure Set_Digits (T : Unsigned);
-- Set digits of absolute value of T
procedure Set_Digits (T : Unsigned) is
begin
if T >= BU then
Set_Digits (T / BU);
P := P + 1;
S (P) := Hex (T mod BU);
else
P := P + 1;
S (P) := Hex (T);
end if;
end Set_Digits;
-- Start of processing for Set_Image_Based_Unsigned
begin
if B >= 10 then
P := P + 1;
S (P) := '1';
end if;
P := P + 1;
S (P) := Character'Val (Character'Pos ('0') + B mod 10);
P := P + 1;
S (P) := '#';
Set_Digits (V);
P := P + 1;
S (P) := '#';
-- Add leading spaces if required by width parameter
if P - Start < W then
F := P;
P := Start + W;
T := P;
while F > Start loop
S (T) := S (F);
T := T - 1;
F := F - 1;
end loop;
for J in Start + 1 .. T loop
S (J) := ' ';
end loop;
end if;
end Set_Image_Based_Unsigned;
end System.Img_BIU;
gcc/ada/s-imgbiu.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . I M G _ B I U --
-- --
-- S p e c --
-- --
-- $Revision: 1.6 $
-- --
-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Contains the routine for computing the image in based format of signed and
-- unsigned integers whose size <= Integer'Size for use by Text_IO.Integer_IO
-- and Text_IO.Modular_IO.
with System.Unsigned_Types;
package System.Img_BIU is
pragma Pure (Img_BIU);
procedure Set_Image_Based_Integer
(V : Integer;
B : Natural;
W : Integer;
S : out String;
P : in out Natural);
-- Sets the signed image of V in based format, using base value B (2..16)
-- starting at S (P + 1), updating P to point to the last character stored.
-- The image includes a leading minus sign if necessary, but no leading
-- spaces unless W is positive, in which case leading spaces are output if
-- necessary to ensure that the output string is no less than W characters
-- long. The caller promises that the buffer is large enough and no check
-- is made for this. Constraint_Error will not necessarily be raised if
-- this is violated, since it is perfectly valid to compile this unit with
-- checks off.
procedure Set_Image_Based_Unsigned
(V : System.Unsigned_Types.Unsigned;
B : Natural;
W : Integer;
S : out String;
P : in out Natural);
-- Sets the unsigned image of V in based format, using base value B (2..16)
-- starting at S (P + 1), updating P to point to the last character stored.
-- The image includes no leading spaces unless W is positive, in which case
-- leading spaces are output if necessary to ensure that the output string
-- is no less than W characters long. The caller promises that the buffer
-- is large enough and no check is made for this. Constraint_Error will not
-- necessarily be raised if this is violated, since it is perfectly valid
-- to compile this unit with checks off).
end System.Img_BIU;
gcc/ada/s-imgboo.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . I M G _ B O O L --
-- --
-- B o d y --
-- --
-- $Revision: 1.9 $ --
-- --
-- Copyright (C) 1992,1993,1994 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body System.Img_Bool is
-------------------
-- Image_Boolean --
-------------------
function Image_Boolean (V : Boolean) return String is
begin
if V then
return "TRUE";
else
return "FALSE";
end if;
end Image_Boolean;
end System.Img_Bool;
gcc/ada/s-imgboo.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . I M G _ B O O L --
-- --
-- S p e c --
-- --
-- $Revision: 1.10 $
-- --
-- Copyright (C) 1992-2000 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- Boolean'Image
package System.Img_Bool is
pragma Pure (Img_Bool);
function Image_Boolean (V : Boolean) return String;
-- Computes Boolean'Image (V) and returns the result.
end System.Img_Bool;
gcc/ada/s-imgcha.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- S Y S T E M . I M G _ C H A R --
-- --
-- B o d y --
-- --
-- $Revision: 1.11 $ --
-- --
-- Copyright (C) 1992,1993,1994,1995 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 2, 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 COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
package body System.Img_Char is
---------------------
-- Image_Character --
---------------------
function Image_Character (V : Character) return String is
subtype Cname is String (1 .. 3);
S : Cname;
subtype C0_Range is Character
range Character'Val (16#00#) .. Character'Val (16#1F#);
C0 : constant array (C0_Range) of Cname :=
(Character'Val (16#00#) => "NUL",
Character'Val (16#01#) => "SOH",
Character'Val (16#02#) => "STX",
Character'Val (16#03#) => "ETX",
Character'Val (16#04#) => "EOT",
Character'Val (16#05#) => "ENQ",
Character'Val (16#06#) => "ACK",
Character'Val (16#07#) => "BEL",
Character'Val (16#08#) => "BS ",
Character'Val (16#09#) => "HT ",
Character'Val (16#0A#) => "LF ",
Character'Val (16#0B#) => "VT ",
Character'Val (16#0C#) => "FF ",
Character'Val (16#0D#) => "CR ",
Character'Val (16#0E#) => "SO ",
Character'Val (16#0F#) => "SI ",
Character'Val (16#10#) => "DLE",
Character'Val (16#11#) => "DC1",
Character'Val (16#12#) => "DC2",
Character'Val (16#13#) => "DC3",
Character'Val (16#14#) => "DC4",
Character'Val (16#15#) => "NAK",
Character'Val (16#16#) => "SYN",
Character'Val (16#17#) => "ETB",
Character'Val (16#18#) => "CAN",
Character'Val (16#19#) => "EM ",
Character'Val (16#1A#) => "SUB",
Character'Val (16#1B#) => "ESC",
Character'Val (16#1C#) => "FS ",
Character'Val (16#1D#) => "GS ",
Character'Val (16#1E#) => "RS ",
Character'Val (16#1F#) => "US ");
subtype C1_Range is Character
range Character'Val (16#7F#) .. Character'Val (16#9F#);
C1 : constant array (C1_Range) of Cname :=
(Character'Val (16#7F#) => "DEL",
Character'Val (16#80#) => "res",
Character'Val (16#81#) => "res",
Character'Val (16#82#) => "BPH",
Character'Val (16#83#) => "NBH",
Character'Val (16#84#) => "res",
Character'Val (16#85#) => "NEL",
Character'Val (16#86#) => "SSA",
Character'Val (16#87#) => "ESA",
Character'Val (16#88#) => "HTS",
Character'Val (16#89#) => "HTJ",
Character'Val (16#8A#) => "VTS",
Character'Val (16#8B#) => "PLD",
Character'Val (16#8C#) => "PLU",
Character'Val (16#8D#) => "RI ",
Character'Val (16#8E#) => "SS2",
Character'Val (16#8F#) => "SS3",
Character'Val (16#90#) => "DCS",
Character'Val (16#91#) => "PU1",
Character'Val (16#92#) => "PU2",
Character'Val (16#93#) => "STS",
Character'Val (16#94#) => "CCH",
Character'Val (16#95#) => "MW ",
Character'Val (16#96#) => "SPA",
Character'Val (16#97#) => "EPA",
Character'Val (16#98#) => "SOS",
Character'Val (16#99#) => "res",
Character'Val (16#9A#) => "SCI",
Character'Val (16#9B#) => "CSI",
Character'Val (16#9C#) => "ST ",
Character'Val (16#9D#) => "OSC",
Character'Val (16#9E#) => "PM ",
Character'Val (16#9F#) => "APC");
begin
-- Control characters are represented by their names (RM 3.5(32))
if V in C0_Range then
S := C0 (V);
if S (3) = ' ' then
return S (1 .. 2);
else
return S;
end if;
elsif V in C1_Range then
S := C1 (V);
if S (1) /= 'r' then
if S (3) = ' ' then
return S (1 .. 2);
else
return S;
end if;
-- Special case, res means RESERVED_nnn where nnn is the three digit
-- decimal value corresponding to the code position (more efficient
-- to compute than to store!)
else
declare
VP : constant Natural := Character'Pos (V);
St : String (1 .. 12) := "RESERVED_xxx";
begin
St (10) := Character'Val (48 + VP / 100);
St (11) := Character'Val (48 + (VP / 10) mod 10);
St (12) := Character'Val (48 + VP mod 10);
return St;
end;
end if;
-- Normal characters yield the character enlosed in quotes (RM 3.5(32))
else
S (1) := ''';
S (2) := V;
S (3) := ''';
return S;
end if;
end Image_Character;
end System.Img_Char;
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