Skip to content

R
riscv-gcc-1
Commit 84481f76 by Richard Kenner
Options

New Language: Ada 

From-SVN: r45952
parent 62a04081
Showing with 4948 additions and 0 deletions
gcc/ada/51osinte.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . O S _ I N T E R F A C E --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $
-- --
-- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 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 is a UnixWare (Native) version of this package
pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during
-- tasking operations. It causes infinite loops and other problems.
with Interfaces.C;
package body System.OS_Interface is
use Interfaces.C;
-----------------
-- To_Duration --
-----------------
function To_Duration (TS : timespec) return Duration is
begin
return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
end To_Duration;
function To_Duration (TV : struct_timeval) return Duration is
begin
return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
end To_Duration;
-----------------
-- To_Timespec --
-----------------
function To_Timespec (D : Duration) return timespec is
S : time_t;
F : Duration;
begin
S := time_t (Long_Long_Integer (D));
F := D - Duration (S);
-- If F has negative value due to a round-up, adjust for positive F
-- value.
if F < 0.0 then
S := S - 1;
F := F + 1.0;
end if;
return timespec' (tv_sec => S,
tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
----------------
-- To_Timeval --
----------------
function To_Timeval (D : Duration) return struct_timeval is
S : long;
F : Duration;
begin
S := long (Long_Long_Integer (D));
F := D - Duration (S);
-- If F has negative value due to a round-up, adjust for positive F
-- value.
if F < 0.0 then
S := S - 1;
F := F + 1.0;
end if;
return struct_timeval' (tv_sec => S,
tv_usec => long (Long_Long_Integer (F * 10#1#E6)));
end To_Timeval;
-------------------
-- clock_gettime --
-------------------
function clock_gettime
(clock_id : clockid_t;
tp : access timespec) return int
is
Result : int;
tv : aliased struct_timeval;
function gettimeofday
(tv : access struct_timeval;
tz : System.Address := System.Null_Address) return int;
pragma Import (C, gettimeofday, "gettimeofday");
begin
Result := gettimeofday (tv'Unchecked_Access);
tp.all := To_Timespec (To_Duration (tv));
return Result;
end clock_gettime;
---------------------------
-- POSIX.1c Section 3 --
---------------------------
function sigwait (set : access sigset_t; sig : access Signal) return int is
Result : int;
function sigwait (set : access sigset_t) return int;
pragma Import (C, sigwait, "sigwait");
begin
Result := sigwait (set);
if Result < 0 then
sig.all := 0;
return errno;
end if;
sig.all := Signal (Result);
return 0;
end sigwait;
function pthread_kill (thread : pthread_t; sig : Signal) return int is
function pthread_kill_base
(thread : access pthread_t; sig : access Signal) return int;
pragma Import (C, pthread_kill_base, "pthread_kill");
thr : aliased pthread_t := thread;
signo : aliased Signal := sig;
begin
return pthread_kill_base (thr'Unchecked_Access, signo'Unchecked_Access);
end pthread_kill;
function Get_Stack_Base (thread : pthread_t) return Address is
begin
return Null_Address;
end Get_Stack_Base;
procedure pthread_init is
begin
null;
end pthread_init;
end System.OS_Interface;
gcc/ada/52system.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M --
-- --
-- S p e c --
-- (LynxOS PPC/x86 Version)
-- --
-- $Revision: 1.4 $
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 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 is
pragma Pure (System);
-- Note that we take advantage of the implementation permission to
-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
type Name is (SYSTEM_NAME_GNAT);
System_Name : constant Name := SYSTEM_NAME_GNAT;
-- System-Dependent Named Numbers
Min_Int : constant := Long_Long_Integer'First;
Max_Int : constant := Long_Long_Integer'Last;
Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
Max_Nonbinary_Modulus : constant := Integer'Last;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := Standard'Tick;
-- Storage-related Declarations
type Address is private;
Null_Address : constant Address;
Storage_Unit : constant := Standard'Storage_Unit;
Word_Size : constant := Standard'Word_Size;
Memory_Size : constant := 2 ** Standard'Address_Size;
-- Address comparison
function "<" (Left, Right : Address) return Boolean;
function "<=" (Left, Right : Address) return Boolean;
function ">" (Left, Right : Address) return Boolean;
function ">=" (Left, Right : Address) return Boolean;
function "=" (Left, Right : Address) return Boolean;
pragma Import (Intrinsic, "<");
pragma Import (Intrinsic, "<=");
pragma Import (Intrinsic, ">");
pragma Import (Intrinsic, ">=");
pragma Import (Intrinsic, "=");
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
Default_Bit_Order : constant Bit_Order :=
Bit_Order'Val (Standard'Default_Bit_Order);
-- Priority-related Declarations (RM D.1)
Max_Priority : constant Positive := 30;
Max_Interrupt_Priority : constant Positive := 31;
subtype Any_Priority is Integer
range 0 .. Standard'Max_Interrupt_Priority;
subtype Priority is Any_Priority
range 0 .. Standard'Max_Priority;
-- Functional notation is needed in the following to avoid visibility
-- problems when this package is compiled through rtsfind in the middle
-- of another compilation.
subtype Interrupt_Priority is Any_Priority
range
Standard."+" (Standard'Max_Priority, 1) ..
Standard'Max_Interrupt_Priority;
Default_Priority : constant Priority :=
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
private
type Address is mod Memory_Size;
Null_Address : constant Address := 0;
--------------------------------------
-- System Implementation Parameters --
--------------------------------------
-- These parameters provide information about the target that is used
-- by the compiler. They are in the private part of System, where they
-- can be accessed using the special circuitry in the Targparm unit
-- whose source should be consulted for more detailed descriptions
-- of the individual switch values.
AAMP : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
Denorm : constant Boolean := True;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
Long_Shifts_Inlined : constant Boolean := True;
High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := False;
end System;
gcc/ada/5amastop.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- SYSTEM.MACHINE_STATE_OPERATIONS --
-- --
-- B o d y --
-- (Version for Alpha/Dec Unix) --
-- --
-- $Revision: 1.5 $
-- --
-- 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 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 version of System.Machine_State_Operations is for use on
-- Alpha systems running DEC Unix.
with System.Memory;
package body System.Machine_State_Operations is
use System.Exceptions;
pragma Linker_Options ("-lexc");
-- Needed for definitions of exc_capture_context and exc_virtual_unwind
----------------------------
-- Allocate_Machine_State --
----------------------------
function Allocate_Machine_State return Machine_State is
use System.Storage_Elements;
function c_machine_state_length return Storage_Offset;
pragma Import (C, c_machine_state_length, "__gnat_machine_state_length");
begin
return Machine_State
(Memory.Alloc (Memory.size_t (c_machine_state_length)));
end Allocate_Machine_State;
-------------------
-- Enter_Handler --
-------------------
procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
procedure c_enter_handler (M : Machine_State; Handler : Handler_Loc);
pragma Import (C, c_enter_handler, "__gnat_enter_handler");
begin
c_enter_handler (M, Handler);
end Enter_Handler;
----------------
-- Fetch_Code --
----------------
function Fetch_Code (Loc : Code_Loc) return Code_Loc is
begin
return Loc;
end Fetch_Code;
------------------------
-- Free_Machine_State --
------------------------
procedure Free_Machine_State (M : in out Machine_State) is
procedure Gnat_Free (M : in Machine_State);
pragma Import (C, Gnat_Free, "__gnat_free");
begin
Gnat_Free (M);
M := Machine_State (Null_Address);
end Free_Machine_State;
------------------
-- Get_Code_Loc --
------------------
function Get_Code_Loc (M : Machine_State) return Code_Loc is
Asm_Call_Size : constant := 4;
function c_get_code_loc (M : Machine_State) return Code_Loc;
pragma Import (C, c_get_code_loc, "__gnat_get_code_loc");
-- Code_Loc returned by c_get_code_loc is the return point but here we
-- want Get_Code_Loc to return the call point. Under DEC Unix a call
-- asm instruction takes 4 bytes. So we must remove this value from
-- c_get_code_loc to have the call point.
begin
return c_get_code_loc (M) - Asm_Call_Size;
end Get_Code_Loc;
--------------------------
-- Machine_State_Length --
--------------------------
function Machine_State_Length
return System.Storage_Elements.Storage_Offset
is
use System.Storage_Elements;
function c_machine_state_length return Storage_Offset;
pragma Import (C, c_machine_state_length, "__gnat_machine_state_length");
begin
return c_machine_state_length;
end Machine_State_Length;
---------------
-- Pop_Frame --
---------------
procedure Pop_Frame
(M : Machine_State;
Info : Subprogram_Info_Type)
is
procedure exc_virtual_unwind
(Fcn : System.Address;
M : Machine_State);
pragma Import (C, exc_virtual_unwind, "exc_virtual_unwind");
begin
exc_virtual_unwind (System.Null_Address, M);
end Pop_Frame;
-----------------------
-- Set_Machine_State --
-----------------------
procedure Set_Machine_State (M : Machine_State) is
procedure c_capture_context (M : Machine_State);
pragma Import (C, c_capture_context, "exc_capture_context");
begin
c_capture_context (M);
Pop_Frame (M, System.Null_Address);
end Set_Machine_State;
------------------------------
-- Set_Signal_Machine_State --
------------------------------
procedure Set_Signal_Machine_State
(M : Machine_State;
Context : System.Address) is
begin
null;
end Set_Signal_Machine_State;
end System.Machine_State_Operations;
gcc/ada/5aosinte.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . O S _ I N T E R F A C E --
-- --
-- B o d y --
-- --
-- $Revision: 1.15 $
-- --
-- Copyright (C) 1991-2001 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 is the DEC Unix and IRIX version of this package.
-- This package encapsulates all direct interfaces to OS services
-- that are needed by children of System.
pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during
-- tasking operations. It causes infinite loops and other problems.
with Interfaces.C; use Interfaces.C;
package body System.OS_Interface is
------------------
-- pthread_init --
------------------
procedure pthread_init is
begin
null;
end pthread_init;
-----------------
-- To_Duration --
-----------------
function To_Duration (TS : timespec) return Duration is
begin
return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
end To_Duration;
function To_Duration (TV : struct_timeval) return Duration is
begin
return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
end To_Duration;
-----------------
-- To_Timespec --
-----------------
function To_Timespec (D : Duration) return timespec is
S : time_t;
F : Duration;
begin
S := time_t (Long_Long_Integer (D));
F := D - Duration (S);
-- If F has negative value due to a round-up, adjust for positive F
-- value.
if F < 0.0 then
S := S - 1;
F := F + 1.0;
end if;
return timespec' (tv_sec => S,
tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
function To_Timeval (D : Duration) return struct_timeval is
S : time_t;
F : Duration;
begin
S := time_t (Long_Long_Integer (D));
F := D - Duration (S);
-- If F has negative value due to a round-up, adjust for positive F
-- value.
if F < 0.0 then
S := S - 1;
F := F + 1.0;
end if;
return struct_timeval' (tv_sec => S,
tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
end To_Timeval;
end System.OS_Interface;
gcc/ada/5asystem.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M --
-- --
-- S p e c --
-- (DEC Unix Version) --
-- --
-- $Revision: 1.20 $
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 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 is
pragma Pure (System);
-- Note that we take advantage of the implementation permission to
-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
type Name is (SYSTEM_NAME_GNAT);
System_Name : constant Name := SYSTEM_NAME_GNAT;
-- System-Dependent Named Numbers
Min_Int : constant := Long_Long_Integer'First;
Max_Int : constant := Long_Long_Integer'Last;
Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
Max_Nonbinary_Modulus : constant := Integer'Last;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := Standard'Tick;
-- Storage-related Declarations
type Address is private;
Null_Address : constant Address;
Storage_Unit : constant := Standard'Storage_Unit;
Word_Size : constant := Standard'Word_Size;
Memory_Size : constant := 2 ** Standard'Address_Size;
-- Address comparison
function "<" (Left, Right : Address) return Boolean;
function "<=" (Left, Right : Address) return Boolean;
function ">" (Left, Right : Address) return Boolean;
function ">=" (Left, Right : Address) return Boolean;
function "=" (Left, Right : Address) return Boolean;
pragma Import (Intrinsic, "<");
pragma Import (Intrinsic, "<=");
pragma Import (Intrinsic, ">");
pragma Import (Intrinsic, ">=");
pragma Import (Intrinsic, "=");
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
Default_Bit_Order : constant Bit_Order := Low_Order_First;
-- Priority-related Declarations (RM D.1)
Max_Priority : constant Positive := 30;
Max_Interrupt_Priority : constant Positive := 31;
subtype Any_Priority is Integer
range 0 .. Standard'Max_Interrupt_Priority;
subtype Priority is Any_Priority
range 0 .. Standard'Max_Priority;
-- Functional notation is needed in the following to avoid visibility
-- problems when this package is compiled through rtsfind in the middle
-- of another compilation.
subtype Interrupt_Priority is Any_Priority
range
Standard."+" (Standard'Max_Priority, 1) ..
Standard'Max_Interrupt_Priority;
Default_Priority : constant Priority :=
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
private
type Address is mod Memory_Size;
Null_Address : constant Address := 0;
--------------------------------------
-- System Implementation Parameters --
--------------------------------------
-- These parameters provide information about the target that is used
-- by the compiler. They are in the private part of System, where they
-- can be accessed using the special circuitry in the Targparm unit
-- whose source should be consulted for more detailed descriptions
-- of the individual switch values.
AAMP : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
Denorm : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := True;
Long_Shifts_Inlined : constant Boolean := True;
High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := True;
Stack_Check_Probes : constant Boolean := True;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := True;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := True;
-- Note: Denorm is False because denormals are only handled properly
-- if the -mieee switch is set, and we do not require this usage.
---------------------------
-- Underlying Priorities --
---------------------------
-- Important note: this section of the file must come AFTER the
-- definition of the system implementation parameters to ensure
-- that the value of these parameters is available for analysis
-- of the declarations here (using Rtsfind at compile time).
-- The underlying priorities table provides a generalized mechanism
-- for mapping from Ada priorities to system priorities. In some
-- cases a 1-1 mapping is not the convenient or optimal choice.
-- For Dec Unix 4.0d, we use a default 1-to-1 mapping that provides
-- the full range of 64 priorities available from the operating system.
-- On DU prior to 4.0d, less than 64 priorities are available so there
-- are two possibilities:
-- Limit your range of priorities to the range provided by the
-- OS (e.g 16 .. 32 on 4.0b)
-- Replace the standard table as described below
-- To replace the default values of the Underlying_Priorities mapping,
-- copy this source file into your build directory, edit the file to
-- reflect your desired behavior, and recompile with the command:
-- $ gcc -c -O3 -gnatpgn system.ads
-- then recompile the run-time parts that depend on this package:
-- $ gnatmake -a -gnatn -O3 <your application>
-- then force rebuilding your application if you need different options:
-- $ gnatmake -f <your options> <your application>
type Priorities_Mapping is array (Any_Priority) of Integer;
pragma Suppress_Initialization (Priorities_Mapping);
-- Suppress initialization in case gnat.adc specifies Normalize_Scalars
Underlying_Priorities : constant Priorities_Mapping :=
(Priority'First => 16,
1 => 17,
2 => 18,
3 => 18,
4 => 18,
5 => 18,
6 => 19,
7 => 19,
8 => 19,
9 => 20,
10 => 20,
11 => 21,
12 => 21,
13 => 22,
14 => 23,
Default_Priority => 24,
16 => 25,
17 => 25,
18 => 25,
19 => 26,
20 => 26,
21 => 26,
22 => 27,
23 => 27,
24 => 27,
25 => 28,
26 => 28,
27 => 29,
28 => 29,
29 => 30,
Priority'Last => 30,
Interrupt_Priority => 31);
end System;
gcc/ada/5atasinf.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . T A S K _ I N F O --
-- --
-- S p e c --
-- (Compiler Interface) --
-- --
-- $Revision: 1.5 $
-- --
-- Copyright (C) 1998-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 DEC Unix 4.0d version of this package.
-- This package contains the definitions and routines associated with the
-- implementation of the Task_Info pragma.
-- Note: the compiler generates direct calls to this interface, via Rtsfind.
-- Any changes to this interface may require corresponding compiler changes.
with Unchecked_Deallocation;
package System.Task_Info is
pragma Elaborate_Body;
-- To ensure that a body is allowed
-----------------------------------------
-- Implementation of Task_Info Feature --
-----------------------------------------
-- The Task_Info pragma:
-- pragma Task_Info (EXPRESSION);
-- allows the specification on a task by task basis of a value of type
-- System.Task_Info.Task_Info_Type to be passed to a task when it is
-- created. The specification of this type, and the effect on the task
-- that is created is target dependent.
-- The Task_Info pragma appears within a task definition (compare the
-- definition and implementation of pragma Priority). If no such pragma
-- appears, then the value Task_Info_Unspecified is passed. If a pragma
-- is present, then it supplies an alternative value. If the argument of
-- the pragma is a discriminant reference, then the value can be set on
-- a task by task basis by supplying the appropriate discriminant value.
-- Note that this means that the type used for Task_Info_Type must be
-- suitable for use as a discriminant (i.e. a scalar or access type).
------------------
-- Declarations --
------------------
type Scope_Type is
(Process_Scope,
-- Contend only with threads in same process
System_Scope,
-- Contend with all threads on same CPU
Default_Scope);
type Thread_Attributes is record
Bind_To_Cpu_Number : Integer;
-- -1: Do nothing
-- 0: Unbind
-- 1-N: Bind all unbound threads to this CPU
Contention_Scope : Scope_Type;
end record;
type Task_Info_Type is access all Thread_Attributes;
-- Type used for passing information to task create call, using the
-- Task_Info pragma. This type may be specialized for individual
-- implementations, but it must be a type that can be used as a
-- discriminant (i.e. a scalar or access type).
type Task_Image_Type is access String;
-- Used to generate a meaningful identifier for tasks that are variables
-- and components of variables.
procedure Free_Task_Image is new
Unchecked_Deallocation (String, Task_Image_Type);
Unspecified_Thread_Attribute : aliased Thread_Attributes :=
Thread_Attributes'(-1, Default_Scope);
Unspecified_Task_Info : constant Task_Info_Type :=
Unspecified_Thread_Attribute'Access;
-- Value passed to task in the absence of a Task_Info pragma
-- Don't call new here because the tasking run time has not been
-- elaborated yet, so calling Task_Lock is unsafe.
end System.Task_Info;
gcc/ada/5ataspri.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T A S K _ P R I M I T I V E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.8 $
-- --
-- Copyright (C) 1991-2000 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 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 is the DEC Unix 4.0 version of this package.
-- This package provides low-level support for most tasking features.
pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during
-- tasking operations. It causes infinite loops and other problems.
with Interfaces.C;
-- used for int
-- size_t
with System.OS_Interface;
-- used for pthread_mutex_t
-- pthread_cond_t
-- pthread_t
package System.Task_Primitives is
type Lock is limited private;
-- Should be used for implementation of protected objects.
type RTS_Lock is limited private;
-- Should be used inside the runtime system.
-- The difference between Lock and the RTS_Lock is that the later
-- one serves only as a semaphore so that do not check for
-- ceiling violations.
type Task_Body_Access is access procedure;
-- Pointer to the task body's entry point (or possibly a wrapper
-- declared local to the GNARL).
type Private_Data is limited private;
-- Any information that the GNULLI needs maintained on a per-task
-- basis. A component of this type is guaranteed to be included
-- in the Ada_Task_Control_Block.
private
type Lock is record
L : aliased System.OS_Interface.pthread_mutex_t;
Ceiling : Interfaces.C.int;
end record;
type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
type Private_Data is record
Thread : aliased System.OS_Interface.pthread_t;
pragma Atomic (Thread);
-- Thread field may be updated by two different threads of control.
-- (See, Enter_Task and Create_Task in s-taprop.adb).
-- They put the same value (thr_self value). We do not want to
-- use lock on those operations and the only thing we have to
-- make sure is that they are updated in atomic fashion.
CV : aliased System.OS_Interface.pthread_cond_t;
L : aliased RTS_Lock;
-- protection for all components is lock L
end record;
end System.Task_Primitives;
gcc/ada/5avxwork.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . V X W O R K S --
-- --
-- S p e c --
-- --
-- $Revision: 1.3 $ --
-- --
-- Copyright (C) 1998-2001 Free Software Foundation --
-- --
-- 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 is the Alpha VxWorks version of this package.
with Interfaces.C;
package System.VxWorks is
pragma Preelaborate (System.VxWorks);
package IC renames Interfaces.C;
-- Define enough of a Wind Task Control Block in order to
-- obtain the inherited priority. When porting this to
-- different versions of VxWorks (this is based on 5.3[.1]),
-- be sure to look at the definition for WIND_TCB located
-- in $WIND_BASE/target/h/taskLib.h
type Wind_Fill_1 is array (0 .. 16#77#) of IC.unsigned_char;
type Wind_Fill_2 is array (16#80# .. 16#1c7#) of IC.unsigned_char;
type Wind_Fill_3 is array (16#1d8# .. 16#777#) of IC.unsigned_char;
type Wind_TCB is record
Fill_1 : Wind_Fill_1; -- 0x00 - 0x77
Priority : IC.int; -- 0x78 - 0x7b, current (inherited) priority
Normal_Priority : IC.int; -- 0x7c - 0x7f, base priority
Fill_2 : Wind_Fill_2; -- 0x80 - 0x1c7
spare1 : Address; -- 0x1c8 - 0x1cb
spare2 : Address; -- 0x1cc - 0x1cf
spare3 : Address; -- 0x1d0 - 0x1d3
spare4 : Address; -- 0x1d4 - 0x1d7
-- Fill_3 is much smaller on the board runtime, but the larger size
-- below keeps this record compatible with vxsim.
Fill_3 : Wind_Fill_3; -- 0x1d8 - 0x777
end record;
type Wind_TCB_Ptr is access Wind_TCB;
-- Floating point context record. Alpha version
FP_NUM_DREGS : constant := 32;
type Fpx_Array is array (1 .. FP_NUM_DREGS) of IC.double;
type FP_CONTEXT is record
fpx : Fpx_Array;
fpcsr : IC.long;
end record;
pragma Convention (C, FP_CONTEXT);
-- Number of entries in hardware interrupt vector table. Value of
-- 0 disables hardware interrupt handling until it can be tested
Num_HW_Interrupts : constant := 0;
-- VxWorks 5.3 and 5.4 version
type TASK_DESC is record
td_id : IC.int; -- task id
td_name : Address; -- name of task
td_priority : IC.int; -- task priority
td_status : IC.int; -- task status
td_options : IC.int; -- task option bits (see below)
td_entry : Address; -- original entry point of task
td_sp : Address; -- saved stack pointer
td_pStackBase : Address; -- the bottom of the stack
td_pStackLimit : Address; -- the effective end of the stack
td_pStackEnd : Address; -- the actual end of the stack
td_stackSize : IC.int; -- size of stack in bytes
td_stackCurrent : IC.int; -- current stack usage in bytes
td_stackHigh : IC.int; -- maximum stack usage in bytes
td_stackMargin : IC.int; -- current stack margin in bytes
td_errorStatus : IC.int; -- most recent task error status
td_delay : IC.int; -- delay/timeout ticks
end record;
pragma Convention (C, TASK_DESC);
end System.VxWorks;
gcc/ada/5bosinte.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . O S _ I N T E R F A C E --
-- --
-- B o d y --
-- --
-- $Revision: 1.8 $
-- --
-- Copyright (C) 1997-2001, 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 is a AIX (Native) version of this package
pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during
-- tasking operations. It causes infinite loops and other problems.
with Interfaces.C;
package body System.OS_Interface is
use Interfaces.C;
-----------------
-- To_Duration --
-----------------
function To_Duration (TS : timespec) return Duration is
begin
return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
end To_Duration;
function To_Duration (TV : struct_timeval) return Duration is
begin
return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
end To_Duration;
-----------------
-- To_Timespec --
-----------------
function To_Timespec (D : Duration) return timespec is
S : time_t;
F : Duration;
begin
S := time_t (Long_Long_Integer (D));
F := D - Duration (S);
-- If F has negative value due to a round-up, adjust for positive F
-- value.
if F < 0.0 then
S := S - 1;
F := F + 1.0;
end if;
return timespec' (tv_sec => S,
tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
----------------
-- To_Timeval --
----------------
function To_Timeval (D : Duration) return struct_timeval is
S : long;
F : Duration;
begin
S := long (Long_Long_Integer (D));
F := D - Duration (S);
-- If F has negative value due to a round-up, adjust for positive F
-- value.
if F < 0.0 then
S := S - 1;
F := F + 1.0;
end if;
return struct_timeval' (tv_sec => S,
tv_usec => long (Long_Long_Integer (F * 10#1#E6)));
end To_Timeval;
-------------------
-- clock_gettime --
-------------------
function clock_gettime
(clock_id : clockid_t;
tp : access timespec)
return int
is
Result : int;
tv : aliased struct_timeval;
function gettimeofday
(tv : access struct_timeval;
tz : System.Address := System.Null_Address) return int;
pragma Import (C, gettimeofday, "gettimeofday");
begin
Result := gettimeofday (tv'Unchecked_Access);
tp.all := To_Timespec (To_Duration (tv));
return Result;
end clock_gettime;
-----------------
-- sched_yield --
-----------------
-- AIX Thread does not have sched_yield;
function sched_yield return int is
procedure pthread_yield;
pragma Import (C, pthread_yield, "pthread_yield");
begin
pthread_yield;
return 0;
end sched_yield;
function Get_Stack_Base (thread : pthread_t) return Address is
begin
return Null_Address;
end Get_Stack_Base;
end System.OS_Interface;
gcc/ada/5bsystem.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M --
-- --
-- S p e c --
-- (AIX/PPC Version)
-- --
-- $Revision: 1.4 $
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 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 is
pragma Pure (System);
-- Note that we take advantage of the implementation permission to
-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
type Name is (SYSTEM_NAME_GNAT);
System_Name : constant Name := SYSTEM_NAME_GNAT;
-- System-Dependent Named Numbers
Min_Int : constant := Long_Long_Integer'First;
Max_Int : constant := Long_Long_Integer'Last;
Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
Max_Nonbinary_Modulus : constant := Integer'Last;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := Standard'Tick;
-- Storage-related Declarations
type Address is private;
Null_Address : constant Address;
Storage_Unit : constant := Standard'Storage_Unit;
Word_Size : constant := Standard'Word_Size;
Memory_Size : constant := 2 ** Standard'Address_Size;
-- Address comparison
function "<" (Left, Right : Address) return Boolean;
function "<=" (Left, Right : Address) return Boolean;
function ">" (Left, Right : Address) return Boolean;
function ">=" (Left, Right : Address) return Boolean;
function "=" (Left, Right : Address) return Boolean;
pragma Import (Intrinsic, "<");
pragma Import (Intrinsic, "<=");
pragma Import (Intrinsic, ">");
pragma Import (Intrinsic, ">=");
pragma Import (Intrinsic, "=");
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
Default_Bit_Order : constant Bit_Order :=
Bit_Order'Val (Standard'Default_Bit_Order);
-- Priority-related Declarations (RM D.1)
Max_Priority : constant Positive := 30;
Max_Interrupt_Priority : constant Positive := 31;
subtype Any_Priority is Integer
range 0 .. Standard'Max_Interrupt_Priority;
subtype Priority is Any_Priority
range 0 .. Standard'Max_Priority;
-- Functional notation is needed in the following to avoid visibility
-- problems when this package is compiled through rtsfind in the middle
-- of another compilation.
subtype Interrupt_Priority is Any_Priority
range
Standard."+" (Standard'Max_Priority, 1) ..
Standard'Max_Interrupt_Priority;
Default_Priority : constant Priority :=
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
private
type Address is mod Memory_Size;
Null_Address : constant Address := 0;
--------------------------------------
-- System Implementation Parameters --
--------------------------------------
-- These parameters provide information about the target that is used
-- by the compiler. They are in the private part of System, where they
-- can be accessed using the special circuitry in the Targparm unit
-- whose source should be consulted for more detailed descriptions
-- of the individual switch values.
AAMP : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
Denorm : constant Boolean := True;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
Long_Shifts_Inlined : constant Boolean := True;
High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := False;
end System;
gcc/ada/5esystem.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M --
-- --
-- S p e c --
-- (X86 Solaris Version) --
-- --
-- $Revision: 1.10 $
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 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 is
pragma Pure (System);
-- Note that we take advantage of the implementation permission to
-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
type Name is (SYSTEM_NAME_GNAT);
System_Name : constant Name := SYSTEM_NAME_GNAT;
-- System-Dependent Named Numbers
Min_Int : constant := Long_Long_Integer'First;
Max_Int : constant := Long_Long_Integer'Last;
Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
Max_Nonbinary_Modulus : constant := Integer'Last;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := Standard'Tick;
-- Storage-related Declarations
type Address is private;
Null_Address : constant Address;
Storage_Unit : constant := Standard'Storage_Unit;
Word_Size : constant := Standard'Word_Size;
Memory_Size : constant := 2 ** Standard'Address_Size;
-- Address comparison
function "<" (Left, Right : Address) return Boolean;
function "<=" (Left, Right : Address) return Boolean;
function ">" (Left, Right : Address) return Boolean;
function ">=" (Left, Right : Address) return Boolean;
function "=" (Left, Right : Address) return Boolean;
pragma Import (Intrinsic, "<");
pragma Import (Intrinsic, "<=");
pragma Import (Intrinsic, ">");
pragma Import (Intrinsic, ">=");
pragma Import (Intrinsic, "=");
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
Default_Bit_Order : constant Bit_Order := Low_Order_First;
-- Priority-related Declarations (RM D.1)
Max_Priority : constant Positive := 30;
Max_Interrupt_Priority : constant Positive := 31;
subtype Any_Priority is Integer
range 0 .. Standard'Max_Interrupt_Priority;
subtype Priority is Any_Priority
range 0 .. Standard'Max_Priority;
-- Functional notation is needed in the following to avoid visibility
-- problems when this package is compiled through rtsfind in the middle
-- of another compilation.
subtype Interrupt_Priority is Any_Priority
range
Standard."+" (Standard'Max_Priority, 1) ..
Standard'Max_Interrupt_Priority;
Default_Priority : constant Priority :=
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
private
type Address is mod Memory_Size;
Null_Address : constant Address := 0;
--------------------------------------
-- System Implementation Parameters --
--------------------------------------
-- These parameters provide information about the target that is used
-- by the compiler. They are in the private part of System, where they
-- can be accessed using the special circuitry in the Targparm unit
-- whose source should be consulted for more detailed descriptions
-- of the individual switch values.
AAMP : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
Denorm : constant Boolean := True;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
Long_Shifts_Inlined : constant Boolean := True;
High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := True;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := False;
end System;
gcc/ada/5etpopse.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SELF --
-- --
-- B o d y --
-- --
-- $Revision: 1.1 $ --
-- --
-- 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 is a Solaris/X86 (native) version of this package.
separate (System.Task_Primitives.Operations)
----------
-- Self --
----------
function Self return Task_ID is
Temp : aliased System.Address;
Result : Interfaces.C.int;
begin
Result := thr_getspecific (ATCB_Key, Temp'Unchecked_Access);
pragma Assert (Result = 0);
return To_Task_ID (Temp);
end Self;
gcc/ada/5fintman.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
-- --
-- B o d y --
-- --
-- $Revision: 1.5 $
-- --
-- Copyright (C) 1991-2001, 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 is a SGI Pthread version of this package.
-- PLEASE DO NOT add any dependences on other packages.
-- This package is designed to work with or without tasking support.
-- Make a careful study of all signals available under the OS,
-- to see which need to be reserved, kept always unmasked,
-- or kept always unmasked.
-- Be on the lookout for special signals that
-- may be used by the thread library.
with Interfaces.C;
-- used for int
with System.OS_Interface;
-- used for various Constants, Signal and types
package body System.Interrupt_Management is
use System.OS_Interface;
type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
Exception_Interrupts : constant Interrupt_List :=
(SIGTSTP, SIGILL, SIGTRAP, SIGEMT, SIGFPE, SIGBUS, SIGSTOP, SIGKILL,
SIGSEGV, SIGSYS, SIGXCPU, SIGXFSZ, SIGPROF, SIGPTINTR, SIGPTRESCHED,
SIGABRT, SIGPIPE);
---------------------------
-- Initialize_Interrupts --
---------------------------
-- Nothing needs to be done on this platform.
procedure Initialize_Interrupts is
begin
null;
end Initialize_Interrupts;
Unreserve_All_Interrupts : Interfaces.C.int;
pragma Import
(C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
use type Interfaces.C.int;
begin
Abort_Task_Interrupt := SIGABRT;
-- Change this if you want to use another signal for task abort.
-- SIGTERM might be a good one.
for I in Exception_Interrupts'Range loop
Keep_Unmasked (Exception_Interrupts (I)) := True;
end loop;
-- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but in the
-- same time, disable the ability of handling this signal via
-- Ada.Interrupts.
-- The pragma Unreserve_All_Interrupts let the user the ability to
-- change this behavior.
if Unreserve_All_Interrupts = 0 then
Keep_Unmasked (SIGINT) := True;
end if;
Keep_Unmasked (Abort_Task_Interrupt) := True;
Reserve := Keep_Unmasked or Keep_Masked;
Reserve (0) := True;
end System.Interrupt_Management;
gcc/ada/5fsystem.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M --
-- --
-- S p e c --
-- (SGI Irix, o32 ABI) --
-- --
-- $Revision: 1.13 $
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 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 is
pragma Pure (System);
-- Note that we take advantage of the implementation permission to
-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
type Name is (SYSTEM_NAME_GNAT);
System_Name : constant Name := SYSTEM_NAME_GNAT;
-- System-Dependent Named Numbers
Min_Int : constant := Long_Long_Integer'First;
Max_Int : constant := Long_Long_Integer'Last;
Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
Max_Nonbinary_Modulus : constant := Integer'Last;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := Standard'Tick;
-- Storage-related Declarations
type Address is private;
Null_Address : constant Address;
Storage_Unit : constant := Standard'Storage_Unit;
Word_Size : constant := Standard'Word_Size;
Memory_Size : constant := 2 ** Standard'Address_Size;
-- Address comparison
function "<" (Left, Right : Address) return Boolean;
function "<=" (Left, Right : Address) return Boolean;
function ">" (Left, Right : Address) return Boolean;
function ">=" (Left, Right : Address) return Boolean;
function "=" (Left, Right : Address) return Boolean;
pragma Import (Intrinsic, "<");
pragma Import (Intrinsic, "<=");
pragma Import (Intrinsic, ">");
pragma Import (Intrinsic, ">=");
pragma Import (Intrinsic, "=");
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
Default_Bit_Order : constant Bit_Order := High_Order_First;
-- Priority-related Declarations (RM D.1)
Max_Priority : constant Positive := 30;
Max_Interrupt_Priority : constant Positive := 31;
subtype Any_Priority is Integer
range 0 .. Standard'Max_Interrupt_Priority;
subtype Priority is Any_Priority
range 0 .. Standard'Max_Priority;
-- Functional notation is needed in the following to avoid visibility
-- problems when this package is compiled through rtsfind in the middle
-- of another compilation.
subtype Interrupt_Priority is Any_Priority
range
Standard."+" (Standard'Max_Priority, 1) ..
Standard'Max_Interrupt_Priority;
Default_Priority : constant Priority :=
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
private
type Address is mod Memory_Size;
Null_Address : constant Address := 0;
--------------------------------------
-- System Implementation Parameters --
--------------------------------------
-- These parameters provide information about the target that is used
-- by the compiler. They are in the private part of System, where they
-- can be accessed using the special circuitry in the Targparm unit
-- whose source should be consulted for more detailed descriptions
-- of the individual switch values.
AAMP : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
Denorm : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := True;
Long_Shifts_Inlined : constant Boolean := True;
High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := True;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := True;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := True;
-- Note: Denorm is False because denormals are not supported on the
-- R10000, and we want the code to be valid for this processor.
end System;
gcc/ada/5ftasinf.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . T A S K _ I N F O --
-- --
-- S p e c --
-- (Compiler Interface) --
-- --
-- $Revision: 1.4 $
-- --
-- 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 definitions and routines associated with the
-- implementation of the Task_Info pragma. It is specialized appropriately
-- for targets that make use of this pragma.
-- Note: the compiler generates direct calls to this interface, via Rtsfind.
-- Any changes to this interface may require corresponding compiler changes.
with Interfaces.C;
with System.OS_Interface;
with Unchecked_Deallocation;
package System.Task_Info is
pragma Elaborate_Body;
-- To ensure that a body is allowed
package OSI renames System.OS_Interface;
-----------------------------------------
-- Implementation of Task_Info Feature --
-----------------------------------------
-- Pragma Task_Info allows an application to set the underlying
-- pthread scheduling attributes for a specific task.
------------------
-- Declarations --
------------------
type Thread_Scheduling_Scope is
(PTHREAD_SCOPE_PROCESS, PTHREAD_SCOPE_SYSTEM);
for Thread_Scheduling_Scope'Size use Interfaces.C.int'Size;
type Thread_Scheduling_Inheritance is
(PTHREAD_EXPLICIT_SCHED, PTHREAD_INHERIT_SCHED);
for Thread_Scheduling_Inheritance'Size use Interfaces.C.int'Size;
type Thread_Scheduling_Policy is
(SCHED_FIFO, -- The first-in-first-out real-time policy
SCHED_RR, -- The round-robin real-time scheduling policy
SCHED_TS); -- The timeshare earnings based scheduling policy
for Thread_Scheduling_Policy'Size use Interfaces.C.int'Size;
for Thread_Scheduling_Policy use
(SCHED_FIFO => 1,
SCHED_RR => 2,
SCHED_TS => 3);
function SCHED_OTHER return Thread_Scheduling_Policy renames SCHED_TS;
No_Specified_Priority : constant := -1;
subtype Thread_Scheduling_Priority is Integer range
No_Specified_Priority .. 255;
function Min (Policy : Interfaces.C.int) return Interfaces.C.int
renames OSI.sched_get_priority_min;
function Max (Policy : Interfaces.C.int) return Interfaces.C.int
renames OSI.sched_get_priority_max;
subtype FIFO_Priority is Thread_Scheduling_Priority range
Thread_Scheduling_Priority (Min (OSI.SCHED_FIFO)) ..
Thread_Scheduling_Priority (Max (OSI.SCHED_FIFO));
subtype RR_Priority is Thread_Scheduling_Priority range
Thread_Scheduling_Priority (Min (OSI.SCHED_RR)) ..
Thread_Scheduling_Priority (Max (OSI.SCHED_RR));
subtype TS_Priority is Thread_Scheduling_Priority range
Thread_Scheduling_Priority (Min (OSI.SCHED_TS)) ..
Thread_Scheduling_Priority (Max (OSI.SCHED_TS));
subtype OTHER_Priority is Thread_Scheduling_Priority range
Thread_Scheduling_Priority (Min (OSI.SCHED_OTHER)) ..
Thread_Scheduling_Priority (Max (OSI.SCHED_OTHER));
subtype CPU_Number is Integer range -1 .. Integer'Last;
ANY_CPU : constant CPU_Number := CPU_Number'First;
type Thread_Attributes is record
Scope : Thread_Scheduling_Scope := PTHREAD_SCOPE_PROCESS;
Inheritance : Thread_Scheduling_Inheritance := PTHREAD_EXPLICIT_SCHED;
Policy : Thread_Scheduling_Policy := SCHED_RR;
Priority : Thread_Scheduling_Priority := No_Specified_Priority;
Runon_CPU : CPU_Number := ANY_CPU;
end record;
Default_Thread_Attributes : constant Thread_Attributes :=
(PTHREAD_SCOPE_PROCESS, PTHREAD_EXPLICIT_SCHED, SCHED_RR,
No_Specified_Priority, ANY_CPU);
type Task_Info_Type is access all Thread_Attributes;
type Task_Image_Type is access String;
-- Used to generate a meaningful identifier for tasks that are variables
-- and components of variables.
procedure Free_Task_Image is new
Unchecked_Deallocation (String, Task_Image_Type);
Unspecified_Task_Info : constant Task_Info_Type := null;
-- Value passed to task in the absence of a Task_Info pragma
end System.Task_Info;
gcc/ada/5gintman.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
-- --
-- B o d y --
-- --
-- $Revision: 1.6 $ --
-- --
-- Copyright (C) 1997-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 is an Irix (old pthread library) version of this package.
-- PLEASE DO NOT add any dependences on other packages.
-- This package is designed to work with or without tasking support.
-- Make a careful study of all signals available under the OS,
-- to see which need to be reserved, kept always unmasked,
-- or kept always unmasked.
-- Be on the lookout for special signals that
-- may be used by the thread library.
with System.OS_Interface;
-- used for various Constants, Signal and types
package body System.Interrupt_Management is
use System.OS_Interface;
type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
Exception_Interrupts : constant Interrupt_List :=
(SIGILL,
SIGABRT,
SIGFPE,
SIGSEGV,
SIGBUS);
Reserved_Interrupts : constant Interrupt_List :=
(0,
SIGTRAP,
SIGKILL,
SIGSYS,
SIGALRM,
SIGSTOP,
SIGPTINTR,
SIGPTRESCHED);
Abort_Signal : constant := 48;
--
-- Serious MOJO: The SGI pthreads library only supports the
-- unnamed signal number 48 for pthread_kill!
--
----------------------
-- Notify_Exception --
----------------------
-- This function identifies the Ada exception to be raised using the
-- information when the system received a synchronous signal.
-- Since this function is machine and OS dependent, different code has to
-- be provided for different target.
-- On SGI, the signal handling is done is a-init.c, even when tasking is
-- involved.
---------------------------
-- Initialize_Interrupts --
---------------------------
-- Nothing needs to be done on this platform.
procedure Initialize_Interrupts is
begin
null;
end Initialize_Interrupts;
begin
Abort_Task_Interrupt := Abort_Signal;
for I in Reserved_Interrupts'Range loop
Keep_Unmasked (Reserved_Interrupts (I)) := True;
Reserve (Reserved_Interrupts (I)) := True;
end loop;
for I in Exception_Interrupts'Range loop
Keep_Unmasked (Exception_Interrupts (I)) := True;
Reserve (Reserved_Interrupts (I)) := True;
end loop;
end System.Interrupt_Management;
gcc/ada/5gproinf.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . P R O G R A M _ I N F O --
-- --
-- B o d y --
-- --
-- $Revision: 1.7 $
-- --
-- Copyright (C) 1997-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). --
-- --
------------------------------------------------------------------------------
-- This is an Irix (old pthread library) version of this package.
-- This package contains the parameters used by the run-time system at
-- program startup. These parameters are isolated in this package body to
-- facilitate replacement by the end user.
--
-- To replace the default values, copy this source file into your build
-- directory, edit the file to reflect your desired behavior, and recompile
-- with the command:
--
-- % gcc -c -O2 -gnatpg s-proinf.adb
--
-- then relink your application as usual.
--
with GNAT.OS_Lib;
package body System.Program_Info is
Kbytes : constant := 1024;
Default_Initial_Sproc_Count : constant := 0;
Default_Max_Sproc_Count : constant := 128;
Default_Sproc_Stack_Size : constant := 16#4000#;
Default_Stack_Guard_Pages : constant := 1;
Default_Default_Time_Slice : constant := 0.0;
Default_Default_Task_Stack : constant := 12 * Kbytes;
Default_Pthread_Sched_Signal : constant := 35;
Default_Pthread_Arena_Size : constant := 16#40000#;
Default_Os_Default_Priority : constant := 0;
-------------------------
-- Initial_Sproc_Count --
-------------------------
function Initial_Sproc_Count return Integer is
function sysmp (P1 : Integer) return Integer;
pragma Import (C, sysmp, "sysmp", "sysmp");
MP_NPROCS : constant := 1; -- # processor in complex
Pthread_Sproc_Count : constant GNAT.OS_Lib.String_Access :=
GNAT.OS_Lib.Getenv ("PTHREAD_SPROC_COUNT");
begin
if Pthread_Sproc_Count.all'Length = 0 then
return Default_Initial_Sproc_Count;
elsif Pthread_Sproc_Count.all = "AUTO" then
return sysmp (MP_NPROCS);
else
return Integer'Value (Pthread_Sproc_Count.all);
end if;
exception
when others =>
return Default_Initial_Sproc_Count;
end Initial_Sproc_Count;
---------------------
-- Max_Sproc_Count --
---------------------
function Max_Sproc_Count return Integer is
Pthread_Max_Sproc_Count : constant GNAT.OS_Lib.String_Access :=
GNAT.OS_Lib.Getenv ("PTHREAD_MAX_SPROC_COUNT");
begin
if Pthread_Max_Sproc_Count.all'Length = 0 then
return Default_Max_Sproc_Count;
else
return Integer'Value (Pthread_Max_Sproc_Count.all);
end if;
exception
when others =>
return Default_Max_Sproc_Count;
end Max_Sproc_Count;
----------------------
-- Sproc_Stack_Size --
----------------------
function Sproc_Stack_Size return Integer is
begin
return Default_Sproc_Stack_Size;
end Sproc_Stack_Size;
------------------------
-- Default_Time_Slice --
------------------------
function Default_Time_Slice return Duration is
Pthread_Time_Slice_Sec : constant GNAT.OS_Lib.String_Access :=
GNAT.OS_Lib.Getenv ("PTHREAD_TIME_SLICE_SEC");
Pthread_Time_Slice_Usec : constant GNAT.OS_Lib.String_Access :=
GNAT.OS_Lib.Getenv ("PTHREAD_TIME_SLICE_USEC");
Val_Sec, Val_Usec : Integer := 0;
begin
if Pthread_Time_Slice_Sec.all'Length /= 0 or
Pthread_Time_Slice_Usec.all'Length /= 0
then
if Pthread_Time_Slice_Sec.all'Length /= 0 then
Val_Sec := Integer'Value (Pthread_Time_Slice_Sec.all);
end if;
if Pthread_Time_Slice_Usec.all'Length /= 0 then
Val_Usec := Integer'Value (Pthread_Time_Slice_Usec.all);
end if;
return Duration (Val_Sec) + Duration (Val_Usec) / 1000.0;
else
return Default_Default_Time_Slice;
end if;
exception
when others =>
return Default_Default_Time_Slice;
end Default_Time_Slice;
------------------------
-- Default_Task_Stack --
------------------------
function Default_Task_Stack return Integer is
begin
return Default_Default_Task_Stack;
end Default_Task_Stack;
-----------------------
-- Stack_Guard_Pages --
-----------------------
function Stack_Guard_Pages return Integer is
Pthread_Stack_Guard_Pages : constant GNAT.OS_Lib.String_Access :=
GNAT.OS_Lib.Getenv ("PTHREAD_STACK_GUARD_PAGES");
begin
if Pthread_Stack_Guard_Pages.all'Length /= 0 then
return Integer'Value (Pthread_Stack_Guard_Pages.all);
else
return Default_Stack_Guard_Pages;
end if;
exception
when others =>
return Default_Stack_Guard_Pages;
end Stack_Guard_Pages;
--------------------------
-- Pthread_Sched_Signal --
--------------------------
function Pthread_Sched_Signal return Integer is
begin
return Default_Pthread_Sched_Signal;
end Pthread_Sched_Signal;
------------------------
-- Pthread_Arena_Size --
------------------------
function Pthread_Arena_Size return Integer is
Pthread_Arena_Size : constant GNAT.OS_Lib.String_Access :=
GNAT.OS_Lib.Getenv ("PTHREAD_ARENA_SIZE");
begin
if Pthread_Arena_Size.all'Length = 0 then
return Default_Pthread_Arena_Size;
else
return Integer'Value (Pthread_Arena_Size.all);
end if;
exception
when others =>
return Default_Pthread_Arena_Size;
end Pthread_Arena_Size;
-------------------------
-- Os_Default_Priority --
-------------------------
function Os_Default_Priority return Integer is
begin
return Default_Os_Default_Priority;
end Os_Default_Priority;
end System.Program_Info;
gcc/ada/5gproinf.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . P R O G R A M _ I N F O --
-- --
-- S p e c --
-- --
-- $Revision: 1.1 $ --
-- --
-- Copyright (C) 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 package contains the definitions and routines used as parameters
-- to the run-time system at program startup for the SGI implementation.
package System.Program_Info is
function Initial_Sproc_Count return Integer;
--
-- The number of sproc created at program startup for scheduling
-- threads.
--
function Max_Sproc_Count return Integer;
--
-- The maximum number of sprocs that can be created by the program
-- for servicing threads. This limit includes both the pre-created
-- sprocs and those explicitly created under program control.
--
function Sproc_Stack_Size return Integer;
--
-- The size, in bytes, of the sproc's initial stack.
--
function Default_Time_Slice return Duration;
--
-- The default time quanta for round-robin scheduling of threads of
-- equal priority. This default value can be overridden on a per-task
-- basis by specifying an alternate value via the implementation-defined
-- Task_Info pragma. See s-tasinf.ads for more information.
--
function Default_Task_Stack return Integer;
--
-- The default stack size for each created thread. This default value
-- can be overriden on a per-task basis by the language-defined
-- Storage_Size pragma.
--
function Stack_Guard_Pages return Integer;
--
-- The number of non-writable, guard pages to append to the bottom of
-- each thread's stack.
--
function Pthread_Sched_Signal return Integer;
--
-- The signal used by the Pthreads library to affect scheduling actions
-- in remote sprocs.
--
function Pthread_Arena_Size return Integer;
--
-- The size of the shared arena from which pthread locks are allocated.
-- See the usinit(3p) man page for more information on shared arenas.
--
function Os_Default_Priority return Integer;
--
-- The default Irix Non-Degrading priority for each sproc created to
-- service threads.
--
end System.Program_Info;
gcc/ada/5gsystem.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M --
-- --
-- S p e c --
-- (SGI Irix, n32 ABI) --
-- --
-- $Revision: 1.19 $
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 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 is
pragma Pure (System);
-- Note that we take advantage of the implementation permission to
-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
type Name is (SYSTEM_NAME_GNAT);
System_Name : constant Name := SYSTEM_NAME_GNAT;
-- System-Dependent Named Numbers
Min_Int : constant := Long_Long_Integer'First;
Max_Int : constant := Long_Long_Integer'Last;
Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
Max_Nonbinary_Modulus : constant := Integer'Last;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := Standard'Tick;
-- Storage-related Declarations
type Address is private;
Null_Address : constant Address;
Storage_Unit : constant := Standard'Storage_Unit;
Word_Size : constant := Standard'Word_Size;
Memory_Size : constant := 2 ** Standard'Address_Size;
-- Address comparison
function "<" (Left, Right : Address) return Boolean;
function "<=" (Left, Right : Address) return Boolean;
function ">" (Left, Right : Address) return Boolean;
function ">=" (Left, Right : Address) return Boolean;
function "=" (Left, Right : Address) return Boolean;
pragma Import (Intrinsic, "<");
pragma Import (Intrinsic, "<=");
pragma Import (Intrinsic, ">");
pragma Import (Intrinsic, ">=");
pragma Import (Intrinsic, "=");
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
Default_Bit_Order : constant Bit_Order := High_Order_First;
-- Priority-related Declarations (RM D.1)
Max_Priority : constant Positive := 30;
Max_Interrupt_Priority : constant Positive := 31;
subtype Any_Priority is Integer
range 0 .. Standard'Max_Interrupt_Priority;
subtype Priority is Any_Priority
range 0 .. Standard'Max_Priority;
-- Functional notation is needed in the following to avoid visibility
-- problems when this package is compiled through rtsfind in the middle
-- of another compilation.
subtype Interrupt_Priority is Any_Priority
range
Standard."+" (Standard'Max_Priority, 1) ..
Standard'Max_Interrupt_Priority;
Default_Priority : constant Priority :=
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
private
type Address is mod Memory_Size;
Null_Address : constant Address := 0;
--------------------------------------
-- System Implementation Parameters --
--------------------------------------
-- These parameters provide information about the target that is used
-- by the compiler. They are in the private part of System, where they
-- can be accessed using the special circuitry in the Targparm unit
-- whose source should be consulted for more detailed descriptions
-- of the individual switch values.
AAMP : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
Denorm : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := True;
Long_Shifts_Inlined : constant Boolean := True;
High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := True;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := True;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := True;
-- Note: Denorm is False because denormals are not supported on the
-- R10000, and we want the code to be valid for this processor.
end System;
gcc/ada/5gtpgetc.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T A S K _ P R I M I T I V E S . G E N _ T C B I N F --
-- --
-- B o d y --
-- --
-- $Revision: 1.5 $
-- --
-- Copyright (C) 1999-2000 Free Software Fundation --
-- --
-- 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 is an SGI Irix version of this package
-- This procedure creates the file "a-tcbinf.c"
-- "A-tcbinf.c" is subsequently compiled and made part of the RTL
-- to be referenced by the SGI Workshop debugger. The main procedure:
-- "Gen_Tcbinf" imports this child procedure and runs as part of the
-- RTL build process. Because of the complex process used to build
-- the GNAT RTL for all the different systems and the frequent changes
-- made to the internal data structures, its impractical to create
-- "a-tcbinf.c" using a standalone process.
with System.Tasking;
with Ada.Text_IO;
with Unchecked_Conversion;
procedure System.Task_Primitives.Gen_Tcbinf is
use System.Tasking;
subtype Version_String is String (1 .. 4);
Version : constant Version_String := "3.11";
function To_Integer is new Unchecked_Conversion
(Version_String, Integer);
type Dummy_TCB_Ptr is access Ada_Task_Control_Block (Entry_Num => 0);
Dummy_TCB : constant Dummy_TCB_Ptr := new Ada_Task_Control_Block (0);
C_File : Ada.Text_IO.File_Type;
procedure Pl (S : String);
procedure Nl (C : Ada.Text_IO.Positive_Count := 1);
function State_Name (S : Task_States) return String;
procedure Pl (S : String) is
begin
Ada.Text_IO.Put_Line (C_File, S);
end Pl;
procedure Nl (C : Ada.Text_IO.Positive_Count := 1) is
begin
Ada.Text_IO.New_Line (C_File, C);
end Nl;
function State_Name (S : Task_States) return String is
begin
case S is
when Unactivated =>
return "Unactivated";
when Runnable =>
return "Runnable";
when Terminated =>
return "Terminated";
when Activator_Sleep =>
return "Child Activation Wait";
when Acceptor_Sleep =>
return "Accept/Select Wait";
when Entry_Caller_Sleep =>
return "Waiting on Entry Call";
when Async_Select_Sleep =>
return "Async_Select Wait";
when Delay_Sleep =>
return "Delay Sleep";
when Master_Completion_Sleep =>
return "Child Termination Wait";
when Master_Phase_2_Sleep =>
return "Wait Child in Term Alt";
when Interrupt_Server_Idle_Sleep =>
return "Int Server Idle Sleep";
when Interrupt_Server_Blocked_Interrupt_Sleep =>
return "Int Server Blk Int Sleep";
when Timer_Server_Sleep =>
return "Timer Server Sleep";
when AST_Server_Sleep =>
return "AST Server Sleep";
when Asynchronous_Hold =>
return "Asynchronous Hold";
when Interrupt_Server_Blocked_On_Event_Flag =>
return "Int Server Blk Evt Flag";
end case;
end State_Name;
All_Tasks_Link_Offset : constant Integer
:= Dummy_TCB.Common'Position + Dummy_TCB.Common.All_Tasks_Link'Position;
Entry_Count_Offset : constant Integer
:= Dummy_TCB.Entry_Num'Position;
Entry_Point_Offset : constant Integer
:= Dummy_TCB.Common'Position + Dummy_TCB.Common.Task_Entry_Point'Position;
Parent_Offset : constant Integer
:= Dummy_TCB.Common'Position + Dummy_TCB.Common.Parent'Position;
Base_Priority_Offset : constant Integer
:= Dummy_TCB.Common'Position + Dummy_TCB.Common.Base_Priority'Position;
Current_Priority_Offset : constant Integer
:= Dummy_TCB.Common'Position + Dummy_TCB.Common.Current_Priority'Position;
Stack_Size_Offset : constant Integer
:= Dummy_TCB.Common'Position +
Dummy_TCB.Common.Compiler_Data.Pri_Stack_Info.Size'Position;
State_Offset : constant Integer
:= Dummy_TCB.Common'Position + Dummy_TCB.Common.State'Position;
Task_Image_Offset : constant Integer
:= Dummy_TCB.Common'Position + Dummy_TCB.Common.Task_Image'Position;
Thread_Offset : constant Integer
:= Dummy_TCB.Common'Position + Dummy_TCB.Common.LL'Position +
Dummy_TCB.Common.LL.Thread'Position;
begin
Ada.Text_IO.Create (C_File, Ada.Text_IO.Out_File, "a-tcbinf.c");
Pl ("");
Pl ("#include <sys/types.h>");
Pl ("");
Pl ("#define TCB_INFO_VERSION 2");
Pl ("#define TCB_LIBRARY_VERSION "
& Integer'Image (To_Integer (Version)));
Pl ("");
Pl ("typedef struct {");
Pl ("");
Pl (" __uint32_t info_version;");
Pl (" __uint32_t library_version;");
Pl ("");
Pl (" __uint32_t All_Tasks_Link_Offset;");
Pl (" __uint32_t Entry_Count_Offset;");
Pl (" __uint32_t Entry_Point_Offset;");
Pl (" __uint32_t Parent_Offset;");
Pl (" __uint32_t Base_Priority_Offset;");
Pl (" __uint32_t Current_Priority_Offset;");
Pl (" __uint32_t Stack_Size_Offset;");
Pl (" __uint32_t State_Offset;");
Pl (" __uint32_t Task_Image_Offset;");
Pl (" __uint32_t Thread_Offset;");
Pl ("");
Pl (" char **state_names;");
Pl (" __uint32_t state_names_max;");
Pl ("");
Pl ("} task_control_block_info_t;");
Pl ("");
Pl ("static char *accepting_state_names = NULL;");
Pl ("");
Pl ("static char *task_state_names[] = {");
for State in Task_States loop
Pl (" """ & State_Name (State) & """,");
end loop;
Pl (" """"};");
Pl ("");
Pl ("");
Pl ("task_control_block_info_t __task_control_block_info = {");
Pl ("");
Pl (" TCB_INFO_VERSION,");
Pl (" TCB_LIBRARY_VERSION,");
Pl ("");
Pl (" " & All_Tasks_Link_Offset'Img & ",");
Pl (" " & Entry_Count_Offset'Img & ",");
Pl (" " & Entry_Point_Offset'Img & ",");
Pl (" " & Parent_Offset'Img & ",");
Pl (" " & Base_Priority_Offset'Img & ",");
Pl (" " & Current_Priority_Offset'Img & ",");
Pl (" " & Stack_Size_Offset'Img & ",");
Pl (" " & State_Offset'Img & ",");
Pl (" " & Task_Image_Offset'Img & ",");
Pl (" " & Thread_Offset'Img & ",");
Pl ("");
Pl (" task_state_names,");
Pl (" sizeof (task_state_names),");
Pl ("");
Pl ("");
Pl ("};");
Ada.Text_IO.Close (C_File);
end System.Task_Primitives.Gen_Tcbinf;
gcc/ada/5hparame.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . P A R A M E T E R S --
-- --
-- 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 the HP version of this package
-- This package defines some system dependent parameters for GNAT. These
-- are values that are referenced by the runtime library and are therefore
-- relevant to the target machine.
-- The parameters whose value is defined in the spec are not generally
-- expected to be changed. If they are changed, it will be necessary to
-- recompile the run-time library.
-- The parameters which are defined by functions can be changed by modifying
-- the body of System.Parameters in file s-parame.adb. A change to this body
-- requires only rebinding and relinking of the application.
-- Note: do not introduce any pragma Inline statements into this unit, since
-- otherwise the relinking and rebinding capability would be deactivated.
package System.Parameters is
pragma Pure (Parameters);
---------------------------------------
-- Task And Stack Allocation Control --
---------------------------------------
type Task_Storage_Size is new Integer;
-- Type used in tasking units for task storage size
type Size_Type is new Task_Storage_Size;
-- Type used to provide task storage size to runtime
Unspecified_Size : constant Size_Type := Size_Type'First;
-- Value used to indicate that no size type is set
subtype Ratio is Size_Type range -1 .. 100;
Dynamic : constant Size_Type := -1;
-- The secondary stack ratio is a constant between 0 and 100 which
-- determines the percentage of the allocated task stack that is
-- used by the secondary stack (the rest being the primary stack).
-- The special value of minus one indicates that the secondary
-- stack is to be allocated from the heap instead.
Sec_Stack_Ratio : constant Ratio := Dynamic;
-- This constant defines the handling of the secondary stack
Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic;
-- Convenient Boolean for testing for dynamic secondary stack
function Default_Stack_Size return Size_Type;
-- Default task stack size used if none is specified
function Minimum_Stack_Size return Size_Type;
-- Minimum task stack size permitted
function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
-- Given the storage size stored in the TCB, return the Storage_Size
-- value required by the RM for the Storage_Size attribute. The
-- required adjustment is as follows:
--
-- when Size = Unspecified_Size, return Default_Stack_Size
-- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
-- otherwise return given Size
Stack_Grows_Down : constant Boolean := False;
-- This constant indicates whether the stack grows up (False) or
-- down (True) in memory as functions are called. It is used for
-- proper implementation of the stack overflow check.
----------------------------------------------
-- Characteristics of types in Interfaces.C --
----------------------------------------------
long_bits : constant := Long_Integer'Size;
-- Number of bits in type long and unsigned_long. The normal convention
-- is that this is the same as type Long_Integer, but this is not true
-- of all targets. For example, in OpenVMS long /= Long_Integer.
----------------------------------------------
-- Behavior of Pragma Finalize_Storage_Only --
----------------------------------------------
-- Garbage_Collected is a Boolean constant whose value indicates the
-- effect of the pragma Finalize_Storage_Entry on a controlled type.
-- Garbage_Collected = False
-- The system releases all storage on program termination only,
-- but not other garbage collection occurs, so finalization calls
-- are ommitted only for outer level onjects can be omitted if
-- pragma Finalize_Storage_Only is used.
-- Garbage_Collected = True
-- The system provides full garbage collection, so it is never
-- necessary to release storage for controlled objects for which
-- a pragma Finalize_Storage_Only is used.
Garbage_Collected : constant Boolean := False;
-- The storage mode for this system (release on program exit)
end System.Parameters;
gcc/ada/5hsystem.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M --
-- --
-- S p e c --
-- (HP-UX Version) --
-- --
-- $Revision: 1.15 $
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 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 is
pragma Pure (System);
-- Note that we take advantage of the implementation permission to
-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
type Name is (SYSTEM_NAME_GNAT);
System_Name : constant Name := SYSTEM_NAME_GNAT;
-- System-Dependent Named Numbers
Min_Int : constant := Long_Long_Integer'First;
Max_Int : constant := Long_Long_Integer'Last;
Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
Max_Nonbinary_Modulus : constant := Integer'Last;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := Standard'Tick;
-- Storage-related Declarations
type Address is private;
Null_Address : constant Address;
Storage_Unit : constant := Standard'Storage_Unit;
Word_Size : constant := Standard'Word_Size;
Memory_Size : constant := 2 ** Standard'Address_Size;
-- Address comparison
function "<" (Left, Right : Address) return Boolean;
function "<=" (Left, Right : Address) return Boolean;
function ">" (Left, Right : Address) return Boolean;
function ">=" (Left, Right : Address) return Boolean;
function "=" (Left, Right : Address) return Boolean;
pragma Import (Intrinsic, "<");
pragma Import (Intrinsic, "<=");
pragma Import (Intrinsic, ">");
pragma Import (Intrinsic, ">=");
pragma Import (Intrinsic, "=");
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
Default_Bit_Order : constant Bit_Order := High_Order_First;
-- Priority-related Declarations (RM D.1)
Max_Priority : constant Positive := 30;
Max_Interrupt_Priority : constant Positive := 31;
subtype Any_Priority is Integer
range 0 .. Standard'Max_Interrupt_Priority;
subtype Priority is Any_Priority
range 0 .. Standard'Max_Priority;
-- Functional notation is needed in the following to avoid visibility
-- problems when this package is compiled through rtsfind in the middle
-- of another compilation.
subtype Interrupt_Priority is Any_Priority
range
Standard."+" (Standard'Max_Priority, 1) ..
Standard'Max_Interrupt_Priority;
Default_Priority : constant Priority :=
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
private
type Address is mod Memory_Size;
Null_Address : constant Address := 0;
--------------------------------------
-- System Implementation Parameters --
--------------------------------------
-- These parameters provide information about the target that is used
-- by the compiler. They are in the private part of System, where they
-- can be accessed using the special circuitry in the Targparm unit
-- whose source should be consulted for more detailed descriptions
-- of the individual switch values.
AAMP : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
Denorm : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
Long_Shifts_Inlined : constant Boolean := False;
High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := False;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := False;
--------------------------
-- Underlying Priorities --
---------------------------
-- Important note: this section of the file must come AFTER the
-- definition of the system implementation parameters to ensure
-- that the value of these parameters is available for analysis
-- of the declarations here (using Rtsfind at compile time).
-- The underlying priorities table provides a generalized mechanism
-- for mapping from Ada priorities to system priorities. In some
-- cases a 1-1 mapping is not the convenient or optimal choice.
-- For HP/UX DCE Threads, we use the full range of 31 priorities
-- in the Ada model, but map them by compression onto the more limited
-- range of priorities available in HP/UX.
-- For POSIX Threads, this table is ignored.
-- To replace the default values of the Underlying_Priorities mapping,
-- copy this source file into your build directory, edit the file to
-- reflect your desired behavior, and recompile with the command:
-- $ gcc -c -O2 -gnatpgn system.ads
-- then recompile the run-time parts that depend on this package:
-- $ gnatmake -a -gnatn -O2 <your application>
-- then force rebuilding your application if you need different options:
-- $ gnatmake -f <your options> <your application>
type Priorities_Mapping is array (Any_Priority) of Integer;
pragma Suppress_Initialization (Priorities_Mapping);
-- Suppress initialization in case gnat.adc specifies Normalize_Scalars
Underlying_Priorities : constant Priorities_Mapping :=
(Priority'First => 16,
1 => 17,
2 => 18,
3 => 18,
4 => 18,
5 => 18,
6 => 19,
7 => 19,
8 => 19,
9 => 20,
10 => 20,
11 => 21,
12 => 21,
13 => 22,
14 => 23,
Default_Priority => 24,
16 => 25,
17 => 25,
18 => 25,
19 => 26,
20 => 26,
21 => 26,
22 => 27,
23 => 27,
24 => 27,
25 => 28,
26 => 28,
27 => 29,
28 => 29,
29 => 30,
Priority'Last => 30,
Interrupt_Priority => 31);
end System;
gcc/ada/5htaspri.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T A S K _ P R I M I T I V E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.7 $
-- --
-- Copyright (C) 1991-2000 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 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 is a HP-UX version of this package.
-- This package provides low-level support for most tasking features.
pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during
-- tasking operations. It causes infinite loops and other problems.
with System.OS_Interface;
-- used for pthread_mutex_t
-- pthread_cond_t
-- pthread_t
package System.Task_Primitives is
type Lock is limited private;
-- Should be used for implementation of protected objects.
type RTS_Lock is limited private;
-- Should be used inside the runtime system.
-- The difference between Lock and the RTS_Lock is that the later
-- one serves only as a semaphore so that do not check for
-- ceiling violations.
type Task_Body_Access is access procedure;
-- Pointer to the task body's entry point (or possibly a wrapper
-- declared local to the GNARL).
type Private_Data is limited private;
-- Any information that the GNULLI needs maintained on a per-task
-- basis. A component of this type is guaranteed to be included
-- in the Ada_Task_Control_Block.
private
type Lock is record
L : aliased System.OS_Interface.pthread_mutex_t;
Priority : Integer;
Owner_Priority : Integer;
end record;
type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
type Private_Data is record
Thread : aliased System.OS_Interface.pthread_t;
pragma Atomic (Thread);
-- Thread field may be updated by two different threads of control.
-- (See, Enter_Task and Create_Task in s-taprop.adb).
-- They put the same value (thr_self value). We do not want to
-- use lock on those operations and the only thing we have to
-- make sure is that they are updated in atomic fashion.
CV : aliased System.OS_Interface.pthread_cond_t;
L : aliased RTS_Lock;
-- protection for all components is lock L
end record;
end System.Task_Primitives;
gcc/ada/5iosinte.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . O S _ I N T E R F A C E --
-- --
-- B o d y --
-- --
-- $Revision: 1.12 $
-- --
-- Copyright (C) 1991-2001 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 is a LinuxThreads, Solaris pthread and HP-UX pthread version of this
-- package.
pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during
-- tasking operations. It causes infinite loops and other problems.
-- This package encapsulates all direct interfaces to OS services
-- that are needed by children of System.
with Interfaces.C; use Interfaces.C;
package body System.OS_Interface is
--------------------
-- Get_Stack_Base --
--------------------
function Get_Stack_Base (thread : pthread_t) return Address is
begin
return Null_Address;
end Get_Stack_Base;
------------------
-- pthread_init --
------------------
procedure pthread_init is
begin
null;
end pthread_init;
-----------------
-- To_Duration --
-----------------
function To_Duration (TS : timespec) return Duration is
begin
return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9;
end To_Duration;
function To_Duration (TV : struct_timeval) return Duration is
begin
return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
end To_Duration;
-----------------
-- To_Timespec --
-----------------
function To_Timespec (D : Duration) return timespec is
S : time_t;
F : Duration;
begin
S := time_t (Long_Long_Integer (D));
F := D - Duration (S);
-- If F has negative value due to a round-up, adjust for positive F
-- value.
if F < 0.0 then
S := S - 1;
F := F + 1.0;
end if;
return timespec'
(tv_sec => S, tv_nsec => long (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
----------------
-- To_Timeval --
----------------
function To_Timeval (D : Duration) return struct_timeval is
S : time_t;
F : Duration;
begin
S := time_t (Long_Long_Integer (D));
F := D - Duration (S);
-- If F has negative value due to a round-up, adjust for positive F
-- value.
if F < 0.0 then
S := S - 1;
F := F + 1.0;
end if;
return struct_timeval'
(tv_sec => S, tv_usec => time_t (Long_Long_Integer (F * 10#1#E6)));
end To_Timeval;
end System.OS_Interface;
gcc/ada/5itaspri.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T A S K _ P R I M I T I V E S --
-- --
-- S p e c --
-- --
-- $Revision: 1.5 $
-- --
-- Copyright (C) 1991-2000 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 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 is the Linux (LinuxThreads) version of this package.
-- This package provides low-level support for most tasking features.
pragma Polling (Off);
-- Turn off polling, we do not want ATC polling to take place during
-- tasking operations. It causes infinite loops and other problems.
with System.OS_Interface;
-- used for pthread_mutex_t
-- pthread_cond_t
-- pthread_t
package System.Task_Primitives is
type Lock is limited private;
-- Should be used for implementation of protected objects.
type RTS_Lock is limited private;
-- Should be used inside the runtime system.
-- The difference between Lock and the RTS_Lock is that the later
-- one serves only as a semaphore so that do not check for
-- ceiling violations.
type Task_Body_Access is access procedure;
-- Pointer to the task body's entry point (or possibly a wrapper
-- declared local to the GNARL).
type Private_Data is limited private;
-- Any information that the GNULLI needs maintained on a per-task
-- basis. A component of this type is guaranteed to be included
-- in the Ada_Task_Control_Block.
private
type Prio_Array_Type is array (System.Any_Priority) of Integer;
type Lock is record
L : aliased System.OS_Interface.pthread_mutex_t;
Ceiling : System.Any_Priority := System.Any_Priority'First;
Saved_Priority : System.Any_Priority := System.Any_Priority'First;
end record;
type RTS_Lock is new System.OS_Interface.pthread_mutex_t;
type Private_Data is record
Thread : aliased System.OS_Interface.pthread_t;
pragma Atomic (Thread);
-- Thread field may be updated by two different threads of control.
-- (See, Enter_Task and Create_Task in s-taprop.adb).
-- They put the same value (thr_self value). We do not want to
-- use lock on those operations and the only thing we have to
-- make sure is that they are updated in atomic fashion.
CV : aliased System.OS_Interface.pthread_cond_t;
L : aliased RTS_Lock;
-- protection for all components is lock L
Active_Priority : System.Any_Priority := System.Any_Priority'First;
-- Simulated active priority,
-- used only if Priority_Ceiling_Support is True.
end record;
end System.Task_Primitives;
gcc/ada/5ksystem.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M --
-- --
-- S p e c --
-- (VxWorks version M68K) --
-- --
-- $Revision: 1.11 $
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 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 is
pragma Pure (System);
-- Note that we take advantage of the implementation permission to
-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
type Name is (SYSTEM_NAME_GNAT);
System_Name : constant Name := SYSTEM_NAME_GNAT;
-- System-Dependent Named Numbers
Min_Int : constant := Long_Long_Integer'First;
Max_Int : constant := Long_Long_Integer'Last;
Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
Max_Nonbinary_Modulus : constant := Integer'Last;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := Standard'Tick;
-- Storage-related Declarations
type Address is private;
Null_Address : constant Address;
Storage_Unit : constant := Standard'Storage_Unit;
Word_Size : constant := Standard'Word_Size;
Memory_Size : constant := 2 ** Standard'Address_Size;
-- Address comparison
function "<" (Left, Right : Address) return Boolean;
function "<=" (Left, Right : Address) return Boolean;
function ">" (Left, Right : Address) return Boolean;
function ">=" (Left, Right : Address) return Boolean;
function "=" (Left, Right : Address) return Boolean;
pragma Import (Intrinsic, "<");
pragma Import (Intrinsic, "<=");
pragma Import (Intrinsic, ">");
pragma Import (Intrinsic, ">=");
pragma Import (Intrinsic, "=");
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
Default_Bit_Order : constant Bit_Order :=
Bit_Order'Val (Standard'Default_Bit_Order);
-- Priority-related Declarations (RM D.1)
-- 256 is reserved for the VxWorks kernel
-- 248 - 255 correspond to hardware interrupt levels 0 .. 7
-- 247 is a catchall default "interrupt" priority for signals, allowing
-- higher priority than normal tasks, but lower than hardware
-- priority levels. Protected Object ceilings can override
-- these values
-- 246 is used by the Interrupt_Manager task
Max_Priority : constant Positive := 245;
Max_Interrupt_Priority : constant Positive := 255;
subtype Any_Priority is Integer
range 0 .. Standard'Max_Interrupt_Priority;
subtype Priority is Any_Priority
range 0 .. Standard'Max_Priority;
-- Functional notation is needed in the following to avoid visibility
-- problems when this package is compiled through rtsfind in the middle
-- of another compilation.
subtype Interrupt_Priority is Any_Priority
range
Standard."+" (Standard'Max_Priority, 1) ..
Standard'Max_Interrupt_Priority;
Default_Priority : constant Priority :=
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
private
type Address is mod Memory_Size;
Null_Address : constant Address := 0;
--------------------------------------
-- System Implementation Parameters --
--------------------------------------
-- These parameters provide information about the target that is used
-- by the compiler. They are in the private part of System, where they
-- can be accessed using the special circuitry in the Targparm unit
-- whose source should be consulted for more detailed descriptions
-- of the individual switch values.
AAMP : constant Boolean := False;
Command_Line_Args : constant Boolean := False;
Denorm : constant Boolean := True;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
Long_Shifts_Inlined : constant Boolean := False;
High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := False;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := True;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := False;
end System;
gcc/ada/5kvxwork.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . V X W O R K S --
-- --
-- S p e c --
-- --
-- $Revision: 1.2 $
-- --
-- Copyright (C) 1998-2001 Free Software Foundation --
-- --
-- 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 is the M68K VxWorks version of this package.
with Interfaces.C;
package System.VxWorks is
pragma Preelaborate (System.VxWorks);
package IC renames Interfaces.C;
-- Define enough of a Wind Task Control Block in order to
-- obtain the inherited priority. When porting this to
-- different versions of VxWorks (this is based on 5.3[.1]),
-- be sure to look at the definition for WIND_TCB located
-- in $WIND_BASE/target/h/taskLib.h
type Wind_Fill_1 is array (0 .. 16#3F#) of IC.unsigned_char;
type Wind_Fill_2 is array (16#48# .. 16#107#) of IC.unsigned_char;
type Wind_TCB is record
Fill_1 : Wind_Fill_1; -- 0x00 - 0x3f
Priority : IC.int; -- 0x40 - 0x43, current (inherited) priority
Normal_Priority : IC.int; -- 0x44 - 0x47, base priority
Fill_2 : Wind_Fill_2; -- 0x48 - 0x107
spare1 : Address; -- 0x108 - 0x10b
spare2 : Address; -- 0x10c - 0x10f
spare3 : Address; -- 0x110 - 0x113
spare4 : Address; -- 0x114 - 0x117
end record;
type Wind_TCB_Ptr is access Wind_TCB;
-- Floating point context record. 68K version
FP_NUM_DREGS : constant := 8;
FP_STATE_FRAME_SIZE : constant := 216;
type DOUBLEX is array (1 .. 12) of Interfaces.Unsigned_8;
pragma Pack (DOUBLEX);
for DOUBLEX'Size use 12 * 8;
type DOUBLEX_Array is array (1 .. FP_NUM_DREGS) of DOUBLEX;
pragma Pack (DOUBLEX_Array);
for DOUBLEX_Array'Size use FP_NUM_DREGS * 12 * 8;
type FPREG_SET is record
fpcr : IC.int;
fpsr : IC.int;
fpiar : IC.int;
fpx : DOUBLEX_Array;
end record;
type Fp_State_Frame_Array is array (1 .. FP_STATE_FRAME_SIZE) of IC.char;
pragma Pack (Fp_State_Frame_Array);
for Fp_State_Frame_Array'Size use 8 * FP_STATE_FRAME_SIZE;
type FP_CONTEXT is record
fpRegSet : FPREG_SET;
stateFrame : Fp_State_Frame_Array;
end record;
pragma Convention (C, FP_CONTEXT);
Num_HW_Interrupts : constant := 256;
-- Number of entries in the hardware interrupt vector table
-- VxWorks 5.3 and 5.4 version
type TASK_DESC is record
td_id : IC.int; -- task id
td_name : Address; -- name of task
td_priority : IC.int; -- task priority
td_status : IC.int; -- task status
td_options : IC.int; -- task option bits (see below)
td_entry : Address; -- original entry point of task
td_sp : Address; -- saved stack pointer
td_pStackBase : Address; -- the bottom of the stack
td_pStackLimit : Address; -- the effective end of the stack
td_pStackEnd : Address; -- the actual end of the stack
td_stackSize : IC.int; -- size of stack in bytes
td_stackCurrent : IC.int; -- current stack usage in bytes
td_stackHigh : IC.int; -- maximum stack usage in bytes
td_stackMargin : IC.int; -- current stack margin in bytes
td_errorStatus : IC.int; -- most recent task error status
td_delay : IC.int; -- delay/timeout ticks
end record;
pragma Convention (C, TASK_DESC);
end System.VxWorks;
gcc/ada/5lsystem.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M --
-- --
-- S p e c --
-- (Linux/x86 Version)
-- --
-- $Revision: 1.4 $
-- --
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 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 is
pragma Pure (System);
-- Note that we take advantage of the implementation permission to
-- make this unit Pure instead of Preelaborable, see RM 13.7(36)
type Name is (SYSTEM_NAME_GNAT);
System_Name : constant Name := SYSTEM_NAME_GNAT;
-- System-Dependent Named Numbers
Min_Int : constant := Long_Long_Integer'First;
Max_Int : constant := Long_Long_Integer'Last;
Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
Max_Nonbinary_Modulus : constant := Integer'Last;
Max_Base_Digits : constant := Long_Long_Float'Digits;
Max_Digits : constant := Long_Long_Float'Digits;
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
Tick : constant := Standard'Tick;
-- Storage-related Declarations
type Address is private;
Null_Address : constant Address;
Storage_Unit : constant := Standard'Storage_Unit;
Word_Size : constant := Standard'Word_Size;
Memory_Size : constant := 2 ** Standard'Address_Size;
-- Address comparison
function "<" (Left, Right : Address) return Boolean;
function "<=" (Left, Right : Address) return Boolean;
function ">" (Left, Right : Address) return Boolean;
function ">=" (Left, Right : Address) return Boolean;
function "=" (Left, Right : Address) return Boolean;
pragma Import (Intrinsic, "<");
pragma Import (Intrinsic, "<=");
pragma Import (Intrinsic, ">");
pragma Import (Intrinsic, ">=");
pragma Import (Intrinsic, "=");
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
Default_Bit_Order : constant Bit_Order :=
Bit_Order'Val (Standard'Default_Bit_Order);
-- Priority-related Declarations (RM D.1)
Max_Priority : constant Positive := 30;
Max_Interrupt_Priority : constant Positive := 31;
subtype Any_Priority is Integer
range 0 .. Standard'Max_Interrupt_Priority;
subtype Priority is Any_Priority
range 0 .. Standard'Max_Priority;
-- Functional notation is needed in the following to avoid visibility
-- problems when this package is compiled through rtsfind in the middle
-- of another compilation.
subtype Interrupt_Priority is Any_Priority
range
Standard."+" (Standard'Max_Priority, 1) ..
Standard'Max_Interrupt_Priority;
Default_Priority : constant Priority :=
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
private
type Address is mod Memory_Size;
Null_Address : constant Address := 0;
--------------------------------------
-- System Implementation Parameters --
--------------------------------------
-- These parameters provide information about the target that is used
-- by the compiler. They are in the private part of System, where they
-- can be accessed using the special circuitry in the Targparm unit
-- whose source should be consulted for more detailed descriptions
-- of the individual switch values.
AAMP : constant Boolean := False;
Command_Line_Args : constant Boolean := True;
Denorm : constant Boolean := True;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : constant Boolean := False;
Long_Shifts_Inlined : constant Boolean := True;
High_Integrity_Mode : constant Boolean := False;
Machine_Overflows : constant Boolean := False;
Machine_Rounds : constant Boolean := True;
OpenVMS : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False;
Front_End_ZCX_Support : constant Boolean := True;
end System;
gcc/ada/5mvxwork.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . V X W O R K S --
-- --
-- S p e c --
-- --
-- $Revision: 1.1 $
-- --
-- Copyright (C) 1998-2001 Free Software Foundation --
-- --
-- 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 is the MIPS VxWorks version of this package.
with Interfaces.C;
package System.VxWorks is
pragma Preelaborate (System.VxWorks);
package IC renames Interfaces.C;
-- Define enough of a Wind Task Control Block in order to
-- obtain the inherited priority. When porting this to
-- different versions of VxWorks (this is based on 5.3[.1]),
-- be sure to look at the definition for WIND_TCB located
-- in $WIND_BASE/target/h/taskLib.h
type Wind_Fill_1 is array (0 .. 16#3F#) of IC.unsigned_char;
type Wind_Fill_2 is array (16#48# .. 16#107#) of IC.unsigned_char;
type Wind_TCB is record
Fill_1 : Wind_Fill_1; -- 0x00 - 0x3f
Priority : IC.int; -- 0x40 - 0x43, current (inherited) priority
Normal_Priority : IC.int; -- 0x44 - 0x47, base priority
Fill_2 : Wind_Fill_2; -- 0x48 - 0x107
spare1 : Address; -- 0x108 - 0x10b
spare2 : Address; -- 0x10c - 0x10f
spare3 : Address; -- 0x110 - 0x113
spare4 : Address; -- 0x114 - 0x117
end record;
type Wind_TCB_Ptr is access Wind_TCB;
-- Floating point context record. MIPS version
FP_NUM_DREGS : constant := 16;
type Fpx_Array is array (1 .. FP_NUM_DREGS) of IC.double;
type FP_CONTEXT is record
fpx : Fpx_Array;
fpcsr : IC.int;
end record;
pragma Convention (C, FP_CONTEXT);
-- Number of entries in hardware interrupt vector table. Value of
-- 0 disables hardware interrupt handling until it can be tested
Num_HW_Interrupts : constant := 0;
-- VxWorks 5.3 and 5.4 version
type TASK_DESC is record
td_id : IC.int; -- task id
td_name : Address; -- name of task
td_priority : IC.int; -- task priority
td_status : IC.int; -- task status
td_options : IC.int; -- task option bits (see below)
td_entry : Address; -- original entry point of task
td_sp : Address; -- saved stack pointer
td_pStackBase : Address; -- the bottom of the stack
td_pStackLimit : Address; -- the effective end of the stack
td_pStackEnd : Address; -- the actual end of the stack
td_stackSize : IC.int; -- size of stack in bytes
td_stackCurrent : IC.int; -- current stack usage in bytes
td_stackHigh : IC.int; -- maximum stack usage in bytes
td_stackMargin : IC.int; -- current stack margin in bytes
td_errorStatus : IC.int; -- most recent task error status
td_delay : IC.int; -- delay/timeout ticks
end record;
pragma Convention (C, TASK_DESC);
end System.VxWorks;
gcc/ada/5ninmaop.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T . --
-- O P E R A T I O N S --
-- --
-- B o d y --
-- --
-- $Revision: 1.5 $ --
-- --
-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 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 is a NO tasking version of this package.
package body System.Interrupt_Management.Operations is
----------------------------
-- Thread_Block_Interrupt --
----------------------------
procedure Thread_Block_Interrupt
(Interrupt : Interrupt_ID)
is
begin
null;
end Thread_Block_Interrupt;
------------------------------
-- Thread_Unblock_Interrupt --
------------------------------
procedure Thread_Unblock_Interrupt
(Interrupt : Interrupt_ID)
is
begin
null;
end Thread_Unblock_Interrupt;
------------------------
-- Set_Interrupt_Mask --
------------------------
procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
begin
null;
end Set_Interrupt_Mask;
procedure Set_Interrupt_Mask
(Mask : access Interrupt_Mask;
OMask : access Interrupt_Mask) is
begin
null;
end Set_Interrupt_Mask;
------------------------
-- Get_Interrupt_Mask --
------------------------
procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
begin
null;
end Get_Interrupt_Mask;
--------------------
-- Interrupt_Wait --
--------------------
function Interrupt_Wait
(Mask : access Interrupt_Mask)
return Interrupt_ID
is
begin
return 0;
end Interrupt_Wait;
----------------------------
-- Install_Default_Action --
----------------------------
procedure Install_Default_Action (Interrupt : Interrupt_ID) is
begin
null;
end Install_Default_Action;
---------------------------
-- Install_Ignore_Action --
---------------------------
procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
begin
null;
end Install_Ignore_Action;
-------------------------
-- Fill_Interrupt_Mask --
-------------------------
procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
begin
null;
end Fill_Interrupt_Mask;
--------------------------
-- Empty_Interrupt_Mask --
--------------------------
procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
begin
null;
end Empty_Interrupt_Mask;
-----------------------
-- Add_To_Sigal_Mask --
-----------------------
procedure Add_To_Interrupt_Mask
(Mask : access Interrupt_Mask;
Interrupt : Interrupt_ID)
is
begin
null;
end Add_To_Interrupt_Mask;
--------------------------------
-- Delete_From_Interrupt_Mask --
--------------------------------
procedure Delete_From_Interrupt_Mask
(Mask : access Interrupt_Mask;
Interrupt : Interrupt_ID)
is
begin
null;
end Delete_From_Interrupt_Mask;
---------------
-- Is_Member --
---------------
function Is_Member
(Mask : access Interrupt_Mask;
Interrupt : Interrupt_ID) return Boolean
is
begin
return False;
end Is_Member;
-------------------------
-- Copy_Interrupt_Mask --
-------------------------
procedure Copy_Interrupt_Mask
(X : out Interrupt_Mask;
Y : Interrupt_Mask)
is
begin
X := Y;
end Copy_Interrupt_Mask;
-------------------------
-- Interrupt_Self_Process --
-------------------------
procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is
begin
null;
end Interrupt_Self_Process;
end System.Interrupt_Management.Operations;
gcc/ada/5nintman.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T --
-- --
-- B o d y --
-- --
-- $Revision: 1.4 $ --
-- --
-- Copyright (C) 1991-1996, 1998 Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 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). --
-- --
------------------------------------------------------------------------------
package body System.Interrupt_Management is
---------------------------
-- Initialize_Interrupts --
---------------------------
-- Nothing needs to be done on this platform.
procedure Initialize_Interrupts is
begin
null;
end Initialize_Interrupts;
end System.Interrupt_Management;
gcc/ada/Makefile.in 0 → 100644
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/make.adb 0 → 100644
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/misc.c 0 → 100644
This diff is collapsed. Click to expand it.
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