Skip to content

R
riscv-gcc-1
Commit 084c663c by Arnaud Charlet Committed by Arnaud Charlet
Options

Renaming of target specific files for clarity 

        * Makefile.in: Rename GNAT target specific files.

	* 31soccon.ads, 31soliop.ads 35soccon.ads, 3asoccon.ads,
	3bsoccon.ads, 3gsoccon.ads, 3hsoccon.ads, 3psoccon.ads,
	3ssoccon.ads, 3ssoliop.ads, 3veacodu.adb, 3vexpect.adb,
	3vsoccon.ads, 3vsocthi.adb, 3vsocthi.ads, 3vtrasym.adb,
	3wsoccon.ads, 3wsocthi.adb, 3wsocthi.ads, 3wsoliop.ads,
	3zsoccon.ads, 3zsocthi.adb, 3zsocthi.ads, 41intnam.ads,
	42intnam.ads, 45intnam.ads, 4aintnam.ads, 4cintnam.ads,
	4gintnam.ads, 4hexcpol.adb, 4hintnam.ads, 4lintnam.ads,
	4nintnam.ads, 4ointnam.ads, 4onumaux.ads, 4pintnam.ads,
	4sintnam.ads, 4vcaldel.adb, 4vcalend.adb, 4vcalend.ads,
	4vintnam.ads, 4wcalend.adb, 4wexcpol.adb, 4wintnam.ads,
	4zintnam.ads, 4znumaux.ads, 4zsytaco.adb, 4zsytaco.ads,
	51osinte.adb, 51osinte.ads, 51system.ads,
	52osinte.adb, 52osinte.ads, 53osinte.ads, 54osinte.ads,
	55osinte.adb, 55osinte.ads, 55system.ads, 56osinte.adb,
	56osinte.ads, 56system.ads, 56taprop.adb, 56taspri.ads,
	56tpopsp.adb, 57system.ads, 58system.ads,
	5amastop.adb, 5aml-tgt.adb, 5aosinte.adb, 5aosinte.ads,
	5asystem.ads, 5ataprop.adb, 5atasinf.ads, 5ataspri.ads,
	5atpopsp.adb, 5avxwork.ads, 5bml-tgt.adb, 5bosinte.adb,
	5bosinte.ads, 5bsystem.ads, 5cosinte.ads, 5csystem.ads,
	5dsystem.ads, 5esystem.ads, 5fintman.adb, 5fosinte.adb,
	5fosinte.ads, 5fsystem.ads, 5ftaprop.adb, 5ftasinf.ads,
	5ginterr.adb, 5gintman.adb, 5gmastop.adb, 5gml-tgt.adb,
	5gosinte.ads, 5gproinf.adb, 5gproinf.ads, 5gsystem.ads,
	5gtaprop.adb, 5gtasinf.adb, 5gtasinf.ads, 5gtpgetc.adb,
	5hml-tgt.adb, 5hosinte.adb, 5hosinte.ads, 5hparame.ads,
	5hsystem.ads, 5htaprop.adb, 5htaspri.ads, 5htraceb.adb,
	5iosinte.adb, 5iosinte.ads, 5itaprop.adb, 5itaspri.ads,
	5ksystem.ads, 5kvxwork.ads, 5lml-tgt.adb, 5losinte.ads,
	5lparame.adb, 5lsystem.ads, 5msystem.ads, 5mvxwork.ads,
	5ninmaop.adb, 5nintman.adb, 5nosinte.ads, 5nsystem.ads,
	5ntaprop.adb, 5ntaspri.ads, 5ointerr.adb, 5omastop.adb,
	5oosinte.adb, 5oosinte.ads, 5oosprim.adb, 5oparame.adb,
	5osystem.ads, 5otaprop.adb, 5otaspri.ads, 5posinte.ads,
	5posprim.adb, 5psystem.ads, 5pvxwork.ads, 5sintman.adb,
	5sml-tgt.adb, 5sosinte.adb, 5sosinte.ads, 5sosprim.adb,
	5sparame.adb, 5ssystem.ads, 5staprop.adb, 5stasinf.adb,
	5stasinf.ads, 5staspri.ads, 5stpopsp.adb, 5svxwork.ads,
	5tosinte.ads, 5usystem.ads, 5vasthan.adb, 5vdirval.adb,
	5vinmaop.adb, 5vinterr.adb, 5vintman.adb, 5vintman.ads,
	5vmastop.adb, 5vml-tgt.adb, 5vosinte.adb, 5vosinte.ads,
	5vosprim.adb, 5vosprim.ads, 5vparame.ads, 5vsymbol.adb,
	5vsystem.ads, 5vtaprop.adb, 5vtaspri.ads, 5vtpopde.adb,
	5vtpopde.ads, 5vtraent.adb, 5vtraent.ads, 5vvaflop.adb,
	5wdirval.adb, 5wgloloc.adb, 5wintman.adb, 5wmemory.adb,
	5wml-tgt.adb, 5wosinte.ads, 5wosprim.adb, 5wsystem.ads,
	5wtaprop.adb, 5wtaspri.ads, 5xparame.ads, 5xsystem.ads,
	5xvxwork.ads, 5yparame.ads, 5ysystem.ads, 5zinterr.adb,
	5zintman.adb, 5zintman.ads, 5zml-tgt.adb, 5zosinte.adb,
	5zosinte.ads, 5zosprim.adb, 5zparame.ads, 5zstchop.adb,
	5zsystem.ads, 5ztaprop.adb, 5ztaspri.ads, 5ztfsetr.adb,
	5ztpopsp.adb, 6vcpp.adb, 6vcstrea.adb, 6vinterf.ads,
	7sinmaop.adb, 7sintman.adb, 7sosinte.adb, 7sosprim.adb,
	7staprop.adb, 7staspri.ads, 7stfsetr.adb, 7stpopsp.adb,
	7straceb.adb, 7straces.adb, 7strafor.adb, 7strafor.ads,
	7stratas.adb, 86numaux.adb, 86numaux.ads: Replaced by files below.

	* a-caldel-vms.adb, a-calend-mingw.adb, a-calend-vms.adb,
	a-calend-vms.ads, a-dirval-mingw.adb, a-dirval-vms.adb,
	a-excpol-abort.adb, a-excpol-interix.adb, a-intnam-aix.ads,
	a-intnam-dummy.ads, a-intnam-freebsd.ads, a-intnam-hpux.ads,
	a-intnam-interix.ads, a-intnam-irix.ads, a-intnam-linux.ads,
	a-intnam-lynxos.ads, a-intnam-mingw.ads, a-intnam-os2.ads,
	a-intnam-solaris.ads, a-intnam-tru64.ads, a-intnam-unixware.ads,
	a-intnam-vms.ads, a-intnam-vxworks.ads, a-numaux-libc-x86.ads,
	a-numaux-vxworks.ads, a-numaux-x86.adb, a-numaux-x86.ads,
	a-sytaco-vxworks.adb, a-sytaco-vxworks.ads, g-eacodu-vms.adb,
	g-expect-vms.adb, g-soccon-aix.ads, g-soccon-freebsd.ads,
	g-soccon-hpux.ads, g-soccon-interix.ads, g-soccon-irix.ads,
	g-soccon-mingw.ads, g-soccon-solaris.ads, g-soccon-tru64.ads,
	g-soccon-unixware.ads, g-soccon-vms.adb, g-soccon-vxworks.ads,
	g-socthi-mingw.adb, g-socthi-mingw.ads, g-socthi-vms.adb,
	g-socthi-vms.ads, g-socthi-vxworks.adb, g-socthi-vxworks.ads,
	g-soliop-mingw.ads, g-soliop-solaris.ads, g-soliop-unixware.ads,
	g-trasym-vms.adb, i-cpp-vms.adb, i-cstrea-vms.adb,
	interfac-vms.ads, mlib-tgt-aix.adb, mlib-tgt-hpux.adb,
	mlib-tgt-irix.adb, mlib-tgt-linux.adb, mlib-tgt-mingw.adb,
	mlib-tgt-solaris.adb, mlib-tgt-tru64.adb, mlib-tgt-vms.adb,
	mlib-tgt-vxworks.adb, s-asthan-vms.adb, s-gloloc-mingw.adb,
	s-inmaop-dummy.adb, s-inmaop-posix.adb, s-inmaop-vms.adb,
	s-interr-dummy.adb, s-interr-sigaction.adb, s-interr-vms.adb,
	s-interr-vxworks.adb, s-intman-dummy.adb, s-intman-irix.adb,
	s-intman-irix-athread.adb, s-intman-mingw.adb, s-intman-posix.adb,
	s-intman-solaris.adb, s-intman-vms.adb, s-intman-vms.ads,
	s-intman-vxworks.adb, s-intman-vxworks.ads, s-mastop-irix.adb,
	s-mastop-tru64.adb, s-mastop-vms.adb, s-mastop-x86.adb,
	s-memory-mingw.adb, s-osinte-aix.adb, s-osinte-aix.ads,
	s-osinte-aix-fsu.ads, s-osinte-dummy.ads, s-osinte-freebsd.adb,
	s-osinte-freebsd.ads, s-osinte-fsu.adb, s-osinte-hpux.ads,
	s-osinte-hpux-dce.adb, s-osinte-hpux-dce.ads, s-osinte-interix.ads,
	s-osinte-irix.adb, s-osinte-irix.ads, s-osinte-irix-athread.ads,
	s-osinte-linux.ads, s-osinte-linux-fsu.ads, s-osinte-linux-ia64.ads,
	s-osinte-lynxos-3.adb, s-osinte-lynxos-3.ads, s-osinte-lynxos.adb,
	s-osinte-lynxos.ads, s-osinte-mingw.ads, s-osinte-os2.adb,
	s-osinte-os2.ads, s-osinte-posix.adb, s-osinte-solaris.adb,
	s-osinte-solaris.ads, s-osinte-solaris-fsu.ads,
	s-osinte-solaris-posix.ads, s-osinte-tru64.adb, s-osinte-tru64.ads,
	s-osinte-unixware.adb, s-osinte-unixware.ads, s-osinte-vms.adb,
	s-osinte-vms.ads, s-osinte-vxworks.adb,
	s-osinte-vxworks.ads, s-osprim-mingw.adb,
	s-osprim-os2.adb, s-osprim-posix.adb, s-osprim-solaris.adb,
	s-osprim-unix.adb, s-osprim-vms.adb, s-osprim-vms.ads,
	s-osprim-vxworks.adb, s-parame-ae653.ads, s-parame-hpux.ads,
	s-parame-linux.adb, s-parame-os2.adb, s-parame-solaris.adb,
	s-parame-vms.ads, s-parame-vms-restrict.ads, s-parame-vxworks.ads,
	s-proinf-irix-athread.adb, s-proinf-irix-athread.ads,
	s-stchop-vxworks.adb, s-taprop-dummy.adb,
	s-taprop-hpux-dce.adb, s-taprop-irix.adb,
	s-taprop-irix-athread.adb, s-taprop-linux.adb, s-taprop-lynxos.adb,
	s-taprop-mingw.adb, s-taprop-os2.adb, s-taprop-posix.adb,
	s-taprop-solaris.adb, s-taprop-tru64.adb, s-taprop-vms.adb,
	s-taprop-vxworks.adb, s-tasinf-irix.ads, s-tasinf-irix-athread.adb,
	s-tasinf-irix-athread.ads, s-tasinf-solaris.adb, s-tasinf-solaris.ads,
	s-tasinf-tru64.ads, s-taspri-dummy.ads, s-taspri-hpux-dce.ads,
	s-taspri-linux.ads, s-taspri-lynxos.ads, s-taspri-mingw.ads,
	s-taspri-os2.ads, s-taspri-posix.ads, s-taspri-solaris.ads,
	s-taspri-tru64.ads, s-taspri-vms.ads, s-taspri-vxworks.ads,
	s-tfsetr-default.adb, s-tfsetr-vxworks.adb, s-tpopde-vms.adb,
	s-tpopde-vms.ads, s-tpopsp-lynxos.adb, s-tpopsp-posix.adb,
	s-tpopsp-posix-foreign.adb, s-tpopsp-solaris.adb, s-tpopsp-vxworks.adb,
	s-traceb-hpux.adb, s-traceb-mastop.adb, s-traces-default.adb,
	s-traent-vms.adb, s-traent-vms.ads, s-trafor-default.adb,
	s-trafor-default.ads, s-tratas-default.adb, s-vaflop-vms.adb,
	s-vxwork-alpha.ads, s-vxwork-m68k.ads, s-vxwork-mips.ads,
	s-vxwork-ppc.ads, s-vxwork-sparcv9.ads, s-vxwork-xscale.ads,
	symbols-vms.adb, system-aix.ads, system-freebsd-x86.ads,
	system-hpux.ads, system-interix.ads, system-irix-n32.ads,
	system-irix-o32.ads, system-linux-x86_64.ads,
	system-linux-x86.ads, system-lynxos-ppc.ads, system-lynxos-x86.ads,
	system-mingw.ads, system-os2.ads, system-solaris-sparc.ads,
	system-solaris-sparcv9.ads, system-solaris-x86.ads, system-tru64.ads,
	system-unixware.ads, system-vms.ads, system-vms-zcx.ads,
	system-vxworks-alpha.ads, system-vxworks-m68k.ads,
	system-vxworks-mips.ads, system-vxworks-ppc.ads,
	system-vxworks-sparcv9.ads, system-vxworks-xscale.ads: Replace files
	above.

From-SVN: r81834
parent 02ea8d06
Showing with 5208 additions and 5271 deletions
gcc/ada/5gtpgetc.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- 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 --
-- --
-- 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. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- 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/5zstchop.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2004 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. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is the VxWorks version of this package.
-- This file should be kept synchronized with the general implementation
-- provided by s-stchop.adb.
pragma Restrictions (No_Elaboration_Code);
-- We want to guarantee the absence of elaboration code because the
-- binder does not handle references to this package.
with Ada.Exceptions;
with System.Storage_Elements; use System.Storage_Elements;
with System.Parameters; use System.Parameters;
with System.Soft_Links;
with Interfaces.C;
with System.OS_Interface;
package body System.Stack_Checking.Operations is
-- In order to have stack checking working appropriately on
-- VxWorks we need to extract the stack size information from the
-- VxWorks kernel itself. It means that the library for showing
-- task-related information needs to be linked into the VxWorks
-- system, when using stack checking. The TaskShow library can be
-- linked into the VxWorks system by either:
-- * defining INCLUDE_SHOW_ROUTINES in config.h when using
-- configuration header files, or
-- * selecting INCLUDE_TASK_SHOW when using the Tornado project
-- facility.
function Set_Stack_Info (Stack : access Stack_Access) return Stack_Access;
-- The function Set_Stack_Info is the actual function that updates
-- the cache containing a pointer to the Stack_Info. It may also
-- be used for detecting asynchronous abort in combination with
-- Invalidate_Self_Cache.
-- Set_Stack_Info should do the following things in order:
-- 1) Get the Stack_Access value for the current task
-- 2) Set Stack.all to the value obtained in 1)
-- 3) Optionally Poll to check for asynchronous abort
-- This order is important because if at any time a write to
-- the stack cache is pending, that write should be followed
-- by a Poll to prevent loosing signals.
-- Note: This function must be compiled with Polling turned off
-- Note: on systems like VxWorks and OS/2 with real thread-local storage,
-- Set_Stack_Info should return an access value for such local
-- storage. In those cases the cache will always be up-to-date.
-- The following constants should be imported from some system-specific
-- constants package. The constants must be static for performance reasons.
----------------------------
-- Invalidate_Stack_Cache --
----------------------------
procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is
pragma Warnings (Off, Any_Stack);
begin
Cache := Null_Stack;
end Invalidate_Stack_Cache;
--------------------
-- Set_Stack_Info --
--------------------
function Set_Stack_Info
(Stack : access Stack_Access) return Stack_Access
is
-- Task descriptor that is handled internally by the VxWorks kernel
type Task_Descriptor is record
T_Id : Interfaces.C.int; -- task identifier
Td_Name : System.Address; -- task name
Td_Priority : Interfaces.C.int; -- task priority
Td_Status : Interfaces.C.int; -- task status
Td_Options : Interfaces.C.int; -- task option bits (see below)
Td_Entry : System.Address; -- original entry point of task
Td_Sp : System.Address; -- saved stack pointer
Td_PStackBase : System.Address; -- the bottom of the stack
Td_PStackLimit : System.Address; -- the effective end of the stack
Td_PStackEnd : System.Address; -- the actual end of the stack
Td_StackSize : Interfaces.C.int; -- size of stack in bytes
Td_StackCurrent : Interfaces.C.int; -- current stack usage in bytes
Td_StackHigh : Interfaces.C.int; -- maximum stack usage in bytes
Td_StackMargin : Interfaces.C.int; -- current stack margin in bytes
Td_ErrorStatus : Interfaces.C.int; -- most recent task error status
Td_Delay : Interfaces.C.int; -- delay/timeout ticks
end record;
-- This VxWorks procedure fills in a specified task descriptor
-- for a specified task.
procedure TaskInfoGet (T_Id : System.OS_Interface.t_id;
Task_Desc : access Task_Descriptor);
pragma Import (C, TaskInfoGet, "taskInfoGet");
My_Stack : Stack_Access;
Task_Desc : aliased Task_Descriptor;
begin
-- The order of steps 1 .. 3 is important, see specification.
-- 1) Get the Stack_Access value for the current task
My_Stack := Soft_Links.Get_Stack_Info.all;
if My_Stack.Base = Null_Address then
-- First invocation. Ask the VxWorks kernel about stack
-- values.
TaskInfoGet (System.OS_Interface.taskIdSelf, Task_Desc'Access);
My_Stack.Size := System.Storage_Elements.Storage_Offset
(Task_Desc.Td_StackSize);
My_Stack.Base := Task_Desc.Td_PStackBase;
My_Stack.Limit := Task_Desc.Td_PStackLimit;
end if;
-- 2) Set Stack.all to the value obtained in 1)
Stack.all := My_Stack;
-- 3) Optionally Poll to check for asynchronous abort
if Soft_Links.Check_Abort_Status.all /= 0 then
raise Standard'Abort_Signal;
end if;
return My_Stack; -- Never trust the cached value, but return local copy!
end Set_Stack_Info;
--------------------
-- Set_Stack_Size --
--------------------
-- Specify the stack size for the current frame.
procedure Set_Stack_Size
(Stack_Size : System.Storage_Elements.Storage_Offset)
is
My_Stack : Stack_Access;
Frame_Address : constant System.Address := My_Stack'Address;
begin
My_Stack := Stack_Check (Frame_Address);
if Stack_Grows_Down then
My_Stack.Limit := My_Stack.Base - Stack_Size;
else
My_Stack.Limit := My_Stack.Base + Stack_Size;
end if;
end Set_Stack_Size;
-----------------
-- Stack_Check --
-----------------
function Stack_Check
(Stack_Address : System.Address) return Stack_Access
is
type Frame_Marker is null record;
Marker : Frame_Marker;
Cached_Stack : constant Stack_Access := Cache;
Frame_Address : constant System.Address := Marker'Address;
begin
-- This function first does a "cheap" check which is correct
-- if it succeeds. In case of failure, the full check is done.
-- Ideally the cheap check should be done in an optimized manner,
-- or be inlined.
if (Stack_Grows_Down and then
(Frame_Address <= Cached_Stack.Base
and
Stack_Address > Cached_Stack.Limit))
or else
(not Stack_Grows_Down and then
(Frame_Address >= Cached_Stack.Base
and
Stack_Address < Cached_Stack.Limit))
then
-- Cached_Stack is valid as it passed the stack check
return Cached_Stack;
end if;
Full_Check :
declare
My_Stack : constant Stack_Access := Set_Stack_Info (Cache'Access);
-- At this point Stack.all might already be invalid, so
-- it is essential to use our local copy of Stack!
begin
if (Stack_Grows_Down and then
Stack_Address < My_Stack.Limit)
or else
(not Stack_Grows_Down and then
Stack_Address > My_Stack.Limit)
then
Ada.Exceptions.Raise_Exception
(E => Storage_Error'Identity,
Message => "stack overflow detected");
end if;
return My_Stack;
end Full_Check;
end Stack_Check;
------------------------
-- Update_Stack_Cache --
------------------------
procedure Update_Stack_Cache (Stack : Stack_Access) is
begin
if not Multi_Processor then
Cache := Stack;
end if;
end Update_Stack_Cache;
end System.Stack_Checking.Operations;
gcc/ada/5zsystem.ads deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M --
-- --
-- S p e c --
-- (VxWorks Version Alpha) --
-- --
-- Copyright (C) 1992-2003 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. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
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 := 1.0 / 60.0;
-- Storage-related Declarations
type Address is private;
Null_Address : constant Address;
Storage_Unit : constant := 8;
Word_Size : constant := 64;
Memory_Size : constant := 2 ** 64;
-- Address comparison
function "<" (Left, Right : Address) return Boolean;
function "<=" (Left, Right : Address) return Boolean;
function ">" (Left, Right : Address) return Boolean;
function ">=" (Left, Right : Address) return Boolean;
function "=" (Left, Right : Address) return Boolean;
pragma Import (Intrinsic, "<");
pragma Import (Intrinsic, "<=");
pragma Import (Intrinsic, ">");
pragma Import (Intrinsic, ">=");
pragma Import (Intrinsic, "=");
-- 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)
-- 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 .. 255;
subtype Priority is Any_Priority range 0 .. 245;
subtype Interrupt_Priority is Any_Priority range 246 .. 255;
Default_Priority : constant Priority := 122;
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;
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := False;
Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := False;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : 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;
Support_64_Bit_Divides : constant Boolean := True;
Support_Aggregates : constant Boolean := True;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
Suppress_Standard_Library : 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;
-- Obsolete entries, to be removed eventually (bootstrap issues!)
High_Integrity_Mode : constant Boolean := False;
Long_Shifts_Inlined : constant Boolean := False;
end System;
gcc/ada/5ztaspri.ads deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- 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 --
-- --
-- Copyright (C) 2001-2002 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. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a VxWorks 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 System.OS_Interface;
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 Priority_Type is (Prio_None, Prio_Protect, Prio_Inherit);
type Lock is record
Mutex : System.OS_Interface.SEM_ID;
Protocol : Priority_Type;
Prio_Ceiling : System.OS_Interface.int;
-- priority ceiling of lock
end record;
type RTS_Lock is new Lock;
type Private_Data is record
Thread : aliased System.OS_Interface.t_id := 0;
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.
LWP : aliased System.Address;
-- The purpose of this field is to provide a better tasking support on
-- gdb. The order of the two first fields (Thread and LWP) is important.
-- On targets where lwp is not relevant, this is equivalent to Thread.
CV : aliased System.OS_Interface.SEM_ID;
L : aliased RTS_Lock;
-- Protection for all components is lock L
end record;
end System.Task_Primitives;
gcc/ada/5ztfsetr.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T R A C E S . S E N D --
-- --
-- B o d y --
-- --
-- Copyright (C) 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. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This version is for VxWorks targets.
-- Trace information is sent to WindView using the wvEvent function.
-- Note that wvEvent is from the VxWorks API.
-- When adding a new event, just give an Id to then event, and then modify
-- the WindView events database.
-- Refer to WindView User's Guide for more details on how to add new events
-- to the events database.
----------------
-- Send_Trace --
----------------
-- This procedure formats the string, maps the event Id to an Id
-- recognized by WindView, and send the event using wvEvent
separate (System.Traces.Format)
procedure Send_Trace (Id : Trace_T; Info : String) is
procedure Wv_Event
(Id : Integer;
Buffer : System.Address;
Size : Integer);
pragma Import (C, Wv_Event, "wvEvent");
Info_Trace : String_Trace;
Id_Event : Integer;
begin
Info_Trace := Format_Trace (Info);
case Id is
when M_Accept_Complete => Id_Event := 30000;
when M_Select_Else => Id_Event := 30001;
when M_RDV_Complete => Id_Event := 30002;
when M_Call_Complete => Id_Event := 30003;
when M_Delay => Id_Event := 30004;
when E_Kill => Id_Event := 30005;
when E_Missed => Id_Event := 30006;
when E_Timeout => Id_Event := 30007;
when W_Call => Id_Event := 30010;
when W_Accept => Id_Event := 30011;
when W_Select => Id_Event := 30012;
when W_Completion => Id_Event := 30013;
when W_Delay => Id_Event := 30014;
when WT_Select => Id_Event := 30015;
when WT_Call => Id_Event := 30016;
when WT_Completion => Id_Event := 30017;
when WU_Delay => Id_Event := 30018;
when PO_Call => Id_Event := 30020;
when POT_Call => Id_Event := 30021;
when PO_Run => Id_Event := 30022;
when PO_Lock => Id_Event := 30023;
when PO_Unlock => Id_Event := 30024;
when PO_Done => Id_Event := 30025;
when T_Create => Id_Event := 30030;
when T_Activate => Id_Event := 30031;
when T_Abort => Id_Event := 30032;
when T_Terminate => Id_Event := 30033;
-- Unrecognized events are given the special Id_Event value 29999
when others => Id_Event := 29999;
end case;
Wv_Event (Id_Event, Info_Trace'Address, Max_Size);
end Send_Trace;
gcc/ada/6vcpp.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- I N T E R F A C E S . C P P --
-- --
-- B o d y --
-- --
-- Copyright (C) 2000-2004, 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. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the OpenVMS/Alpha DEC C++ (cxx) version of this package
with Ada.Tags; use Ada.Tags;
with System; use System;
with System.Storage_Elements; use System.Storage_Elements;
with Unchecked_Conversion;
package body Interfaces.CPP is
subtype Cstring is String (Positive);
type Cstring_Ptr is access all Cstring;
type Tag_Table is array (Natural range <>) of Vtable_Ptr;
pragma Suppress_Initialization (Tag_Table);
type Type_Specific_Data is record
Idepth : Natural;
Expanded_Name : Cstring_Ptr;
External_Tag : Cstring_Ptr;
HT_Link : Tag;
Ancestor_Tags : Tag_Table (Natural);
end record;
type Vtable_Entry is record
Pfn : System.Address;
end record;
type Type_Specific_Data_Ptr is access all Type_Specific_Data;
type Vtable_Entry_Array is array (Positive range <>) of Vtable_Entry;
type VTable is record
Prims_Ptr : Vtable_Entry_Array (Positive);
TSD : Type_Specific_Data_Ptr;
-- Location of TSD is unknown so it got moved here to be out of the
-- way of Prims_Ptr. Find it later. ???
end record;
--------------------------------------------------------
-- Unchecked Conversions for Tag, Vtable_Ptr, and TSD --
--------------------------------------------------------
function To_Type_Specific_Data_Ptr is
new Unchecked_Conversion (Address, Type_Specific_Data_Ptr);
function To_Address is
new Unchecked_Conversion (Type_Specific_Data_Ptr, Address);
---------------------------------------------
-- Unchecked Conversions for String Fields --
---------------------------------------------
function To_Cstring_Ptr is
new Unchecked_Conversion (Address, Cstring_Ptr);
function To_Address is
new Unchecked_Conversion (Cstring_Ptr, Address);
-----------------------
-- Local Subprograms --
-----------------------
function Length (Str : Cstring_Ptr) return Natural;
-- Length of string represented by the given pointer (treating the
-- string as a C-style string, which is Nul terminated).
--------------------
-- Displaced_This --
--------------------
function Displaced_This
(Current_This : System.Address;
Vptr : Vtable_Ptr;
Position : Positive) return System.Address
is
pragma Warnings (Off, Vptr);
pragma Warnings (Off, Position);
begin
return Current_This;
-- + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1);
-- why is above line commented out ???
end Displaced_This;
-----------------------
-- CPP_CW_Membership --
-----------------------
function CPP_CW_Membership
(Obj_Tag : Vtable_Ptr;
Typ_Tag : Vtable_Ptr) return Boolean
is
Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;
begin
return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag;
end CPP_CW_Membership;
---------------------------
-- CPP_Get_Expanded_Name --
---------------------------
function CPP_Get_Expanded_Name (T : Vtable_Ptr) return Address is
begin
return To_Address (T.TSD.Expanded_Name);
end CPP_Get_Expanded_Name;
--------------------------
-- CPP_Get_External_Tag --
--------------------------
function CPP_Get_External_Tag (T : Vtable_Ptr) return Address is
begin
return To_Address (T.TSD.External_Tag);
end CPP_Get_External_Tag;
-------------------------------
-- CPP_Get_Inheritance_Depth --
-------------------------------
function CPP_Get_Inheritance_Depth (T : Vtable_Ptr) return Natural is
begin
return T.TSD.Idepth;
end CPP_Get_Inheritance_Depth;
-----------------------
-- CPP_Get_RC_Offset --
-----------------------
function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is
pragma Warnings (Off, T);
begin
return 0;
end CPP_Get_RC_Offset;
-----------------------------
-- CPP_Get_Prim_Op_Address --
-----------------------------
function CPP_Get_Prim_Op_Address
(T : Vtable_Ptr;
Position : Positive) return Address
is
begin
return T.Prims_Ptr (Position).Pfn;
end CPP_Get_Prim_Op_Address;
-------------------------------
-- CPP_Get_Remotely_Callable --
-------------------------------
function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean is
pragma Warnings (Off, T);
begin
return True;
end CPP_Get_Remotely_Callable;
-----------------
-- CPP_Get_TSD --
-----------------
function CPP_Get_TSD (T : Vtable_Ptr) return Address is
begin
return To_Address (T.TSD);
end CPP_Get_TSD;
--------------------
-- CPP_Inherit_DT --
--------------------
procedure CPP_Inherit_DT
(Old_T : Vtable_Ptr;
New_T : Vtable_Ptr;
Entry_Count : Natural)
is
begin
if Old_T /= null then
New_T.Prims_Ptr (1 .. Entry_Count) :=
Old_T.Prims_Ptr (1 .. Entry_Count);
end if;
end CPP_Inherit_DT;
---------------------
-- CPP_Inherit_TSD --
---------------------
procedure CPP_Inherit_TSD
(Old_TSD : Address;
New_Tag : Vtable_Ptr)
is
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (Old_TSD);
New_TSD : Type_Specific_Data renames New_Tag.TSD.all;
begin
if TSD /= null then
New_TSD.Idepth := TSD.Idepth + 1;
New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth)
:= TSD.Ancestor_Tags (0 .. TSD.Idepth);
else
New_TSD.Idepth := 0;
end if;
New_TSD.Ancestor_Tags (0) := New_Tag;
end CPP_Inherit_TSD;
---------------------------
-- CPP_Set_Expanded_Name --
---------------------------
procedure CPP_Set_Expanded_Name (T : Vtable_Ptr; Value : Address) is
begin
T.TSD.Expanded_Name := To_Cstring_Ptr (Value);
end CPP_Set_Expanded_Name;
--------------------------
-- CPP_Set_External_Tag --
--------------------------
procedure CPP_Set_External_Tag (T : Vtable_Ptr; Value : Address) is
begin
T.TSD.External_Tag := To_Cstring_Ptr (Value);
end CPP_Set_External_Tag;
-------------------------------
-- CPP_Set_Inheritance_Depth --
-------------------------------
procedure CPP_Set_Inheritance_Depth
(T : Vtable_Ptr;
Value : Natural)
is
begin
T.TSD.Idepth := Value;
end CPP_Set_Inheritance_Depth;
-----------------------------
-- CPP_Set_Prim_Op_Address --
-----------------------------
procedure CPP_Set_Prim_Op_Address
(T : Vtable_Ptr;
Position : Positive;
Value : Address)
is
begin
T.Prims_Ptr (Position).Pfn := Value;
end CPP_Set_Prim_Op_Address;
-----------------------
-- CPP_Set_RC_Offset --
-----------------------
procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is
pragma Warnings (Off, T);
pragma Warnings (Off, Value);
begin
null;
end CPP_Set_RC_Offset;
-------------------------------
-- CPP_Set_Remotely_Callable --
-------------------------------
procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean) is
pragma Warnings (Off, T);
pragma Warnings (Off, Value);
begin
null;
end CPP_Set_Remotely_Callable;
-----------------
-- CPP_Set_TSD --
-----------------
procedure CPP_Set_TSD (T : Vtable_Ptr; Value : Address) is
begin
T.TSD := To_Type_Specific_Data_Ptr (Value);
end CPP_Set_TSD;
-------------------
-- Expanded_Name --
-------------------
function Expanded_Name (T : Vtable_Ptr) return String is
Result : constant Cstring_Ptr := T.TSD.Expanded_Name;
begin
return Result (1 .. Length (Result));
end Expanded_Name;
------------------
-- External_Tag --
------------------
function External_Tag (T : Vtable_Ptr) return String is
Result : constant Cstring_Ptr := T.TSD.External_Tag;
begin
return Result (1 .. Length (Result));
end External_Tag;
------------
-- Length --
------------
function Length (Str : Cstring_Ptr) return Natural is
Len : Integer := 1;
begin
while Str (Len) /= ASCII.Nul loop
Len := Len + 1;
end loop;
return Len - 1;
end Length;
end Interfaces.CPP;
gcc/ada/6vcstrea.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- I N T E R F A C E S . C _ S T R E A M S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2004 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. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the Alpha/VMS version.
with Unchecked_Conversion;
package body Interfaces.C_Streams is
use type System.CRTL.size_t;
-- As the functions fread, fwrite and setvbuf are too big to be inlined,
-- they are just wrappers to the following implementation functions.
function fread_impl
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t;
function fread_impl
(buffer : voids;
index : size_t;
size : size_t;
count : size_t;
stream : FILEs) return size_t;
function fwrite_impl
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t;
function setvbuf_impl
(stream : FILEs;
buffer : chars;
mode : int;
size : size_t) return int;
------------
-- fread --
------------
function fread_impl
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
Get_Count : size_t := 0;
type Buffer_Type is array (size_t range 1 .. count,
size_t range 1 .. size) of Character;
type Buffer_Access is access Buffer_Type;
function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
BA : constant Buffer_Access := To_BA (buffer);
Ch : int;
begin
-- This Fread goes with the Fwrite below.
-- The C library fread sometimes can't read fputc generated files.
for C in 1 .. count loop
for S in 1 .. size loop
Ch := fgetc (stream);
if Ch = EOF then
return Get_Count;
end if;
BA.all (C, S) := Character'Val (Ch);
end loop;
Get_Count := Get_Count + 1;
end loop;
return Get_Count;
end fread_impl;
function fread_impl
(buffer : voids;
index : size_t;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
Get_Count : size_t := 0;
type Buffer_Type is array (size_t range 1 .. count,
size_t range 1 .. size) of Character;
type Buffer_Access is access Buffer_Type;
function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
BA : constant Buffer_Access := To_BA (buffer);
Ch : int;
begin
-- This Fread goes with the Fwrite below.
-- The C library fread sometimes can't read fputc generated files.
for C in 1 + index .. count + index loop
for S in 1 .. size loop
Ch := fgetc (stream);
if Ch = EOF then
return Get_Count;
end if;
BA.all (C, S) := Character'Val (Ch);
end loop;
Get_Count := Get_Count + 1;
end loop;
return Get_Count;
end fread_impl;
function fread
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
begin
return fread_impl (buffer, size, count, stream);
end fread;
function fread
(buffer : voids;
index : size_t;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
begin
return fread_impl (buffer, index, size, count, stream);
end fread;
------------
-- fwrite --
------------
function fwrite_impl
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
Put_Count : size_t := 0;
type Buffer_Type is array (size_t range 1 .. count,
size_t range 1 .. size) of Character;
type Buffer_Access is access Buffer_Type;
function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
BA : constant Buffer_Access := To_BA (buffer);
begin
-- Fwrite on VMS has the undesirable effect of always generating at
-- least one record of output per call, regardless of buffering. To
-- get around this, we do multiple fputc calls instead.
for C in 1 .. count loop
for S in 1 .. size loop
if fputc (Character'Pos (BA.all (C, S)), stream) = EOF then
return Put_Count;
end if;
end loop;
Put_Count := Put_Count + 1;
end loop;
return Put_Count;
end fwrite_impl;
function fwrite
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
begin
return fwrite_impl (buffer, size, count, stream);
end fwrite;
-------------
-- setvbuf --
-------------
function setvbuf_impl
(stream : FILEs;
buffer : chars;
mode : int;
size : size_t) return int
is
use type System.Address;
begin
-- In order for the above fwrite hack to work, we must always buffer
-- stdout and stderr. Is_regular_file on VMS cannot detect when
-- these are redirected to a file, so checking for that condition
-- doesnt help.
if mode = IONBF
and then (stream = stdout or else stream = stderr)
then
return System.CRTL.setvbuf
(stream, buffer, IOLBF, System.CRTL.size_t (size));
else
return System.CRTL.setvbuf
(stream, buffer, mode, System.CRTL.size_t (size));
end if;
end setvbuf_impl;
function setvbuf
(stream : FILEs;
buffer : chars;
mode : int;
size : size_t) return int
is
begin
return setvbuf_impl (stream, buffer, mode, size);
end setvbuf;
end Interfaces.C_Streams;
gcc/ada/6vinterf.ads deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- I N T E R F A C E S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2003 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 implementation dependent sections of this file. --
-- --
-- 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. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the OpenVMS version of this package which adds Float_Representation
-- pragmas to the IEEE floating point types to ensure they remain IEEE in
-- the presence of a configuration pragma Float_Representation (Vax_Float).
-- It assumes integer sizes of 8, 16, 32 and 64 are available, and that IEEE
-- floating-point formats are available.
package Interfaces is
pragma Pure (Interfaces);
type Integer_8 is range -2 ** 7 .. 2 ** 7 - 1;
for Integer_8'Size use 8;
type Integer_16 is range -2 ** 15 .. 2 ** 15 - 1;
for Integer_16'Size use 16;
type Integer_32 is range -2 ** 31 .. 2 ** 31 - 1;
for Integer_32'Size use 32;
type Integer_64 is range -2 ** 63 .. 2 ** 63 - 1;
for Integer_64'Size use 64;
type Unsigned_8 is mod 2 ** 8;
for Unsigned_8'Size use 8;
type Unsigned_16 is mod 2 ** 16;
for Unsigned_16'Size use 16;
type Unsigned_32 is mod 2 ** 32;
for Unsigned_32'Size use 32;
type Unsigned_64 is mod 2 ** 64;
for Unsigned_64'Size use 64;
function Shift_Left
(Value : Unsigned_8;
Amount : Natural)
return Unsigned_8;
function Shift_Right
(Value : Unsigned_8;
Amount : Natural)
return Unsigned_8;
function Shift_Right_Arithmetic
(Value : Unsigned_8;
Amount : Natural)
return Unsigned_8;
function Rotate_Left
(Value : Unsigned_8;
Amount : Natural)
return Unsigned_8;
function Rotate_Right
(Value : Unsigned_8;
Amount : Natural)
return Unsigned_8;
function Shift_Left
(Value : Unsigned_16;
Amount : Natural)
return Unsigned_16;
function Shift_Right
(Value : Unsigned_16;
Amount : Natural)
return Unsigned_16;
function Shift_Right_Arithmetic
(Value : Unsigned_16;
Amount : Natural)
return Unsigned_16;
function Rotate_Left
(Value : Unsigned_16;
Amount : Natural)
return Unsigned_16;
function Rotate_Right
(Value : Unsigned_16;
Amount : Natural)
return Unsigned_16;
function Shift_Left
(Value : Unsigned_32;
Amount : Natural)
return Unsigned_32;
function Shift_Right
(Value : Unsigned_32;
Amount : Natural)
return Unsigned_32;
function Shift_Right_Arithmetic
(Value : Unsigned_32;
Amount : Natural)
return Unsigned_32;
function Rotate_Left
(Value : Unsigned_32;
Amount : Natural)
return Unsigned_32;
function Rotate_Right
(Value : Unsigned_32;
Amount : Natural)
return Unsigned_32;
function Shift_Left
(Value : Unsigned_64;
Amount : Natural)
return Unsigned_64;
function Shift_Right
(Value : Unsigned_64;
Amount : Natural)
return Unsigned_64;
function Shift_Right_Arithmetic
(Value : Unsigned_64;
Amount : Natural)
return Unsigned_64;
function Rotate_Left
(Value : Unsigned_64;
Amount : Natural)
return Unsigned_64;
function Rotate_Right
(Value : Unsigned_64;
Amount : Natural)
return Unsigned_64;
pragma Import (Intrinsic, Shift_Left);
pragma Import (Intrinsic, Shift_Right);
pragma Import (Intrinsic, Shift_Right_Arithmetic);
pragma Import (Intrinsic, Rotate_Left);
pragma Import (Intrinsic, Rotate_Right);
-- Floating point types. We use the digits value to define the IEEE
-- forms, otherwise a configuration pragma specifying VAX float can
-- default the digits to an illegal value for IEEE.
-- Note: it is harmless, and explicitly permitted, to include additional
-- types in interfaces, so it is not wrong to have IEEE_Extended_Float
-- defined even if the extended format is not available.
type IEEE_Float_32 is digits 6;
pragma Float_Representation (IEEE_Float, IEEE_Float_32);
type IEEE_Float_64 is digits 15;
pragma Float_Representation (IEEE_Float, IEEE_Float_64);
type IEEE_Extended_Float is digits 15;
pragma Float_Representation (IEEE_Float, IEEE_Extended_Float);
end Interfaces;
gcc/ada/7sinmaop.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
-- --
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- 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. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a POSIX-like version of this package.
-- Note: this file can only be used for POSIX compliant systems.
with Interfaces.C;
-- used for int
-- size_t
-- unsigned
with System.OS_Interface;
-- used for various type, constant, and operations
with System.Storage_Elements;
-- used for To_Address
-- Integer_Address
with Unchecked_Conversion;
package body System.Interrupt_Management.Operations is
use Interfaces.C;
use System.OS_Interface;
type Interrupt_Mask_Ptr is access all Interrupt_Mask;
function "+" is new
Unchecked_Conversion (Interrupt_Mask_Ptr, sigset_t_ptr);
---------------------
-- Local Variables --
---------------------
Initial_Action : array (Signal) of aliased struct_sigaction;
Default_Action : aliased struct_sigaction;
Ignore_Action : aliased struct_sigaction;
----------------------------
-- Thread_Block_Interrupt --
----------------------------
procedure Thread_Block_Interrupt
(Interrupt : Interrupt_ID)
is
Result : Interfaces.C.int;
Mask : aliased sigset_t;
begin
Result := sigemptyset (Mask'Access);
pragma Assert (Result = 0);
Result := sigaddset (Mask'Access, Signal (Interrupt));
pragma Assert (Result = 0);
Result := pthread_sigmask (SIG_BLOCK, Mask'Unchecked_Access, null);
pragma Assert (Result = 0);
end Thread_Block_Interrupt;
------------------------------
-- Thread_Unblock_Interrupt --
------------------------------
procedure Thread_Unblock_Interrupt
(Interrupt : Interrupt_ID)
is
Mask : aliased sigset_t;
Result : Interfaces.C.int;
begin
Result := sigemptyset (Mask'Access);
pragma Assert (Result = 0);
Result := sigaddset (Mask'Access, Signal (Interrupt));
pragma Assert (Result = 0);
Result := pthread_sigmask (SIG_UNBLOCK, Mask'Unchecked_Access, null);
pragma Assert (Result = 0);
end Thread_Unblock_Interrupt;
------------------------
-- Set_Interrupt_Mask --
------------------------
procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
Result : Interfaces.C.int;
begin
Result := pthread_sigmask
(SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), null);
pragma Assert (Result = 0);
end Set_Interrupt_Mask;
procedure Set_Interrupt_Mask
(Mask : access Interrupt_Mask;
OMask : access Interrupt_Mask)
is
Result : Interfaces.C.int;
begin
Result := pthread_sigmask
(SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), +Interrupt_Mask_Ptr (OMask));
pragma Assert (Result = 0);
end Set_Interrupt_Mask;
------------------------
-- Get_Interrupt_Mask --
------------------------
procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
Result : Interfaces.C.int;
begin
Result := pthread_sigmask
(SIG_SETMASK, null, +Interrupt_Mask_Ptr (Mask));
pragma Assert (Result = 0);
end Get_Interrupt_Mask;
--------------------
-- Interrupt_Wait --
--------------------
function Interrupt_Wait
(Mask : access Interrupt_Mask)
return Interrupt_ID
is
Result : Interfaces.C.int;
Sig : aliased Signal;
begin
Result := sigwait (Mask, Sig'Access);
if Result /= 0 then
return 0;
end if;
return Interrupt_ID (Sig);
end Interrupt_Wait;
----------------------------
-- Install_Default_Action --
----------------------------
procedure Install_Default_Action (Interrupt : Interrupt_ID) is
Result : Interfaces.C.int;
begin
Result := sigaction
(Signal (Interrupt),
Initial_Action (Signal (Interrupt))'Access, null);
pragma Assert (Result = 0);
end Install_Default_Action;
---------------------------
-- Install_Ignore_Action --
---------------------------
procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
Result : Interfaces.C.int;
begin
Result := sigaction (Signal (Interrupt), Ignore_Action'Access, null);
pragma Assert (Result = 0);
end Install_Ignore_Action;
-------------------------
-- Fill_Interrupt_Mask --
-------------------------
procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
Result : Interfaces.C.int;
begin
Result := sigfillset (Mask);
pragma Assert (Result = 0);
end Fill_Interrupt_Mask;
--------------------------
-- Empty_Interrupt_Mask --
--------------------------
procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
Result : Interfaces.C.int;
begin
Result := sigemptyset (Mask);
pragma Assert (Result = 0);
end Empty_Interrupt_Mask;
---------------------------
-- Add_To_Interrupt_Mask --
---------------------------
procedure Add_To_Interrupt_Mask
(Mask : access Interrupt_Mask;
Interrupt : Interrupt_ID)
is
Result : Interfaces.C.int;
begin
Result := sigaddset (Mask, Signal (Interrupt));
pragma Assert (Result = 0);
end Add_To_Interrupt_Mask;
--------------------------------
-- Delete_From_Interrupt_Mask --
--------------------------------
procedure Delete_From_Interrupt_Mask
(Mask : access Interrupt_Mask;
Interrupt : Interrupt_ID)
is
Result : Interfaces.C.int;
begin
Result := sigdelset (Mask, Signal (Interrupt));
pragma Assert (Result = 0);
end Delete_From_Interrupt_Mask;
---------------
-- Is_Member --
---------------
function Is_Member
(Mask : access Interrupt_Mask;
Interrupt : Interrupt_ID) return Boolean
is
Result : Interfaces.C.int;
begin
Result := sigismember (Mask, Signal (Interrupt));
pragma Assert (Result = 0 or else Result = 1);
return Result = 1;
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
Result : Interfaces.C.int;
begin
Result := kill (getpid, Signal (Interrupt));
pragma Assert (Result = 0);
end Interrupt_Self_Process;
begin
declare
mask : aliased sigset_t;
allmask : aliased sigset_t;
Result : Interfaces.C.int;
begin
for Sig in 1 .. Signal'Last loop
Result := sigaction
(Sig, null, Initial_Action (Sig)'Unchecked_Access);
-- ??? [assert 1]
-- we can't check Result here since sigaction will fail on
-- SIGKILL, SIGSTOP, and possibly other signals
-- pragma Assert (Result = 0);
end loop;
-- Setup the masks to be exported.
Result := sigemptyset (mask'Access);
pragma Assert (Result = 0);
Result := sigfillset (allmask'Access);
pragma Assert (Result = 0);
Default_Action.sa_flags := 0;
Default_Action.sa_mask := mask;
Default_Action.sa_handler :=
Storage_Elements.To_Address
(Storage_Elements.Integer_Address (SIG_DFL));
Ignore_Action.sa_flags := 0;
Ignore_Action.sa_mask := mask;
Ignore_Action.sa_handler :=
Storage_Elements.To_Address
(Storage_Elements.Integer_Address (SIG_IGN));
for J in Interrupt_ID loop
-- We need to check whether J is in Keep_Unmasked because
-- the index type of the Keep_Unmasked array is not always
-- Interrupt_ID; it may be a subtype of Interrupt_ID.
if J in Keep_Unmasked'Range and then Keep_Unmasked (J) then
Result := sigaddset (mask'Access, Signal (J));
pragma Assert (Result = 0);
Result := sigdelset (allmask'Access, Signal (J));
pragma Assert (Result = 0);
end if;
end loop;
-- The Keep_Unmasked signals should be unmasked for Environment task
Result := pthread_sigmask (SIG_UNBLOCK, mask'Unchecked_Access, null);
pragma Assert (Result = 0);
-- Get the signal mask of the Environment Task
Result := pthread_sigmask (SIG_SETMASK, null, mask'Unchecked_Access);
pragma Assert (Result = 0);
-- Setup the constants exported
Environment_Mask := Interrupt_Mask (mask);
All_Tasks_Mask := Interrupt_Mask (allmask);
end;
end System.Interrupt_Management.Operations;
gcc/ada/7sintman.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- 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 --
-- --
-- Copyright (C) 1992-2003, 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. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is the POSIX threads version of this package
-- PLEASE DO NOT add any dependences on other packages. ??? why not ???
-- This package is designed to work with or without tasking support.
-- See the other warnings in the package specification before making
-- any modifications to this file.
-- 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.
-- Since this is a multi target file, the signal <-> exception mapping
-- is simple minded. If you need a more precise and target specific
-- signal handling, create a new s-intman.adb that will fit your needs.
-- This file assumes that:
-- SIGFPE, SIGILL, SIGSEGV and SIGBUS exist. They are mapped as follows:
-- SIGPFE => Constraint_Error
-- SIGILL => Program_Error
-- SIGSEGV => Storage_Error
-- SIGBUS => Storage_Error
-- SIGINT exists and will be kept unmasked unless the pragma
-- Unreserve_All_Interrupts is specified anywhere in the application.
-- System.OS_Interface contains the following:
-- SIGADAABORT: the signal that will be used to abort tasks.
-- Unmasked: the OS specific set of signals that should be unmasked in
-- all the threads. SIGADAABORT is unmasked by
-- default
-- Reserved: the OS specific set of signals that are reserved.
with Interfaces.C;
-- used for int and other types
with System.OS_Interface;
-- used for various Constants, Signal and types
package body System.Interrupt_Management is
use Interfaces.C;
use System.OS_Interface;
type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
Exception_Interrupts : constant Interrupt_List :=
(SIGFPE, SIGILL, SIGSEGV, SIGBUS);
Unreserve_All_Interrupts : Interfaces.C.int;
pragma Import
(C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
-----------------------
-- Local Subprograms --
-----------------------
procedure Notify_Exception (signo : Signal);
-- 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.
----------------------
-- Notify_Exception --
----------------------
Signal_Mask : aliased sigset_t;
-- The set of signals handled by Notify_Exception
procedure Notify_Exception (signo : Signal) is
Result : Interfaces.C.int;
begin
-- With the __builtin_longjmp, the signal mask is not restored, so we
-- need to restore it explicitely.
Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null);
pragma Assert (Result = 0);
-- Check that treatment of exception propagation here
-- is consistent with treatment of the abort signal in
-- System.Task_Primitives.Operations.
case signo is
when SIGFPE =>
raise Constraint_Error;
when SIGILL =>
raise Program_Error;
when SIGSEGV =>
raise Storage_Error;
when SIGBUS =>
raise Storage_Error;
when others =>
null;
end case;
end Notify_Exception;
---------------------------
-- Initialize_Interrupts --
---------------------------
-- Nothing needs to be done on this platform.
procedure Initialize_Interrupts is
begin
null;
end Initialize_Interrupts;
-------------------------
-- Package Elaboration --
-------------------------
begin
declare
act : aliased struct_sigaction;
old_act : aliased struct_sigaction;
Result : System.OS_Interface.int;
function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
-- and the result is one of the following:
User : constant Character := 'u';
Runtime : constant Character := 'r';
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
-- 'u' Interrupt_State pragma set state to User
-- 'r' Interrupt_State pragma set state to Runtime
-- 's' Interrupt_State pragma set state to System (use "default"
-- system handler)
begin
-- Need to call pthread_init very early because it is doing signal
-- initializations.
pthread_init;
Abort_Task_Interrupt := SIGADAABORT;
act.sa_handler := Notify_Exception'Address;
act.sa_flags := SA_SIGINFO;
-- Setting SA_SIGINFO asks the kernel to pass more than just the signal
-- number argument to the handler when it is called. The set of extra
-- parameters typically includes a pointer to a structure describing
-- the interrupted context. Although the Notify_Exception handler does
-- not use this information, it is actually required for the GCC/ZCX
-- exception propagation scheme because on some targets (at least
-- alpha-tru64), the structure contents are not even filled when this
-- flag is not set.
-- On some targets, we set sa_flags to SA_NODEFER so that during the
-- handler execution we do not change the Signal_Mask to be masked for
-- the Signal.
-- This is a temporary fix to the problem that the Signal_Mask is
-- not restored after the exception (longjmp) from the handler.
-- The right fix should be made in sigsetjmp so that we save
-- the Signal_Set and restore it after a longjmp.
-- Since SA_NODEFER is obsolete, instead we reset explicitely
-- the mask in the exception handler.
Result := sigemptyset (Signal_Mask'Access);
pragma Assert (Result = 0);
-- Add signals that map to Ada exceptions to the mask.
for J in Exception_Interrupts'Range loop
if State (Exception_Interrupts (J)) /= Default then
Result :=
sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J)));
pragma Assert (Result = 0);
end if;
end loop;
act.sa_mask := Signal_Mask;
pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
pragma Assert (Reserve = (Interrupt_ID'Range => False));
-- Process state of exception signals
for J in Exception_Interrupts'Range loop
if State (Exception_Interrupts (J)) /= User then
Keep_Unmasked (Exception_Interrupts (J)) := True;
Reserve (Exception_Interrupts (J)) := True;
if State (Exception_Interrupts (J)) /= Default then
Result :=
sigaction
(Signal (Exception_Interrupts (J)), act'Unchecked_Access,
old_act'Unchecked_Access);
pragma Assert (Result = 0);
end if;
end if;
end loop;
if State (Abort_Task_Interrupt) /= User then
Keep_Unmasked (Abort_Task_Interrupt) := True;
Reserve (Abort_Task_Interrupt) := True;
end if;
-- Set SIGINT to unmasked state as long as it is not in "User"
-- state. Check for Unreserve_All_Interrupts last
if State (SIGINT) /= User then
Keep_Unmasked (SIGINT) := True;
Reserve (SIGINT) := True;
end if;
-- Check all signals for state that requires keeping them
-- unmasked and reserved
for J in Interrupt_ID'Range loop
if State (J) = Default or else State (J) = Runtime then
Keep_Unmasked (J) := True;
Reserve (J) := True;
end if;
end loop;
-- Add the set of signals that must always be unmasked for this target
for J in Unmasked'Range loop
Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
Reserve (Interrupt_ID (Unmasked (J))) := True;
end loop;
-- Add target-specific reserved signals
for J in Reserved'Range loop
Reserve (Interrupt_ID (Reserved (J))) := True;
end loop;
-- Process pragma Unreserve_All_Interrupts. This overrides any
-- settings due to pragma Interrupt_State:
if Unreserve_All_Interrupts /= 0 then
Keep_Unmasked (SIGINT) := False;
Reserve (SIGINT) := False;
end if;
-- We do not have Signal 0 in reality. We just use this value
-- to identify non-existent signals (see s-intnam.ads). Therefore,
-- Signal 0 should not be used in all signal related operations hence
-- mark it as reserved.
Reserve (0) := True;
end;
end System.Interrupt_Management;
gcc/ada/7sosinte.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- 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 --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- 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. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a FSU Threads 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;
-------------
-- sigwait --
-------------
-- FSU_THREADS has a nonstandard sigwait
function sigwait
(set : access sigset_t;
sig : access Signal) return int
is
Result : int;
function sigwait_base (set : access sigset_t) return int;
pragma Import (C, sigwait_base, "sigwait");
begin
Result := sigwait_base (set);
if Result = -1 then
sig.all := 0;
return errno;
end if;
sig.all := Signal (Result);
return 0;
end sigwait;
------------------------
-- pthread_mutex_lock --
------------------------
-- FSU_THREADS has nonstandard pthread_mutex_lock and unlock.
-- It sets errno but the standard Posix requires it to be returned.
function pthread_mutex_lock (mutex : access pthread_mutex_t) return int is
function pthread_mutex_lock_base
(mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_mutex_lock_base, "pthread_mutex_lock");
Result : int;
begin
Result := pthread_mutex_lock_base (mutex);
if Result /= 0 then
return errno;
end if;
return 0;
end pthread_mutex_lock;
--------------------------
-- pthread_mutex_unlock --
--------------------------
function pthread_mutex_unlock
(mutex : access pthread_mutex_t) return int
is
function pthread_mutex_unlock_base
(mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_mutex_unlock_base, "pthread_mutex_unlock");
Result : int;
begin
Result := pthread_mutex_unlock_base (mutex);
if Result /= 0 then
return errno;
end if;
return 0;
end pthread_mutex_unlock;
-----------------------
-- pthread_cond_wait --
-----------------------
-- FSU_THREADS has a nonstandard pthread_cond_wait.
-- The FSU_THREADS version returns EINTR when interrupted.
function pthread_cond_wait
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t) return int
is
function pthread_cond_wait_base
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_cond_wait_base, "pthread_cond_wait");
Result : int;
begin
Result := pthread_cond_wait_base (cond, mutex);
if Result = EINTR then
return 0;
else
return Result;
end if;
end pthread_cond_wait;
----------------------------
-- pthread_cond_timedwait --
----------------------------
-- FSU_THREADS has a nonstandard pthread_cond_timedwait. The
-- FSU_THREADS version returns -1 and set errno to EAGAIN for timeout.
function pthread_cond_timedwait
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t;
abstime : access timespec) return int
is
function pthread_cond_timedwait_base
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t;
abstime : access timespec) return int;
pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait");
Result : int;
begin
Result := pthread_cond_timedwait_base (cond, mutex, abstime);
if Result = -1 then
if errno = EAGAIN then
return ETIMEDOUT;
else
return EINVAL;
end if;
end if;
return 0;
end pthread_cond_timedwait;
---------------------------
-- pthread_setschedparam --
---------------------------
-- FSU_THREADS does not have pthread_setschedparam
-- This routine returns a non-negative value upon failure
-- but the error code can not be set conforming the POSIX standard.
function pthread_setschedparam
(thread : pthread_t;
policy : int;
param : access struct_sched_param) return int
is
function pthread_setschedattr
(thread : pthread_t;
attr : pthread_attr_t) return int;
pragma Import (C, pthread_setschedattr, "pthread_setschedattr");
attr : aliased pthread_attr_t;
Result : int;
begin
Result := pthread_attr_init (attr'Access);
if Result /= 0 then
return Result;
end if;
attr.sched := policy;
-- Short-cut around pthread_attr_setprio
attr.prio := param.sched_priority;
Result := pthread_setschedattr (thread, attr);
if Result /= 0 then
return Result;
end if;
Result := pthread_attr_destroy (attr'Access);
if Result /= 0 then
return Result;
else
return 0;
end if;
end pthread_setschedparam;
-------------------------
-- pthread_getspecific --
-------------------------
-- FSU_THREADS has a nonstandard pthread_getspecific
function pthread_getspecific (key : pthread_key_t) return System.Address is
function pthread_getspecific_base
(key : pthread_key_t;
value : access System.Address) return int;
pragma Import (C, pthread_getspecific_base, "pthread_getspecific");
Tmp : aliased System.Address;
Result : int;
begin
Result := pthread_getspecific_base (key, Tmp'Access);
if Result /= 0 then
return System.Null_Address;
end if;
return Tmp;
end pthread_getspecific;
---------------------------------
-- pthread_attr_setdetachstate --
---------------------------------
function pthread_attr_setdetachstate
(attr : access pthread_attr_t;
detachstate : int) return int
is
function pthread_attr_setdetachstate_base
(attr : access pthread_attr_t;
detachstate : access int) return int;
pragma Import
(C, pthread_attr_setdetachstate_base, "pthread_attr_setdetachstate");
Tmp : aliased int := detachstate;
begin
return pthread_attr_setdetachstate_base (attr, Tmp'Access);
end pthread_attr_setdetachstate;
-----------------
-- sched_yield --
-----------------
-- FSU_THREADS does not have sched_yield;
function sched_yield return int is
procedure sched_yield_base (arg : System.Address);
pragma Import (C, sched_yield_base, "pthread_yield");
begin
sched_yield_base (System.Null_Address);
return 0;
end sched_yield;
----------------
-- Stack_Base --
----------------
function Get_Stack_Base (thread : pthread_t) return Address is
begin
return thread.stack_base;
end Get_Stack_Base;
end System.OS_Interface;
gcc/ada/7sosprim.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . O S _ P R I M I T I V E S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2003 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. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This version is for POSIX-like operating systems
package body System.OS_Primitives is
-- ??? These definitions are duplicated from System.OS_Interface
-- because we don't want to depend on any package. Consider removing
-- these declarations in System.OS_Interface and move these ones in
-- the spec.
type struct_timezone is record
tz_minuteswest : Integer;
tz_dsttime : Integer;
end record;
pragma Convention (C, struct_timezone);
type struct_timezone_ptr is access all struct_timezone;
type time_t is new Long_Integer;
type struct_timeval is record
tv_sec : time_t;
tv_usec : Long_Integer;
end record;
pragma Convention (C, struct_timeval);
function gettimeofday
(tv : access struct_timeval;
tz : struct_timezone_ptr) return Integer;
pragma Import (C, gettimeofday, "gettimeofday");
type timespec is record
tv_sec : time_t;
tv_nsec : Long_Integer;
end record;
pragma Convention (C, timespec);
function nanosleep (rqtp, rmtp : access timespec) return Integer;
pragma Import (C, nanosleep, "nanosleep");
-----------
-- Clock --
-----------
function Clock return Duration is
TV : aliased struct_timeval;
Result : Integer;
pragma Unreferenced (Result);
begin
Result := gettimeofday (TV'Access, null);
return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
end Clock;
---------------------
-- Monotonic_Clock --
---------------------
function Monotonic_Clock return Duration renames Clock;
-----------------
-- To_Timespec --
-----------------
function To_Timespec (D : Duration) return 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_Integer (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
-----------------
-- Timed_Delay --
-----------------
procedure Timed_Delay
(Time : Duration;
Mode : Integer)
is
Request : aliased timespec;
Remaind : aliased timespec;
Rel_Time : Duration;
Abs_Time : Duration;
Check_Time : Duration := Clock;
Result : Integer;
pragma Unreferenced (Result);
begin
if Mode = Relative then
Rel_Time := Time;
Abs_Time := Time + Check_Time;
else
Rel_Time := Time - Check_Time;
Abs_Time := Time;
end if;
if Rel_Time > 0.0 then
loop
Request := To_Timespec (Rel_Time);
Result := nanosleep (Request'Access, Remaind'Access);
Check_Time := Clock;
exit when Abs_Time <= Check_Time;
Rel_Time := Abs_Time - Check_Time;
end loop;
end if;
end Timed_Delay;
end System.OS_Primitives;
gcc/ada/7staspri.ads deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- 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 --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- 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. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a POSIX-like version of this package.
-- Note: this file can only be used for POSIX compliant systems.
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 new System.OS_Interface.pthread_mutex_t;
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.
LWP : aliased System.Address;
-- The purpose of this field is to provide a better tasking support on
-- gdb. The order of the two first fields (Thread and LWP) is important.
-- On targets where lwp is not relevant, this is equivalent to Thread.
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/7stfsetr.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T R A C E S . S E N D --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2002 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. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This version is for all targets, provided that System.IO.Put_Line is
-- functional. It prints debug information to Standard Output
with System.IO; use System.IO;
with GNAT.Regpat; use GNAT.Regpat;
----------------
-- Send_Trace --
----------------
-- Prints debug information both in a human readable form
-- and in the form they are sent from upper layers.
separate (System.Traces.Format)
procedure Send_Trace (Id : Trace_T; Info : String) is
type Param_Type is
(Name_Param,
Caller_Param,
Entry_Param,
Timeout_Param,
Acceptor_Param,
Parent_Param,
Number_Param);
-- Type of parameter found in the message
Info_Trace : String_Trace := Format_Trace (Info);
function Get_Param
(Input : String_Trace;
Param : Param_Type;
How_Many : Integer)
return String;
-- Extract a parameter from the given input string
---------------
-- Get_Param --
---------------
function Get_Param
(Input : String_Trace;
Param : Param_Type;
How_Many : Integer)
return String
is
pragma Unreferenced (How_Many);
Matches : Match_Array (1 .. 2);
begin
-- We need comments here ???
case Param is
when Name_Param =>
Match ("/N:([\w]+)", Input, Matches);
when Caller_Param =>
Match ("/C:([\w]+)", Input, Matches);
when Entry_Param =>
Match ("/E:([\s]*) +([0-9 ,]+)", Input, Matches);
when Timeout_Param =>
Match ("/T:([\s]*) +([0-9]+.[0-9]+)", Input, Matches);
when Acceptor_Param =>
Match ("/A:([\w]+)", Input, Matches);
when Parent_Param =>
Match ("/P:([\w]+)", Input, Matches);
when Number_Param =>
Match ("/#:([\s]*) +([0-9]+)", Input, Matches);
end case;
if Matches (1).First < Input'First then
return "";
end if;
case Param is
when Timeout_Param | Entry_Param | Number_Param =>
return Input (Matches (2).First .. Matches (2).Last);
when others =>
return Input (Matches (1).First .. Matches (1).Last);
end case;
end Get_Param;
-- Start of processing for Send_Trace
begin
New_Line;
Put_Line ("- Trace Debug Info ----------------");
Put ("Caught event Id : ");
case Id is
when M_Accept_Complete => Put ("M_Accept_Complete");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " completes accept on entry "
& Get_Param (Info_Trace, Entry_Param, 1) & " with "
& Get_Param (Info_Trace, Caller_Param, 1));
when M_Select_Else => Put ("M_Select_Else");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " selects else statement");
when M_RDV_Complete => Put ("M_RDV_Complete");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " completes rendezvous with "
& Get_Param (Info_Trace, Caller_Param, 1));
when M_Call_Complete => Put ("M_Call_Complete");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " completes call");
when M_Delay => Put ("M_Delay");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " completes delay "
& Get_Param (Info_Trace, Timeout_Param, 1));
when E_Missed => Put ("E_Missed");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " got an invalid acceptor "
& Get_Param (Info_Trace, Acceptor_Param, 1));
when E_Timeout => Put ("E_Timeout");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " ends select due to timeout ");
when E_Kill => Put ("E_Kill");
New_Line;
Put_Line ("Asynchronous Transfer of Control on task "
& Get_Param (Info_Trace, Name_Param, 1));
when W_Delay => Put ("W_Delay");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " sleeping "
& Get_Param (Info_Trace, Timeout_Param, 1)
& " seconds");
when WU_Delay => Put ("WU_Delay");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " sleeping until "
& Get_Param (Info_Trace, Timeout_Param, 1));
when W_Call => Put ("W_Call");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " calling entry "
& Get_Param (Info_Trace, Entry_Param, 1)
& " of " & Get_Param (Info_Trace, Acceptor_Param, 1));
when W_Accept => Put ("W_Accept");
New_Line;
Put ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " waiting on "
& Get_Param (Info_Trace, Number_Param, 1)
& " accept(s)"
& ", " & Get_Param (Info_Trace, Entry_Param, 1));
New_Line;
when W_Select => Put ("W_Select");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " waiting on "
& Get_Param (Info_Trace, Number_Param, 1)
& " select(s)"
& ", " & Get_Param (Info_Trace, Entry_Param, 1));
New_Line;
when W_Completion => Put ("W_Completion");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " waiting for completion ");
when WT_Select => Put ("WT_Select");
New_Line;
Put ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " waiting " & Get_Param (Info_Trace, Timeout_Param, 1)
& " seconds on "
& Get_Param (Info_Trace, Number_Param, 1)
& " select(s)");
if Get_Param (Info_Trace, Number_Param, 1) /= "" then
Put (", " & Get_Param (Info_Trace, Entry_Param, 1));
end if;
New_Line;
when WT_Call => Put ("WT_Call");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " calling entry "
& Get_Param (Info_Trace, Entry_Param, 1)
& " of " & Get_Param (Info_Trace, Acceptor_Param, 1)
& " with timeout "
& Get_Param (Info_Trace, Timeout_Param, 1));
when WT_Completion => Put ("WT_Completion");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " waiting "
& Get_Param (Info_Trace, Timeout_Param, 1)
& " for call completion");
when PO_Call => Put ("PO_Call");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " calling protected entry "
& Get_Param (Info_Trace, Entry_Param, 1));
when POT_Call => Put ("POT_Call");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " calling protected entry "
& Get_Param (Info_Trace, Entry_Param, 1)
& " with timeout "
& Get_Param (Info_Trace, Timeout_Param, 1));
when PO_Run => Put ("PO_Run");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " running entry "
& Get_Param (Info_Trace, Entry_Param, 1)
& " for "
& Get_Param (Info_Trace, Caller_Param, 1));
when PO_Done => Put ("PO_Done");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " finished call from "
& Get_Param (Info_Trace, Caller_Param, 1));
when PO_Lock => Put ("PO_Lock");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " took lock");
when PO_Unlock => Put ("PO_Unlock");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " released lock");
when T_Create => Put ("T_Create");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " created");
when T_Activate => Put ("T_Activate");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " activated");
when T_Abort => Put ("T_Abort");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " aborted by "
& Get_Param (Info_Trace, Parent_Param, 1));
when T_Terminate => Put ("T_Terminate");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " terminated");
when others
=> Put ("Invalid Id");
end case;
Put_Line (" --> " & Info_Trace);
Put_Line ("-----------------------------------");
New_Line;
end Send_Trace;
gcc/ada/7stpopsp.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, Free Software Fundation, 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. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a POSIX-like version of this package.
separate (System.Task_Primitives.Operations)
package body Specific is
----------------
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
pragma Warnings (Off, Environment_Task);
Result : Interfaces.C.int;
begin
Result := pthread_key_create (ATCB_Key'Access, null);
pragma Assert (Result = 0);
end Initialize;
-------------------
-- Is_Valid_Task --
-------------------
function Is_Valid_Task return Boolean is
begin
return pthread_getspecific (ATCB_Key) /= System.Null_Address;
end Is_Valid_Task;
---------
-- Set --
---------
procedure Set (Self_Id : Task_ID) is
Result : Interfaces.C.int;
begin
Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
pragma Assert (Result = 0);
end Set;
----------
-- Self --
----------
function Self return Task_ID is
begin
return To_Task_ID (pthread_getspecific (ATCB_Key));
end Self;
end Specific;
gcc/ada/7straceb.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . T R A C E B A C K --
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2003 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. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This version assumes that System.Machine_State_Operations.Pop_Frame can
-- work with the Info parameter being null.
with System.Machine_State_Operations;
package body System.Traceback is
use System.Machine_State_Operations;
----------------
-- Call_Chain --
----------------
procedure Call_Chain
(Traceback : System.Address;
Max_Len : Natural;
Len : out Natural;
Exclude_Min : System.Address := System.Null_Address;
Exclude_Max : System.Address := System.Null_Address;
Skip_Frames : Natural := 1)
is
type Tracebacks_Array is array (1 .. Max_Len) of Code_Loc;
pragma Suppress_Initialization (Tracebacks_Array);
M : Machine_State;
Code : Code_Loc;
Trace : Tracebacks_Array;
for Trace'Address use Traceback;
N_Skips : Natural := 0;
begin
M := Allocate_Machine_State;
Set_Machine_State (M);
-- Skip the requested number of frames
loop
Code := Get_Code_Loc (M);
exit when Code = Null_Address or else N_Skips = Skip_Frames;
Pop_Frame (M, System.Null_Address);
N_Skips := N_Skips + 1;
end loop;
-- Now, record the frames outside the exclusion bounds, updating
-- the Len output value along the way.
Len := 0;
loop
Code := Get_Code_Loc (M);
exit when Code = Null_Address or else Len = Max_Len;
if Code < Exclude_Min or else Code > Exclude_Max then
Len := Len + 1;
Trace (Len) := Code;
end if;
Pop_Frame (M, System.Null_Address);
end loop;
Free_Machine_State (M);
end Call_Chain;
------------------
-- C_Call_Chain --
------------------
function C_Call_Chain
(Traceback : System.Address;
Max_Len : Natural) return Natural
is
Val : Natural;
begin
Call_Chain (Traceback, Max_Len, Val);
return Val;
end C_Call_Chain;
end System.Traceback;
gcc/ada/7straces.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T R A C E S --
-- --
-- B o d y --
-- --
-- Copyright (C) 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. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with System.Soft_Links;
with System.Parameters;
with System.Traces.Format;
package body System.Traces is
package SSL renames System.Soft_Links;
use System.Traces.Format;
----------------------
-- Send_Trace_Info --
----------------------
procedure Send_Trace_Info (Id : Trace_T) is
Task_S : String := SSL.Task_Name.all;
Trace_S : String (1 .. 3 + Task_S'Length);
begin
if Parameters.Runtime_Traces then
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. Trace_S'Last) := Task_S;
Send_Trace (Id, Trace_S);
end if;
end Send_Trace_Info;
procedure Send_Trace_Info (Id : Trace_T; Timeout : Duration) is
Task_S : String := SSL.Task_Name.all;
Timeout_S : String := Duration'Image (Timeout);
Trace_S : String (1 .. 6 + Task_S'Length + Timeout_S'Length);
begin
if Parameters.Runtime_Traces then
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + Task_S'Length) := Task_S;
Trace_S (4 + Task_S'Length .. 6 + Task_S'Length) := "/T:";
Trace_S (7 + Task_S'Length .. Trace_S'Last) := Timeout_S;
Send_Trace (Id, Trace_S);
end if;
end Send_Trace_Info;
end System.Traces;
gcc/ada/7strafor.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T R A C E S . F O R M A T --
-- --
-- B o d y --
-- --
-- Copyright (C) 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. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with System.Parameters;
package body System.Traces.Format is
procedure Send_Trace (Id : Trace_T; Info : String) is separate;
------------------
-- Format_Trace --
------------------
function Format_Trace (Source : in String) return String_Trace is
Length : Integer := Source'Length;
Result : String_Trace := (others => ' ');
begin
-- If run-time tracing active, then fill the string
if Parameters.Runtime_Traces then
if Max_Size - Length > 0 then
Result (1 .. Length) := Source (1 .. Length);
Result (Length + 1 .. Max_Size) := (others => ' ');
Result (Length + 1) := ASCII.NUL;
else
Result (1 .. Max_Size - 1) := Source (1 .. Max_Size - 1);
Result (Max_Size) := ASCII.NUL;
end if;
end if;
return Result;
end Format_Trace;
------------
-- Append --
------------
function Append
(Source : String_Trace;
Annex : String)
return String_Trace
is
Result : String_Trace := (others => ' ');
Source_Length : Integer := 1;
Annex_Length : Integer := Annex'Length;
begin
if Parameters.Runtime_Traces then
-- First we determine the size used, without the spaces at the
-- end, if a String_Trace is present. Look at
-- System.Traces.Tasking for examples.
while Source (Source_Length) /= ASCII.NUL loop
Source_Length := Source_Length + 1;
end loop;
-- Then we fill the string.
if Source_Length - 1 + Annex_Length <= Max_Size then
Result (1 .. Source_Length - 1) :=
Source (1 .. Source_Length - 1);
Result (Source_Length .. Source_Length - 1 + Annex_Length) :=
Annex (1 .. Annex_Length);
Result (Source_Length + Annex_Length) := ASCII.NUL;
Result (Source_Length + Annex_Length + 1 .. Max_Size) :=
(others => ' ');
else
Result (1 .. Source_Length - 1) := Source (1 .. Source_Length - 1);
Result (Source_Length .. Max_Size - 1) :=
Annex (1 .. Max_Size - Source_Length);
Result (Max_Size) := ASCII.NUL;
end if;
end if;
return Result;
end Append;
end System.Traces.Format;
gcc/ada/7strafor.ads deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T R A C E S . F O R M A T --
-- --
-- S p e c --
-- --
-- Copyright (C) 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. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package implements functions to format run-time traces
package System.Traces.Format is
Max_Size : constant Integer := 128;
-- Event messages' maximum size.
subtype String_Trace is String (1 .. Max_Size);
-- Specific type in which trace information is stored. An ASCII.NUL
-- character ends the string so that it is compatible with C strings
-- which is useful on some targets (eg. VxWorks)
-- These private functions handles String_Trace formatting
function Format_Trace (Source : String) return String_Trace;
-- Put a String in a String_Trace, truncates the string if necessary.
-- Similar to Head( .. ) found in Ada.Strings.Bounded
function Append
(Source : String_Trace;
Annex : String)
return String_Trace;
pragma Inline (Append);
-- Concatenates two string, similar to & operator from Ada.String.Unbounded
procedure Send_Trace (Id : Trace_T; Info : String);
-- This function (which is a subunit) send messages to external programs
end System.Traces.Format;
gcc/ada/7stratas.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T R A C E S . T A S K I N G --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2002 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. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with System.Tasking; use System.Tasking;
with System.Soft_Links;
with System.Parameters;
with System.Traces.Format; use System.Traces.Format;
with System.Traces; use System.Traces;
package body System.Traces.Tasking is
use System.Tasking;
use System.Traces;
use System.Traces.Format;
package SSL renames System.Soft_Links;
function Extract_Accepts (Task_Name : Task_ID) return String_Trace;
-- This function is used to extract data joined with
-- W_Select, WT_Select, W_Accept events
---------------------
-- Send_Trace_Info --
---------------------
procedure Send_Trace_Info (Id : Trace_T; Task_Name2 : Task_ID) is
Task_S : constant String := SSL.Task_Name.all;
Task2_S : constant String :=
Task_Name2.Common.Task_Image
(1 .. Task_Name2.Common.Task_Image_Len);
Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length);
L0 : Integer := Task_S'Length;
L1 : Integer := Task2_S'Length;
begin
if Parameters.Runtime_Traces then
case Id is
when M_RDV_Complete | PO_Done =>
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/C:";
Trace_S (7 + L0 .. Trace_S'Last) := Task2_S;
Send_Trace (Id, Trace_S);
when E_Missed =>
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/A:";
Trace_S (7 + L0 .. Trace_S'Last) := Task2_S;
Send_Trace (Id, Trace_S);
when E_Kill =>
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L1) := Task2_S;
Trace_S (4 + L1 .. Trace_S'Last) := (others => ' ');
Send_Trace (Id, Trace_S);
when T_Create =>
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L1) := Task2_S;
Trace_S (4 + L1 .. Trace_S'Last) := (others => ' ');
Send_Trace (Id, Trace_S);
when others =>
null;
-- should raise an exception ???
end case;
end if;
end Send_Trace_Info;
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name2 : Task_ID;
Entry_Number : Entry_Index)
is
Task_S : constant String := SSL.Task_Name.all;
Task2_S : constant String :=
Task_Name2.Common.Task_Image
(1 .. Task_Name2.Common.Task_Image_Len);
Entry_S : String := Integer'Image (Integer (Entry_Number));
Trace_S : String (1 .. 9 + Task_S'Length
+ Task2_S'Length + Entry_S'Length);
L0 : Integer := Task_S'Length;
L1 : Integer := Task_S'Length + Entry_S'Length;
L2 : Integer := Task_S'Length + Task2_S'Length;
begin
if Parameters.Runtime_Traces then
case Id is
when M_Accept_Complete =>
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/E:";
Trace_S (7 + L0 .. 6 + L1) := Entry_S;
Trace_S (7 + L1 .. 9 + L1) := "/C:";
Trace_S (10 + L1 .. Trace_S'Last) := Task2_S;
Send_Trace (Id, Trace_S);
when W_Call =>
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/A:";
Trace_S (7 + L0 .. 6 + L2) := Task2_S;
Trace_S (7 + L2 .. 9 + L2) := "/C:";
Trace_S (10 + L2 .. Trace_S'Last) := Entry_S;
Send_Trace (Id, Trace_S);
when others =>
null;
-- should raise an exception ???
end case;
end if;
end Send_Trace_Info;
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : Task_ID;
Task_Name2 : Task_ID;
Entry_Number : Entry_Index)
is
Task_S : constant String :=
Task_Name.Common.Task_Image
(1 .. Task_Name.Common.Task_Image_Len);
Task2_S : constant String :=
Task_Name2.Common.Task_Image
(1 .. Task_Name2.Common.Task_Image_Len);
Entry_S : String := Integer'Image (Integer (Entry_Number));
Trace_S : String (1 .. 9 + Task_S'Length
+ Task2_S'Length + Entry_S'Length);
L0 : Integer := Task_S'Length;
L1 : Integer := Task_S'Length + Entry_S'Length;
begin
if Parameters.Runtime_Traces then
case Id is
when PO_Run =>
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/E:";
Trace_S (7 + L0 .. 6 + L1) := Entry_S;
Trace_S (7 + L1 .. 9 + L1) := "/C:";
Trace_S (10 + L1 .. Trace_S'Last) := Task2_S;
Send_Trace (Id, Trace_S);
when others =>
null;
-- should raise an exception ???
end case;
end if;
end Send_Trace_Info;
procedure Send_Trace_Info (Id : Trace_T; Entry_Number : Entry_Index) is
Task_S : String := SSL.Task_Name.all;
Entry_S : String := Integer'Image (Integer (Entry_Number));
Trace_S : String (1 .. 6 + Task_S'Length + Entry_S'Length);
L0 : Integer := Task_S'Length;
begin
if Parameters.Runtime_Traces then
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/E:";
Trace_S (7 + L0 .. Trace_S'Last) := Entry_S;
Send_Trace (Id, Trace_S);
end if;
end Send_Trace_Info;
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : Task_ID;
Task_Name2 : Task_ID)
is
Task_S : constant String :=
Task_Name.Common.Task_Image
(1 .. Task_Name.Common.Task_Image_Len);
Task2_S : constant String :=
Task_Name2.Common.Task_Image
(1 .. Task_Name2.Common.Task_Image_Len);
Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length);
L0 : Integer := Task2_S'Length;
begin
if Parameters.Runtime_Traces then
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task2_S;
Trace_S (4 + L0 .. 6 + L0) := "/P:";
Trace_S (7 + L0 .. Trace_S'Last) := Task_S;
Send_Trace (Id, Trace_S);
end if;
end Send_Trace_Info;
procedure Send_Trace_Info
(Id : Trace_T;
Acceptor : Task_ID;
Entry_Number : Entry_Index;
Timeout : Duration)
is
Task_S : constant String := SSL.Task_Name.all;
Acceptor_S : constant String :=
Acceptor.Common.Task_Image
(1 .. Acceptor.Common.Task_Image_Len);
Entry_S : String := Integer'Image (Integer (Entry_Number));
Timeout_S : String := Duration'Image (Timeout);
Trace_S : String (1 .. 12 + Task_S'Length + Acceptor_S'Length
+ Entry_S'Length + Timeout_S'Length);
L0 : Integer := Task_S'Length;
L1 : Integer := Task_S'Length + Acceptor_S'Length;
L2 : Integer := Task_S'Length + Acceptor_S'Length + Entry_S'Length;
begin
if Parameters.Runtime_Traces then
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/A:";
Trace_S (7 + L0 .. 6 + L1) := Acceptor_S;
Trace_S (7 + L1 .. 9 + L1) := "/E:";
Trace_S (10 + L1 .. 9 + L2) := Entry_S;
Trace_S (10 + L2 .. 12 + L2) := "/T:";
Trace_S (13 + L2 .. Trace_S'Last) := Timeout_S;
Send_Trace (Id, Trace_S);
end if;
end Send_Trace_Info;
procedure Send_Trace_Info
(Id : Trace_T;
Entry_Number : Entry_Index;
Timeout : Duration)
is
Task_S : String := SSL.Task_Name.all;
Entry_S : String := Integer'Image (Integer (Entry_Number));
Timeout_S : String := Duration'Image (Timeout);
Trace_S : String (1 .. 9 + Task_S'Length
+ Entry_S'Length + Timeout_S'Length);
L0 : Integer := Task_S'Length;
L1 : Integer := Task_S'Length + Entry_S'Length;
begin
if Parameters.Runtime_Traces then
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/E:";
Trace_S (7 + L0 .. 6 + L1) := Entry_S;
Trace_S (7 + L1 .. 9 + L1) := "/T:";
Trace_S (10 + L1 .. Trace_S'Last) := Timeout_S;
Send_Trace (Id, Trace_S);
end if;
end Send_Trace_Info;
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : Task_ID;
Number : Integer)
is
Task_S : String := SSL.Task_Name.all;
Number_S : String := Integer'Image (Number);
Accepts_S : String := Extract_Accepts (Task_Name);
Trace_S : String (1 .. 9 + Task_S'Length
+ Number_S'Length + Accepts_S'Length);
L0 : Integer := Task_S'Length;
L1 : Integer := Task_S'Length + Number_S'Length;
begin
if Parameters.Runtime_Traces then
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/#:";
Trace_S (7 + L0 .. 6 + L1) := Number_S;
Trace_S (7 + L1 .. 9 + L1) := "/E:";
Trace_S (10 + L1 .. Trace_S'Last) := Accepts_S;
Send_Trace (Id, Trace_S);
end if;
end Send_Trace_Info;
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : Task_ID;
Number : Integer;
Timeout : Duration)
is
Task_S : String := SSL.Task_Name.all;
Timeout_S : String := Duration'Image (Timeout);
Number_S : String := Integer'Image (Number);
Accepts_S : String := Extract_Accepts (Task_Name);
Trace_S : String (1 .. 12 + Task_S'Length + Timeout_S'Length
+ Number_S'Length + Accepts_S'Length);
L0 : Integer := Task_S'Length;
L1 : Integer := Task_S'Length + Timeout_S'Length;
L2 : Integer := Task_S'Length + Timeout_S'Length + Number_S'Length;
begin
if Parameters.Runtime_Traces then
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/T:";
Trace_S (7 + L0 .. 6 + L1) := Timeout_S;
Trace_S (7 + L1 .. 9 + L1) := "/#:";
Trace_S (10 + L1 .. 9 + L2) := Number_S;
Trace_S (10 + L2 .. 12 + L2) := "/E:";
Trace_S (13 + L2 .. Trace_S'Last) := Accepts_S;
Send_Trace (Id, Trace_S);
end if;
end Send_Trace_Info;
---------------------
-- Extract_Accepts --
---------------------
-- This function returns a string in which all opened
-- Accepts or Selects are given, separated by semi-colons.
function Extract_Accepts (Task_Name : Task_ID) return String_Trace is
Info_Annex : String_Trace := (ASCII.NUL, others => ' ');
begin
for J in Task_Name.Open_Accepts'First ..
Task_Name.Open_Accepts'Last - 1
loop
Info_Annex := Append (Info_Annex, Integer'Image
(Integer (Task_Name.Open_Accepts (J).S)) & ",");
end loop;
Info_Annex := Append (Info_Annex,
Integer'Image (Integer
(Task_Name.Open_Accepts
(Task_Name.Open_Accepts'Last).S)));
return Info_Annex;
end Extract_Accepts;
end System.Traces.Tasking;
gcc/ada/86numaux.adb deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . A U X --
-- --
-- B o d y --
-- (Machine Version for x86) --
-- --
-- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- File a-numaux.adb <- 86numaux.adb
-- This version of Numerics.Aux is for the IEEE Double Extended floating
-- point format on x86.
with System.Machine_Code; use System.Machine_Code;
package body Ada.Numerics.Aux is
NL : constant String := ASCII.LF & ASCII.HT;
type FPU_Stack_Pointer is range 0 .. 7;
for FPU_Stack_Pointer'Size use 3;
type FPU_Status_Word is record
B : Boolean; -- FPU Busy (for 8087 compatibility only)
ES : Boolean; -- Error Summary Status
SF : Boolean; -- Stack Fault
Top : FPU_Stack_Pointer;
-- Condition Code Flags
-- C2 is set by FPREM and FPREM1 to indicate incomplete reduction.
-- In case of successfull recorction, C0, C3 and C1 are set to the
-- three least significant bits of the result (resp. Q2, Q1 and Q0).
-- C2 is used by FPTAN, FSIN, FCOS, and FSINCOS to indicate that
-- that source operand is beyond the allowable range of
-- -2.0**63 .. 2.0**63.
C3 : Boolean;
C2 : Boolean;
C1 : Boolean;
C0 : Boolean;
-- Exception Flags
PE : Boolean; -- Precision
UE : Boolean; -- Underflow
OE : Boolean; -- Overflow
ZE : Boolean; -- Zero Divide
DE : Boolean; -- Denormalized Operand
IE : Boolean; -- Invalid Operation
end record;
for FPU_Status_Word use record
B at 0 range 15 .. 15;
C3 at 0 range 14 .. 14;
Top at 0 range 11 .. 13;
C2 at 0 range 10 .. 10;
C1 at 0 range 9 .. 9;
C0 at 0 range 8 .. 8;
ES at 0 range 7 .. 7;
SF at 0 range 6 .. 6;
PE at 0 range 5 .. 5;
UE at 0 range 4 .. 4;
OE at 0 range 3 .. 3;
ZE at 0 range 2 .. 2;
DE at 0 range 1 .. 1;
IE at 0 range 0 .. 0;
end record;
for FPU_Status_Word'Size use 16;
-----------------------
-- Local subprograms --
-----------------------
function Is_Nan (X : Double) return Boolean;
-- Return True iff X is a IEEE NaN value
function Logarithmic_Pow (X, Y : Double) return Double;
-- Implementation of X**Y using Exp and Log functions (binary base)
-- to calculate the exponentiation. This is used by Pow for values
-- for values of Y in the open interval (-0.25, 0.25)
function Reduce (X : Double) return Double;
-- Implement partial reduction of X by Pi in the x86.
-- Note that for the Sin, Cos and Tan functions completely accurate
-- reduction of the argument is done for arguments in the range of
-- -2.0**63 .. 2.0**63, using a 66-bit approximation of Pi.
pragma Inline (Is_Nan);
pragma Inline (Reduce);
---------------------------------
-- Basic Elementary Functions --
---------------------------------
-- This section implements a few elementary functions that are
-- used to build the more complex ones. This ordering enables
-- better inlining.
----------
-- Atan --
----------
function Atan (X : Double) return Double is
Result : Double;
begin
Asm (Template =>
"fld1" & NL
& "fpatan",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", X));
-- The result value is NaN iff input was invalid
if not (Result = Result) then
raise Argument_Error;
end if;
return Result;
end Atan;
---------
-- Exp --
---------
function Exp (X : Double) return Double is
Result : Double;
begin
Asm (Template =>
"fldl2e " & NL
& "fmulp %%st, %%st(1)" & NL -- X * log2 (E)
& "fld %%st(0) " & NL
& "frndint " & NL -- Integer (X * Log2 (E))
& "fsubr %%st, %%st(1)" & NL -- Fraction (X * Log2 (E))
& "fxch " & NL
& "f2xm1 " & NL -- 2**(...) - 1
& "fld1 " & NL
& "faddp %%st, %%st(1)" & NL -- 2**(Fraction (X * Log2 (E)))
& "fscale " & NL -- E ** X
& "fstp %%st(1) ",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", X));
return Result;
end Exp;
------------
-- Is_Nan --
------------
function Is_Nan (X : Double) return Boolean is
begin
-- The IEEE NaN values are the only ones that do not equal themselves
return not (X = X);
end Is_Nan;
---------
-- Log --
---------
function Log (X : Double) return Double is
Result : Double;
begin
Asm (Template =>
"fldln2 " & NL
& "fxch " & NL
& "fyl2x " & NL,
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", X));
return Result;
end Log;
------------
-- Reduce --
------------
function Reduce (X : Double) return Double is
Result : Double;
begin
Asm
(Template =>
-- Partial argument reduction
"fldpi " & NL
& "fadd %%st(0), %%st" & NL
& "fxch %%st(1) " & NL
& "fprem1 " & NL
& "fstp %%st(1) ",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", X));
return Result;
end Reduce;
----------
-- Sqrt --
----------
function Sqrt (X : Double) return Double is
Result : Double;
begin
if X < 0.0 then
raise Argument_Error;
end if;
Asm (Template => "fsqrt",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", X));
return Result;
end Sqrt;
---------------------------------
-- Other Elementary Functions --
---------------------------------
-- These are built using the previously implemented basic functions
----------
-- Acos --
----------
function Acos (X : Double) return Double is
Result : Double;
begin
Result := 2.0 * Atan (Sqrt ((1.0 - X) / (1.0 + X)));
-- The result value is NaN iff input was invalid
if Is_Nan (Result) then
raise Argument_Error;
end if;
return Result;
end Acos;
----------
-- Asin --
----------
function Asin (X : Double) return Double is
Result : Double;
begin
Result := Atan (X / Sqrt ((1.0 - X) * (1.0 + X)));
-- The result value is NaN iff input was invalid
if Is_Nan (Result) then
raise Argument_Error;
end if;
return Result;
end Asin;
---------
-- Cos --
---------
function Cos (X : Double) return Double is
Reduced_X : Double := X;
Result : Double;
Status : FPU_Status_Word;
begin
loop
Asm
(Template =>
"fcos " & NL
& "xorl %%eax, %%eax " & NL
& "fnstsw %%ax ",
Outputs => (Double'Asm_Output ("=t", Result),
FPU_Status_Word'Asm_Output ("=a", Status)),
Inputs => Double'Asm_Input ("0", Reduced_X));
exit when not Status.C2;
-- Original argument was not in range and the result
-- is the unmodified argument.
Reduced_X := Reduce (Result);
end loop;
return Result;
end Cos;
---------------------
-- Logarithmic_Pow --
---------------------
function Logarithmic_Pow (X, Y : Double) return Double is
Result : Double;
begin
Asm (Template => "" -- X : Y
& "fyl2x " & NL -- Y * Log2 (X)
& "fst %%st(1) " & NL -- Y * Log2 (X) : Y * Log2 (X)
& "frndint " & NL -- Int (...) : Y * Log2 (X)
& "fsubr %%st, %%st(1)" & NL -- Int (...) : Fract (...)
& "fxch " & NL -- Fract (...) : Int (...)
& "f2xm1 " & NL -- 2**Fract (...) - 1 : Int (...)
& "fld1 " & NL -- 1 : 2**Fract (...) - 1 : Int (...)
& "faddp %%st, %%st(1)" & NL -- 2**Fract (...) : Int (...)
& "fscale " & NL -- 2**(Fract (...) + Int (...))
& "fstp %%st(1) ",
Outputs => Double'Asm_Output ("=t", Result),
Inputs =>
(Double'Asm_Input ("0", X),
Double'Asm_Input ("u", Y)));
return Result;
end Logarithmic_Pow;
---------
-- Pow --
---------
function Pow (X, Y : Double) return Double is
type Mantissa_Type is mod 2**Double'Machine_Mantissa;
-- Modular type that can hold all bits of the mantissa of Double
-- For negative exponents, a division is done
-- at the end of the processing.
Negative_Y : constant Boolean := Y < 0.0;
Abs_Y : constant Double := abs Y;
-- During this function the following invariant is kept:
-- X ** (abs Y) = Base**(Exp_High + Exp_Mid + Exp_Low) * Factor
Base : Double := X;
Exp_High : Double := Double'Floor (Abs_Y);
Exp_Mid : Double;
Exp_Low : Double;
Exp_Int : Mantissa_Type;
Factor : Double := 1.0;
begin
-- Select algorithm for calculating Pow:
-- integer cases fall through
if Exp_High >= 2.0**Double'Machine_Mantissa then
-- In case of Y that is IEEE infinity, just raise constraint error
if Exp_High > Double'Safe_Last then
raise Constraint_Error;
end if;
-- Large values of Y are even integers and will stay integer
-- after division by two.
loop
-- Exp_Mid and Exp_Low are zero, so
-- X**(abs Y) = Base ** Exp_High = (Base**2) ** (Exp_High / 2)
Exp_High := Exp_High / 2.0;
Base := Base * Base;
exit when Exp_High < 2.0**Double'Machine_Mantissa;
end loop;
elsif Exp_High /= Abs_Y then
Exp_Low := Abs_Y - Exp_High;
Factor := 1.0;
if Exp_Low /= 0.0 then
-- Exp_Low now is in interval (0.0, 1.0)
-- Exp_Mid := Double'Floor (Exp_Low * 4.0) / 4.0;
Exp_Mid := 0.0;
Exp_Low := Exp_Low - Exp_Mid;
if Exp_Low >= 0.5 then
Factor := Sqrt (X);
Exp_Low := Exp_Low - 0.5; -- exact
if Exp_Low >= 0.25 then
Factor := Factor * Sqrt (Factor);
Exp_Low := Exp_Low - 0.25; -- exact
end if;
elsif Exp_Low >= 0.25 then
Factor := Sqrt (Sqrt (X));
Exp_Low := Exp_Low - 0.25; -- exact
end if;
-- Exp_Low now is in interval (0.0, 0.25)
-- This means it is safe to call Logarithmic_Pow
-- for the remaining part.
Factor := Factor * Logarithmic_Pow (X, Exp_Low);
end if;
elsif X = 0.0 then
return 0.0;
end if;
-- Exp_High is non-zero integer smaller than 2**Double'Machine_Mantissa
Exp_Int := Mantissa_Type (Exp_High);
-- Standard way for processing integer powers > 0
while Exp_Int > 1 loop
if (Exp_Int and 1) = 1 then
-- Base**Y = Base**(Exp_Int - 1) * Exp_Int for Exp_Int > 0
Factor := Factor * Base;
end if;
-- Exp_Int is even and Exp_Int > 0, so
-- Base**Y = (Base**2)**(Exp_Int / 2)
Base := Base * Base;
Exp_Int := Exp_Int / 2;
end loop;
-- Exp_Int = 1 or Exp_Int = 0
if Exp_Int = 1 then
Factor := Base * Factor;
end if;
if Negative_Y then
Factor := 1.0 / Factor;
end if;
return Factor;
end Pow;
---------
-- Sin --
---------
function Sin (X : Double) return Double is
Reduced_X : Double := X;
Result : Double;
Status : FPU_Status_Word;
begin
loop
Asm
(Template =>
"fsin " & NL
& "xorl %%eax, %%eax " & NL
& "fnstsw %%ax ",
Outputs => (Double'Asm_Output ("=t", Result),
FPU_Status_Word'Asm_Output ("=a", Status)),
Inputs => Double'Asm_Input ("0", Reduced_X));
exit when not Status.C2;
-- Original argument was not in range and the result
-- is the unmodified argument.
Reduced_X := Reduce (Result);
end loop;
return Result;
end Sin;
---------
-- Tan --
---------
function Tan (X : Double) return Double is
Reduced_X : Double := X;
Result : Double;
Status : FPU_Status_Word;
begin
loop
Asm
(Template =>
"fptan " & NL
& "xorl %%eax, %%eax " & NL
& "fnstsw %%ax " & NL
& "ffree %%st(0) " & NL
& "fincstp ",
Outputs => (Double'Asm_Output ("=t", Result),
FPU_Status_Word'Asm_Output ("=a", Status)),
Inputs => Double'Asm_Input ("0", Reduced_X));
exit when not Status.C2;
-- Original argument was not in range and the result
-- is the unmodified argument.
Reduced_X := Reduce (Result);
end loop;
return Result;
end Tan;
----------
-- Sinh --
----------
function Sinh (X : Double) return Double is
begin
-- Mathematically Sinh (x) is defined to be (Exp (X) - Exp (-X)) / 2.0
if abs X < 25.0 then
return (Exp (X) - Exp (-X)) / 2.0;
else
return Exp (X) / 2.0;
end if;
end Sinh;
----------
-- Cosh --
----------
function Cosh (X : Double) return Double is
begin
-- Mathematically Cosh (X) is defined to be (Exp (X) + Exp (-X)) / 2.0
if abs X < 22.0 then
return (Exp (X) + Exp (-X)) / 2.0;
else
return Exp (X) / 2.0;
end if;
end Cosh;
----------
-- Tanh --
----------
function Tanh (X : Double) return Double is
begin
-- Return the Hyperbolic Tangent of x
--
-- x -x
-- e - e Sinh (X)
-- Tanh (X) is defined to be ----------- = --------
-- x -x Cosh (X)
-- e + e
if abs X > 23.0 then
return Double'Copy_Sign (1.0, X);
end if;
return 1.0 / (1.0 + Exp (-2.0 * X)) - 1.0 / (1.0 + Exp (2.0 * X));
end Tanh;
end Ada.Numerics.Aux;
gcc/ada/86numaux.ads deleted 100644 → 0
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . A U X --
-- --
-- S p e c --
-- (Machine Version for x86) --
-- --
-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides the basic computational interface for the generic
-- elementary functions. This implementation is based on the glibc assembly
-- sources for the x86 glibc math library.
-- Note: there are two versions of this package. One using the 80-bit x86
-- long double format (which is this version), and one using 64-bit IEEE
-- double (see file a-numaux.ads). The latter version imports the C
-- routines directly.
package Ada.Numerics.Aux is
pragma Pure (Aux);
type Double is new Long_Long_Float;
function Sin (X : Double) return Double;
function Cos (X : Double) return Double;
function Tan (X : Double) return Double;
function Exp (X : Double) return Double;
function Sqrt (X : Double) return Double;
function Log (X : Double) return Double;
function Atan (X : Double) return Double;
function Acos (X : Double) return Double;
function Asin (X : Double) return Double;
function Sinh (X : Double) return Double;
function Cosh (X : Double) return Double;
function Tanh (X : Double) return Double;
function Pow (X, Y : Double) return Double;
private
pragma Inline (Atan);
pragma Inline (Cos);
pragma Inline (Tan);
pragma Inline (Exp);
pragma Inline (Log);
pragma Inline (Sin);
pragma Inline (Sqrt);
end Ada.Numerics.Aux;
gcc/ada/ChangeLog
2004-05-14 Arnaud Charlet <charlet@act-europe.fr>
Renaming of target specific files for clarity
* Makefile.in: Rename GNAT target specific files.
* 31soccon.ads, 31soliop.ads 35soccon.ads, 3asoccon.ads,
3bsoccon.ads, 3gsoccon.ads, 3hsoccon.ads, 3psoccon.ads,
3ssoccon.ads, 3ssoliop.ads, 3veacodu.adb, 3vexpect.adb,
3vsoccon.ads, 3vsocthi.adb, 3vsocthi.ads, 3vtrasym.adb,
3wsoccon.ads, 3wsocthi.adb, 3wsocthi.ads, 3wsoliop.ads,
3zsoccon.ads, 3zsocthi.adb, 3zsocthi.ads, 41intnam.ads,
42intnam.ads, 45intnam.ads, 4aintnam.ads, 4cintnam.ads,
4gintnam.ads, 4hexcpol.adb, 4hintnam.ads, 4lintnam.ads,
4nintnam.ads, 4ointnam.ads, 4onumaux.ads, 4pintnam.ads,
4sintnam.ads, 4vcaldel.adb, 4vcalend.adb, 4vcalend.ads,
4vintnam.ads, 4wcalend.adb, 4wexcpol.adb, 4wintnam.ads,
4zintnam.ads, 4znumaux.ads, 4zsytaco.adb, 4zsytaco.ads,
51osinte.adb, 51osinte.ads, 51system.ads,
52osinte.adb, 52osinte.ads, 53osinte.ads, 54osinte.ads,
55osinte.adb, 55osinte.ads, 55system.ads, 56osinte.adb,
56osinte.ads, 56system.ads, 56taprop.adb, 56taspri.ads,
56tpopsp.adb, 57system.ads, 58system.ads,
5amastop.adb, 5aml-tgt.adb, 5aosinte.adb, 5aosinte.ads,
5asystem.ads, 5ataprop.adb, 5atasinf.ads, 5ataspri.ads,
5atpopsp.adb, 5avxwork.ads, 5bml-tgt.adb, 5bosinte.adb,
5bosinte.ads, 5bsystem.ads, 5cosinte.ads, 5csystem.ads,
5dsystem.ads, 5esystem.ads, 5fintman.adb, 5fosinte.adb,
5fosinte.ads, 5fsystem.ads, 5ftaprop.adb, 5ftasinf.ads,
5ginterr.adb, 5gintman.adb, 5gmastop.adb, 5gml-tgt.adb,
5gosinte.ads, 5gproinf.adb, 5gproinf.ads, 5gsystem.ads,
5gtaprop.adb, 5gtasinf.adb, 5gtasinf.ads, 5gtpgetc.adb,
5hml-tgt.adb, 5hosinte.adb, 5hosinte.ads, 5hparame.ads,
5hsystem.ads, 5htaprop.adb, 5htaspri.ads, 5htraceb.adb,
5iosinte.adb, 5iosinte.ads, 5itaprop.adb, 5itaspri.ads,
5ksystem.ads, 5kvxwork.ads, 5lml-tgt.adb, 5losinte.ads,
5lparame.adb, 5lsystem.ads, 5msystem.ads, 5mvxwork.ads,
5ninmaop.adb, 5nintman.adb, 5nosinte.ads, 5nsystem.ads,
5ntaprop.adb, 5ntaspri.ads, 5ointerr.adb, 5omastop.adb,
5oosinte.adb, 5oosinte.ads, 5oosprim.adb, 5oparame.adb,
5osystem.ads, 5otaprop.adb, 5otaspri.ads, 5posinte.ads,
5posprim.adb, 5psystem.ads, 5pvxwork.ads, 5sintman.adb,
5sml-tgt.adb, 5sosinte.adb, 5sosinte.ads, 5sosprim.adb,
5sparame.adb, 5ssystem.ads, 5staprop.adb, 5stasinf.adb,
5stasinf.ads, 5staspri.ads, 5stpopsp.adb, 5svxwork.ads,
5tosinte.ads, 5usystem.ads, 5vasthan.adb, 5vdirval.adb,
5vinmaop.adb, 5vinterr.adb, 5vintman.adb, 5vintman.ads,
5vmastop.adb, 5vml-tgt.adb, 5vosinte.adb, 5vosinte.ads,
5vosprim.adb, 5vosprim.ads, 5vparame.ads, 5vsymbol.adb,
5vsystem.ads, 5vtaprop.adb, 5vtaspri.ads, 5vtpopde.adb,
5vtpopde.ads, 5vtraent.adb, 5vtraent.ads, 5vvaflop.adb,
5wdirval.adb, 5wgloloc.adb, 5wintman.adb, 5wmemory.adb,
5wml-tgt.adb, 5wosinte.ads, 5wosprim.adb, 5wsystem.ads,
5wtaprop.adb, 5wtaspri.ads, 5xparame.ads, 5xsystem.ads,
5xvxwork.ads, 5yparame.ads, 5ysystem.ads, 5zinterr.adb,
5zintman.adb, 5zintman.ads, 5zml-tgt.adb, 5zosinte.adb,
5zosinte.ads, 5zosprim.adb, 5zparame.ads, 5zstchop.adb,
5zsystem.ads, 5ztaprop.adb, 5ztaspri.ads, 5ztfsetr.adb,
5ztpopsp.adb, 6vcpp.adb, 6vcstrea.adb, 6vinterf.ads,
7sinmaop.adb, 7sintman.adb, 7sosinte.adb, 7sosprim.adb,
7staprop.adb, 7staspri.ads, 7stfsetr.adb, 7stpopsp.adb,
7straceb.adb, 7straces.adb, 7strafor.adb, 7strafor.ads,
7stratas.adb, 86numaux.adb, 86numaux.ads: Replaced by files below.
* a-caldel-vms.adb, a-calend-mingw.adb, a-calend-vms.adb,
a-calend-vms.ads, a-dirval-mingw.adb, a-dirval-vms.adb,
a-excpol-abort.adb, a-excpol-interix.adb, a-intnam-aix.ads,
a-intnam-dummy.ads, a-intnam-freebsd.ads, a-intnam-hpux.ads,
a-intnam-interix.ads, a-intnam-irix.ads, a-intnam-linux.ads,
a-intnam-lynxos.ads, a-intnam-mingw.ads, a-intnam-os2.ads,
a-intnam-solaris.ads, a-intnam-tru64.ads, a-intnam-unixware.ads,
a-intnam-vms.ads, a-intnam-vxworks.ads, a-numaux-libc-x86.ads,
a-numaux-vxworks.ads, a-numaux-x86.adb, a-numaux-x86.ads,
a-sytaco-vxworks.adb, a-sytaco-vxworks.ads, g-eacodu-vms.adb,
g-expect-vms.adb, g-soccon-aix.ads, g-soccon-freebsd.ads,
g-soccon-hpux.ads, g-soccon-interix.ads, g-soccon-irix.ads,
g-soccon-mingw.ads, g-soccon-solaris.ads, g-soccon-tru64.ads,
g-soccon-unixware.ads, g-soccon-vms.adb, g-soccon-vxworks.ads,
g-socthi-mingw.adb, g-socthi-mingw.ads, g-socthi-vms.adb,
g-socthi-vms.ads, g-socthi-vxworks.adb, g-socthi-vxworks.ads,
g-soliop-mingw.ads, g-soliop-solaris.ads, g-soliop-unixware.ads,
g-trasym-vms.adb, i-cpp-vms.adb, i-cstrea-vms.adb,
interfac-vms.ads, mlib-tgt-aix.adb, mlib-tgt-hpux.adb,
mlib-tgt-irix.adb, mlib-tgt-linux.adb, mlib-tgt-mingw.adb,
mlib-tgt-solaris.adb, mlib-tgt-tru64.adb, mlib-tgt-vms.adb,
mlib-tgt-vxworks.adb, s-asthan-vms.adb, s-gloloc-mingw.adb,
s-inmaop-dummy.adb, s-inmaop-posix.adb, s-inmaop-vms.adb,
s-interr-dummy.adb, s-interr-sigaction.adb, s-interr-vms.adb,
s-interr-vxworks.adb, s-intman-dummy.adb, s-intman-irix.adb,
s-intman-irix-athread.adb, s-intman-mingw.adb, s-intman-posix.adb,
s-intman-solaris.adb, s-intman-vms.adb, s-intman-vms.ads,
s-intman-vxworks.adb, s-intman-vxworks.ads, s-mastop-irix.adb,
s-mastop-tru64.adb, s-mastop-vms.adb, s-mastop-x86.adb,
s-memory-mingw.adb, s-osinte-aix.adb, s-osinte-aix.ads,
s-osinte-aix-fsu.ads, s-osinte-dummy.ads, s-osinte-freebsd.adb,
s-osinte-freebsd.ads, s-osinte-fsu.adb, s-osinte-hpux.ads,
s-osinte-hpux-dce.adb, s-osinte-hpux-dce.ads, s-osinte-interix.ads,
s-osinte-irix.adb, s-osinte-irix.ads, s-osinte-irix-athread.ads,
s-osinte-linux.ads, s-osinte-linux-fsu.ads, s-osinte-linux-ia64.ads,
s-osinte-lynxos-3.adb, s-osinte-lynxos-3.ads, s-osinte-lynxos.adb,
s-osinte-lynxos.ads, s-osinte-mingw.ads, s-osinte-os2.adb,
s-osinte-os2.ads, s-osinte-posix.adb, s-osinte-solaris.adb,
s-osinte-solaris.ads, s-osinte-solaris-fsu.ads,
s-osinte-solaris-posix.ads, s-osinte-tru64.adb, s-osinte-tru64.ads,
s-osinte-unixware.adb, s-osinte-unixware.ads, s-osinte-vms.adb,
s-osinte-vms.ads, s-osinte-vxworks.adb,
s-osinte-vxworks.ads, s-osprim-mingw.adb,
s-osprim-os2.adb, s-osprim-posix.adb, s-osprim-solaris.adb,
s-osprim-unix.adb, s-osprim-vms.adb, s-osprim-vms.ads,
s-osprim-vxworks.adb, s-parame-ae653.ads, s-parame-hpux.ads,
s-parame-linux.adb, s-parame-os2.adb, s-parame-solaris.adb,
s-parame-vms.ads, s-parame-vms-restrict.ads, s-parame-vxworks.ads,
s-proinf-irix-athread.adb, s-proinf-irix-athread.ads,
s-stchop-vxworks.adb, s-taprop-dummy.adb,
s-taprop-hpux-dce.adb, s-taprop-irix.adb,
s-taprop-irix-athread.adb, s-taprop-linux.adb, s-taprop-lynxos.adb,
s-taprop-mingw.adb, s-taprop-os2.adb, s-taprop-posix.adb,
s-taprop-solaris.adb, s-taprop-tru64.adb, s-taprop-vms.adb,
s-taprop-vxworks.adb, s-tasinf-irix.ads, s-tasinf-irix-athread.adb,
s-tasinf-irix-athread.ads, s-tasinf-solaris.adb, s-tasinf-solaris.ads,
s-tasinf-tru64.ads, s-taspri-dummy.ads, s-taspri-hpux-dce.ads,
s-taspri-linux.ads, s-taspri-lynxos.ads, s-taspri-mingw.ads,
s-taspri-os2.ads, s-taspri-posix.ads, s-taspri-solaris.ads,
s-taspri-tru64.ads, s-taspri-vms.ads, s-taspri-vxworks.ads,
s-tfsetr-default.adb, s-tfsetr-vxworks.adb, s-tpopde-vms.adb,
s-tpopde-vms.ads, s-tpopsp-lynxos.adb, s-tpopsp-posix.adb,
s-tpopsp-posix-foreign.adb, s-tpopsp-solaris.adb, s-tpopsp-vxworks.adb,
s-traceb-hpux.adb, s-traceb-mastop.adb, s-traces-default.adb,
s-traent-vms.adb, s-traent-vms.ads, s-trafor-default.adb,
s-trafor-default.ads, s-tratas-default.adb, s-vaflop-vms.adb,
s-vxwork-alpha.ads, s-vxwork-m68k.ads, s-vxwork-mips.ads,
s-vxwork-ppc.ads, s-vxwork-sparcv9.ads, s-vxwork-xscale.ads,
symbols-vms.adb, system-aix.ads, system-freebsd-x86.ads,
system-hpux.ads, system-interix.ads, system-irix-n32.ads,
system-irix-o32.ads, system-linux-x86_64.ads,
system-linux-x86.ads, system-lynxos-ppc.ads, system-lynxos-x86.ads,
system-mingw.ads, system-os2.ads, system-solaris-sparc.ads,
system-solaris-sparcv9.ads, system-solaris-x86.ads, system-tru64.ads,
system-unixware.ads, system-vms.ads, system-vms-zcx.ads,
system-vxworks-alpha.ads, system-vxworks-m68k.ads,
system-vxworks-mips.ads, system-vxworks-ppc.ads,
system-vxworks-sparcv9.ads, system-vxworks-xscale.ads: Replace files
above.
2004-05-13 Zack Weinberg <zack@codesourcery.com> 2004-05-13 Zack Weinberg <zack@codesourcery.com>
* trans.c (gnat_stabilize_reference_1): Remove case 'b'. * trans.c (gnat_stabilize_reference_1): Remove case 'b'.
......
gcc/ada/Makefile.in
...@@ -341,13 +341,13 @@ endif ...@@ -341,13 +341,13 @@ endif
# Non-tasking case: # Non-tasking case:
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4nintnam.ads \ a-intnam.ads<a-intnam-dummy.ads \
s-inmaop.adb<5ninmaop.adb \ s-inmaop.adb<s-inmaop-dummy.adb \
s-intman.adb<5nintman.adb \ s-intman.adb<s-intman-dummy.adb \
s-osinte.ads<5nosinte.ads \ s-osinte.ads<s-osinte-dummy.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<5ntaprop.adb \ s-taprop.adb<s-taprop-dummy.adb \
s-taspri.ads<5ntaspri.ads s-taspri.ads<s-taspri-dummy.ads
# Default shared object option. Note that we rely on the fact that the "soname" # Default shared object option. Note that we rely on the fact that the "soname"
# option will always be present and last in this flag, so that we can have # option will always be present and last in this flag, so that we can have
...@@ -384,21 +384,21 @@ LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(fsrcpfx)gnatvsn.ads | ...@@ -384,21 +384,21 @@ LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(fsrcpfx)gnatvsn.ads |
ifeq ($(strip $(filter-out %86 os2 OS2 os2_emx,$(arch) $(osys))),) ifeq ($(strip $(filter-out %86 os2 OS2 os2_emx,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-excpol.adb<4wexcpol.adb \ a-excpol.adb<a-excpol-abort.adb \
a-intnam.ads<4nintnam.ads \ a-intnam.ads<a-intnam-dummy.ads \
a-numaux.adb<86numaux.adb \ a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<86numaux.ads \ a-numaux.ads<a-numaux-x86.ads \
s-inmaop.adb<5ninmaop.adb \ s-inmaop.adb<s-inmaop-dummy.adb \
s-interr.adb<5ointerr.adb \ s-interr.adb<s-interr-dummy.adb \
s-intman.adb<5nintman.adb \ s-intman.adb<s-intman-dummy.adb \
s-mastop.adb<5omastop.adb \ s-mastop.adb<s-mastop-x86.adb \
s-osinte.adb<5oosinte.adb \ s-osinte.adb<s-osinte-os2.adb \
s-osinte.ads<5oosinte.ads \ s-osinte.ads<s-osinte-os2.ads \
s-osprim.adb<5oosprim.adb \ s-osprim.adb<s-osprim-os2.adb \
s-parame.adb<5oparame.adb \ s-parame.adb<s-parame-os2.adb \
system.ads<5osystem.ads \ system.ads<system-os2.ads \
s-taprop.adb<5otaprop.adb \ s-taprop.adb<s-taprop-os2.adb \
s-taspri.ads<5otaspri.ads s-taspri.ads<s-taspri-os2.ads
EXTRA_GNATRTL_NONTASKING_OBJS = \ EXTRA_GNATRTL_NONTASKING_OBJS = \
i-os2err.o \ i-os2err.o \
...@@ -409,21 +409,21 @@ endif ...@@ -409,21 +409,21 @@ endif
ifeq ($(strip $(filter-out %86 interix%,$(arch) $(osys))),) ifeq ($(strip $(filter-out %86 interix%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-excpol.adb<4hexcpol.adb \ a-excpol.adb<a-excpol-interix.adb \
a-intnam.ads<4pintnam.ads \ a-intnam.ads<a-intnam-interix.ads \
a-numaux.adb<86numaux.adb \ a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<86numaux.ads \ a-numaux.ads<a-numaux-x86.ads \
g-soccon.ads<3psoccon.ads \ g-soccon.ads<g-soccon-interix.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-mastop.adb<5omastop.adb \ s-mastop.adb<s-mastop-x86.adb \
s-osinte.adb<7sosinte.adb \ s-osinte.adb<s-osinte-fsu.adb \
s-osinte.ads<5posinte.ads \ s-osinte.ads<s-osinte-interix.ads \
s-osprim.adb<5posprim.adb \ s-osprim.adb<s-osprim-unix.adb \
s-taprop.adb<7staprop.adb \ s-taprop.adb<s-taprop-posix.adb \
system.ads<5psystem.ads \ system.ads<system-interix.ads \
s-taspri.ads<7staspri.ads \ s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<7stpopsp.adb s-tpopsp.adb<s-tpopsp-posix.adb
THREADSLIB = -lgthreads -lmalloc THREADSLIB = -lgthreads -lmalloc
PREFIX_OBJS=$(PREFIX_REAL_OBJS) PREFIX_OBJS=$(PREFIX_REAL_OBJS)
...@@ -432,22 +432,22 @@ endif ...@@ -432,22 +432,22 @@ endif
# sysv5uw is SCO UnixWare 7 # sysv5uw is SCO UnixWare 7
ifeq ($(strip $(filter-out %86 sysv5uw%,$(arch) $(osys))),) ifeq ($(strip $(filter-out %86 sysv5uw%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-excpol.adb<4wexcpol.adb \ a-excpol.adb<a-excpol-abort.adb \
a-intnam.ads<41intnam.ads \ a-intnam.ads<a-intnam-unixware.ads \
a-numaux.adb<86numaux.adb \ a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<86numaux.ads \ a-numaux.ads<a-numaux-x86.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-mastop.adb<5omastop.adb \ s-mastop.adb<s-mastop-x86.adb \
s-osinte.ads<51osinte.ads \ s-osinte.ads<s-osinte-unixware.ads \
s-osinte.adb<51osinte.adb \ s-osinte.adb<s-osinte-unixware.adb \
s-osprim.adb<5posprim.adb \ s-osprim.adb<s-osprim-unix.adb \
s-taprop.adb<7staprop.adb \ s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<7staspri.ads \ s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<5atpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
system.ads<51system.ads \ system.ads<system-unixware.ads \
g-soccon.ads<31soccon.ads \ g-soccon.ads<g-soccon-unixware.ads \
g-soliop.ads<31soliop.ads g-soliop.ads<g-soliop-unixware.ads
THREADSLIB = -lthread THREADSLIB = -lthread
PREFIX_OBJS=$(PREFIX_REAL_OBJS) PREFIX_OBJS=$(PREFIX_REAL_OBJS)
...@@ -458,27 +458,27 @@ endif ...@@ -458,27 +458,27 @@ endif
ifeq ($(strip $(filter-out alpha% dec vx%,$(targ))),) ifeq ($(strip $(filter-out alpha% dec vx%,$(targ))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-sytaco.ads<4zsytaco.ads \ a-sytaco.ads<a-sytaco-vxworks.ads \
a-sytaco.adb<4zsytaco.adb \ a-sytaco.adb<a-sytaco-vxworks.adb \
a-intnam.ads<4zintnam.ads \ a-intnam.ads<a-intnam-vxworks.ads \
a-numaux.ads<4znumaux.ads \ a-numaux.ads<a-numaux-vxworks.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-interr.adb<5zinterr.adb \ s-interr.adb<s-interr-vxworks.adb \
s-intman.ads<5zintman.ads \ s-intman.ads<s-intman-vxworks.ads \
s-intman.adb<5zintman.adb \ s-intman.adb<s-intman-vxworks.adb \
s-osinte.adb<5zosinte.adb \ s-osinte.adb<s-osinte-vxworks.adb \
s-osinte.ads<5zosinte.ads \ s-osinte.ads<s-osinte-vxworks.ads \
s-osprim.adb<5zosprim.adb \ s-osprim.adb<s-osprim-vxworks.adb \
s-parame.ads<5zparame.ads \ s-parame.ads<s-parame-vxworks.ads \
s-stchop.adb<5zstchop.adb \ s-stchop.adb<s-stchop-vxworks.adb \
s-taprop.adb<5ztaprop.adb \ s-taprop.adb<s-taprop-vxworks.adb \
s-tpopsp.adb<5ztpopsp.adb \ s-tpopsp.adb<s-tpopsp-vxworks.adb \
s-taspri.ads<5ztaspri.ads \ s-taspri.ads<s-taspri-vxworks.ads \
s-vxwork.ads<5avxwork.ads \ s-vxwork.ads<s-vxwork-alpha.ads \
g-soccon.ads<3zsoccon.ads \ g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<3zsocthi.ads \ g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<3zsocthi.adb \ g-socthi.adb<g-socthi-vxworks.adb \
system.ads<5zsystem.ads system.ads<system-vxworks-alpha.ads
EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
...@@ -486,104 +486,104 @@ endif ...@@ -486,104 +486,104 @@ endif
ifeq ($(strip $(filter-out m68k% wrs vx%,$(targ))),) ifeq ($(strip $(filter-out m68k% wrs vx%,$(targ))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-sytaco.ads<4zsytaco.ads \ a-sytaco.ads<a-sytaco-vxworks.ads \
a-sytaco.adb<4zsytaco.adb \ a-sytaco.adb<a-sytaco-vxworks.adb \
a-intnam.ads<4zintnam.ads \ a-intnam.ads<a-intnam-vxworks.ads \
a-numaux.ads<4znumaux.ads \ a-numaux.ads<a-numaux-vxworks.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-interr.adb<5zinterr.adb \ s-interr.adb<s-interr-vxworks.adb \
s-intman.ads<5zintman.ads \ s-intman.ads<s-intman-vxworks.ads \
s-intman.adb<5zintman.adb \ s-intman.adb<s-intman-vxworks.adb \
s-osinte.adb<5zosinte.adb \ s-osinte.adb<s-osinte-vxworks.adb \
s-osinte.ads<5zosinte.ads \ s-osinte.ads<s-osinte-vxworks.ads \
s-osprim.adb<5zosprim.adb \ s-osprim.adb<s-osprim-vxworks.adb \
s-parame.ads<5zparame.ads \ s-parame.ads<s-parame-vxworks.ads \
s-stchop.adb<5zstchop.adb \ s-stchop.adb<s-stchop-vxworks.adb \
s-taprop.adb<5ztaprop.adb \ s-taprop.adb<s-taprop-vxworks.adb \
s-taspri.ads<5ztaspri.ads \ s-taspri.ads<s-taspri-vxworks.ads \
s-tpopsp.adb<5ztpopsp.adb \ s-tpopsp.adb<s-tpopsp-vxworks.adb \
s-vxwork.ads<5kvxwork.ads \ s-vxwork.ads<s-vxwork-m68k.ads \
g-soccon.ads<3zsoccon.ads \ g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<3zsocthi.ads \ g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<3zsocthi.adb \ g-socthi.adb<g-socthi-vxworks.adb \
system.ads<5ksystem.ads system.ads<system-vxworks-m68k.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5zml-tgt.adb TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
ifeq ($(strip $(filter-out yes,$(TRACE))),) ifeq ($(strip $(filter-out yes,$(TRACE))),)
LIBGNAT_TARGET_PAIRS += \ LIBGNAT_TARGET_PAIRS += \
s-traces.adb<7straces.adb \ s-traces.adb<s-traces-default.adb \
s-tratas.adb<7stratas.adb \ s-tratas.adb<s-tratas-default.adb \
s-trafor.adb<7strafor.adb \ s-trafor.adb<s-trafor-default.adb \
s-trafor.ads<7strafor.ads \ s-trafor.ads<s-trafor-default.ads \
s-tfsetr.adb<5ztfsetr.adb s-tfsetr.adb<s-tfsetr-vxworks.adb
endif endif
endif endif
ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),) ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-sytaco.ads<4zsytaco.ads \ a-sytaco.ads<a-sytaco-vxworks.ads \
a-sytaco.adb<4zsytaco.adb \ a-sytaco.adb<a-sytaco-vxworks.adb \
a-intnam.ads<4zintnam.ads \ a-intnam.ads<a-intnam-vxworks.ads \
a-numaux.ads<4znumaux.ads \ a-numaux.ads<a-numaux-vxworks.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-interr.adb<5zinterr.adb \ s-interr.adb<s-interr-vxworks.adb \
s-intman.ads<5zintman.ads \ s-intman.ads<s-intman-vxworks.ads \
s-intman.adb<5zintman.adb \ s-intman.adb<s-intman-vxworks.adb \
s-osinte.adb<5zosinte.adb \ s-osinte.adb<s-osinte-vxworks.adb \
s-osinte.ads<5zosinte.ads \ s-osinte.ads<s-osinte-vxworks.ads \
s-osprim.adb<5zosprim.adb \ s-osprim.adb<s-osprim-vxworks.adb \
s-parame.ads<5zparame.ads \ s-parame.ads<s-parame-vxworks.ads \
s-stchop.adb<5zstchop.adb \ s-stchop.adb<s-stchop-vxworks.adb \
s-taprop.adb<5ztaprop.adb \ s-taprop.adb<s-taprop-vxworks.adb \
s-taspri.ads<5ztaspri.ads \ s-taspri.ads<s-taspri-vxworks.ads \
s-tpopsp.adb<5ztpopsp.adb \ s-tpopsp.adb<s-tpopsp-vxworks.adb \
s-vxwork.ads<5pvxwork.ads \ s-vxwork.ads<s-vxwork-ppc.ads \
g-soccon.ads<3zsoccon.ads \ g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<3zsocthi.ads \ g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<3zsocthi.adb \ g-socthi.adb<g-socthi-vxworks.adb \
system.ads<5ysystem.ads system.ads<system-vxworks-ppc.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5zml-tgt.adb TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
ifeq ($(strip $(filter-out yes,$(TRACE))),) ifeq ($(strip $(filter-out yes,$(TRACE))),)
LIBGNAT_TARGET_PAIRS += \ LIBGNAT_TARGET_PAIRS += \
s-traces.adb<7straces.adb \ s-traces.adb<s-traces-default.adb \
s-trafor.adb<7strafor.adb \ s-trafor.adb<s-trafor-default.adb \
s-trafor.ads<7strafor.ads \ s-trafor.ads<s-trafor-default.ads \
s-tratas.adb<7stratas.adb \ s-tratas.adb<s-tratas-default.adb \
s-tfsetr.adb<5ztfsetr.adb s-tfsetr.adb<s-tfsetr-vxworks.adb
endif endif
endif endif
ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),) ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-sytaco.ads<4zsytaco.ads \ a-sytaco.ads<a-sytaco-vxworks.ads \
a-sytaco.adb<4zsytaco.adb \ a-sytaco.adb<a-sytaco-vxworks.adb \
a-intnam.ads<4zintnam.ads \ a-intnam.ads<a-intnam-vxworks.ads \
a-numaux.ads<4znumaux.ads \ a-numaux.ads<a-numaux-vxworks.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-interr.adb<5zinterr.adb \ s-interr.adb<s-interr-vxworks.adb \
s-intman.ads<5zintman.ads \ s-intman.ads<s-intman-vxworks.ads \
s-intman.adb<5zintman.adb \ s-intman.adb<s-intman-vxworks.adb \
s-osinte.adb<5zosinte.adb \ s-osinte.adb<s-osinte-vxworks.adb \
s-osinte.ads<5zosinte.ads \ s-osinte.ads<s-osinte-vxworks.ads \
s-osprim.adb<5zosprim.adb \ s-osprim.adb<s-osprim-vxworks.adb \
s-parame.ads<5zparame.ads \ s-parame.ads<s-parame-vxworks.ads \
s-stchop.adb<5zstchop.adb \ s-stchop.adb<s-stchop-vxworks.adb \
s-taprop.adb<5ztaprop.adb \ s-taprop.adb<s-taprop-vxworks.adb \
s-taspri.ads<5ztaspri.ads \ s-taspri.ads<s-taspri-vxworks.ads \
s-tpopsp.adb<5ztpopsp.adb \ s-tpopsp.adb<s-tpopsp-vxworks.adb \
s-vxwork.ads<5svxwork.ads \ s-vxwork.ads<s-vxwork-sparcv9.ads \
g-soccon.ads<3zsoccon.ads \ g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<3zsocthi.ads \ g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<3zsocthi.adb \ g-socthi.adb<g-socthi-vxworks.adb \
system.ads<5csystem.ads \ system.ads<system-vxworks-sparcv9.ads \
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5zml-tgt.adb TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
...@@ -591,29 +591,29 @@ endif ...@@ -591,29 +591,29 @@ endif
ifeq ($(strip $(filter-out xscale% coff wrs vx%,$(targ))),) ifeq ($(strip $(filter-out xscale% coff wrs vx%,$(targ))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-sytaco.ads<4zsytaco.ads \ a-sytaco.ads<a-sytaco-vxworks.ads \
a-sytaco.adb<4zsytaco.adb \ a-sytaco.adb<a-sytaco-vxworks.adb \
a-intnam.ads<4zintnam.ads \ a-intnam.ads<a-intnam-vxworks.ads \
a-numaux.ads<4znumaux.ads \ a-numaux.ads<a-numaux-vxworks.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-interr.adb<5zinterr.adb \ s-interr.adb<s-interr-vxworks.adb \
s-intman.ads<5zintman.ads \ s-intman.ads<s-intman-vxworks.ads \
s-intman.adb<5zintman.adb \ s-intman.adb<s-intman-vxworks.adb \
s-osinte.adb<5zosinte.adb \ s-osinte.adb<s-osinte-vxworks.adb \
s-osinte.ads<5zosinte.ads \ s-osinte.ads<s-osinte-vxworks.ads \
s-osprim.adb<5zosprim.adb \ s-osprim.adb<s-osprim-vxworks.adb \
s-parame.ads<5zparame.ads \ s-parame.ads<s-parame-vxworks.ads \
s-stchop.adb<5zstchop.adb \ s-stchop.adb<s-stchop-vxworks.adb \
s-taprop.adb<5ztaprop.adb \ s-taprop.adb<s-taprop-vxworks.adb \
s-taspri.ads<5ztaspri.ads \ s-taspri.ads<s-taspri-vxworks.ads \
s-tpopsp.adb<5ztpopsp.adb \ s-tpopsp.adb<s-tpopsp-vxworks.adb \
s-vxwork.ads<5xvxwork.ads \ s-vxwork.ads<s-vxwork-xscale.ads \
g-soccon.ads<3zsoccon.ads \ g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<3zsocthi.ads \ g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<3zsocthi.adb \ g-socthi.adb<g-socthi-vxworks.adb \
system.ads<5rsystem.ads system.ads<system-elf-sparc.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5zml-tgt.adb TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
...@@ -621,29 +621,29 @@ endif ...@@ -621,29 +621,29 @@ endif
ifeq ($(strip $(filter-out mips% wrs vx%,$(targ))),) ifeq ($(strip $(filter-out mips% wrs vx%,$(targ))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-sytaco.ads<4zsytaco.ads \ a-sytaco.ads<a-sytaco-vxworks.ads \
a-sytaco.adb<4zsytaco.adb \ a-sytaco.adb<a-sytaco-vxworks.adb \
a-intnam.ads<4zintnam.ads \ a-intnam.ads<a-intnam-vxworks.ads \
a-numaux.ads<4znumaux.ads \ a-numaux.ads<a-numaux-vxworks.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-interr.adb<5zinterr.adb \ s-interr.adb<s-interr-vxworks.adb \
s-intman.ads<5zintman.ads \ s-intman.ads<s-intman-vxworks.ads \
s-intman.adb<5zintman.adb \ s-intman.adb<s-intman-vxworks.adb \
s-osinte.adb<5zosinte.adb \ s-osinte.adb<s-osinte-vxworks.adb \
s-osinte.ads<5zosinte.ads \ s-osinte.ads<s-osinte-vxworks.ads \
s-osprim.adb<5zosprim.adb \ s-osprim.adb<s-osprim-vxworks.adb \
s-parame.ads<5zparame.ads \ s-parame.ads<s-parame-vxworks.ads \
s-stchop.adb<5zstchop.adb \ s-stchop.adb<s-stchop-vxworks.adb \
s-taprop.adb<5ztaprop.adb \ s-taprop.adb<s-taprop-vxworks.adb \
s-taspri.ads<5ztaspri.ads \ s-taspri.ads<s-taspri-vxworks.ads \
s-tpopsp.adb<5ztpopsp.adb \ s-tpopsp.adb<s-tpopsp-vxworks.adb \
s-vxwork.ads<5mvxwork.ads \ s-vxwork.ads<s-vxwork-mips.ads \
g-soccon.ads<3zsoccon.ads \ g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<3zsocthi.ads \ g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<3zsocthi.adb \ g-socthi.adb<g-socthi-vxworks.adb \
system.ads<5msystem.ads system.ads<system-vxworks-mips.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5zml-tgt.adb TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o
...@@ -651,23 +651,23 @@ endif ...@@ -651,23 +651,23 @@ endif
ifeq ($(strip $(filter-out sparc sun solaris%,$(targ))),) ifeq ($(strip $(filter-out sparc sun solaris%,$(targ))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4sintnam.ads \ a-intnam.ads<a-intnam-solaris.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<5sintman.adb \ s-intman.adb<s-intman-solaris.adb \
s-osinte.adb<5sosinte.adb \ s-osinte.adb<s-osinte-solaris.adb \
s-osinte.ads<5sosinte.ads \ s-osinte.ads<s-osinte-solaris.ads \
s-osprim.adb<5sosprim.adb \ s-osprim.adb<s-osprim-solaris.adb \
s-parame.adb<5sparame.adb \ s-parame.adb<s-parame-solaris.adb \
s-taprop.adb<5staprop.adb \ s-taprop.adb<s-taprop-solaris.adb \
s-tasinf.adb<5stasinf.adb \ s-tasinf.adb<s-tasinf-solaris.adb \
s-tasinf.ads<5stasinf.ads \ s-tasinf.ads<s-tasinf-solaris.ads \
s-taspri.ads<5staspri.ads \ s-taspri.ads<s-taspri-solaris.ads \
s-tpopsp.adb<5stpopsp.adb \ s-tpopsp.adb<s-tpopsp-solaris.adb \
g-soccon.ads<3ssoccon.ads \ g-soccon.ads<g-soccon-solaris.ads \
g-soliop.ads<3ssoliop.ads \ g-soliop.ads<g-soliop-solaris.ads \
system.ads<5ssystem.ads system.ads<system-solaris-sparc.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5sml-tgt.adb TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-solaris.adb
THREADSLIB = -lposix4 -lthread THREADSLIB = -lposix4 -lthread
MISCLIB = -lposix4 -lnsl -lsocket MISCLIB = -lposix4 -lnsl -lsocket
...@@ -680,80 +680,80 @@ ifeq ($(strip $(filter-out sparc sun solaris%,$(targ))),) ...@@ -680,80 +680,80 @@ ifeq ($(strip $(filter-out sparc sun solaris%,$(targ))),)
ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),) ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4sintnam.ads \ a-intnam.ads<a-intnam-solaris.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<5sintman.adb \ s-intman.adb<s-intman-solaris.adb \
s-osinte.adb<7sosinte.adb \ s-osinte.adb<s-osinte-fsu.adb \
s-osinte.ads<5tosinte.ads \ s-osinte.ads<s-osinte-solaris-fsu.ads \
s-osprim.adb<5sosprim.adb \ s-osprim.adb<s-osprim-solaris.adb \
s-taprop.adb<7staprop.adb \ s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<7staspri.ads \ s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<7stpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix.adb \
g-soccon.ads<3ssoccon.ads \ g-soccon.ads<g-soccon-solaris.ads \
g-soliop.ads<3ssoliop.ads \ g-soliop.ads<g-soliop-solaris.ads \
system.ads<5ssystem.ads system.ads<system-solaris-sparc.ads
THREADSLIB = -lgthreads -lmalloc THREADSLIB = -lgthreads -lmalloc
endif endif
ifeq ($(strip $(filter-out pthread PTHREAD,$(THREAD_KIND))),) ifeq ($(strip $(filter-out pthread PTHREAD,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4sintnam.ads \ a-intnam.ads<a-intnam-solaris.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-osinte.adb<5iosinte.adb \ s-osinte.adb<s-osinte-posix.adb \
s-osinte.ads<54osinte.ads \ s-osinte.ads<s-osinte-solaris-posix.ads \
s-osprim.adb<5sosprim.adb \ s-osprim.adb<s-osprim-solaris.adb \
s-taprop.adb<7staprop.adb \ s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<7staspri.ads \ s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<5atpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
g-soccon.ads<3ssoccon.ads \ g-soccon.ads<g-soccon-solaris.ads \
g-soliop.ads<3ssoliop.ads \ g-soliop.ads<g-soliop-solaris.ads \
system.ads<5ssystem.ads system.ads<system-solaris-sparc.ads
THREADSLIB = -lposix4 -lpthread THREADSLIB = -lposix4 -lpthread
endif endif
ifeq ($(strip $(filter-out m64,$(THREAD_KIND))),) ifeq ($(strip $(filter-out m64,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4sintnam.ads \ a-intnam.ads<a-intnam-solaris.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<5sintman.adb \ s-intman.adb<s-intman-solaris.adb \
s-osinte.adb<5sosinte.adb \ s-osinte.adb<s-osinte-solaris.adb \
s-osinte.ads<5sosinte.ads \ s-osinte.ads<s-osinte-solaris.ads \
s-osprim.adb<5sosprim.adb \ s-osprim.adb<s-osprim-solaris.adb \
s-parame.adb<5sparame.adb \ s-parame.adb<s-parame-solaris.adb \
s-taprop.adb<5staprop.adb \ s-taprop.adb<s-taprop-solaris.adb \
s-tasinf.adb<5stasinf.adb \ s-tasinf.adb<s-tasinf-solaris.adb \
s-tasinf.ads<5stasinf.ads \ s-tasinf.ads<s-tasinf-solaris.ads \
s-taspri.ads<5staspri.ads \ s-taspri.ads<s-taspri-solaris.ads \
s-tpopsp.adb<5stpopsp.adb \ s-tpopsp.adb<s-tpopsp-solaris.adb \
g-soccon.ads<3ssoccon.ads \ g-soccon.ads<g-soccon-solaris.ads \
g-soliop.ads<3ssoliop.ads \ g-soliop.ads<g-soliop-solaris.ads \
system.ads<5usystem.ads system.ads<system-solaris-sparcv9.ads
endif endif
endif endif
ifeq ($(strip $(filter-out %86 solaris2%,$(arch) $(osys))),) ifeq ($(strip $(filter-out %86 solaris2%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-numaux.adb<86numaux.adb \ a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<86numaux.ads \ a-numaux.ads<a-numaux-x86.ads \
a-intnam.ads<4sintnam.ads \ a-intnam.ads<a-intnam-solaris.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<5sintman.adb \ s-intman.adb<s-intman-solaris.adb \
s-mastop.adb<5omastop.adb \ s-mastop.adb<s-mastop-x86.adb \
s-osinte.adb<5sosinte.adb \ s-osinte.adb<s-osinte-solaris.adb \
s-osinte.ads<5sosinte.ads \ s-osinte.ads<s-osinte-solaris.ads \
s-osprim.adb<5sosprim.adb \ s-osprim.adb<s-osprim-solaris.adb \
s-parame.adb<5sparame.adb \ s-parame.adb<s-parame-solaris.adb \
s-taprop.adb<5staprop.adb \ s-taprop.adb<s-taprop-solaris.adb \
s-tasinf.adb<5stasinf.adb \ s-tasinf.adb<s-tasinf-solaris.adb \
s-tasinf.ads<5stasinf.ads \ s-tasinf.ads<s-tasinf-solaris.ads \
s-taspri.ads<5staspri.ads \ s-taspri.ads<s-taspri-solaris.ads \
s-tpopsp.adb<5stpopsp.adb \ s-tpopsp.adb<s-tpopsp-solaris.adb \
g-soccon.ads<3ssoccon.ads \ g-soccon.ads<g-soccon-solaris.ads \
g-soliop.ads<3ssoliop.ads \ g-soliop.ads<g-soliop-solaris.ads \
system.ads<5esystem.ads system.ads<system-solaris-x86.ads
THREADSLIB = -lposix4 -lthread THREADSLIB = -lposix4 -lthread
MISCLIB = -lposix4 -lnsl -lsocket MISCLIB = -lposix4 -lnsl -lsocket
...@@ -765,23 +765,23 @@ endif ...@@ -765,23 +765,23 @@ endif
ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4lintnam.ads \ a-intnam.ads<a-intnam-linux.ads \
a-numaux.adb<86numaux.adb \ a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<86numaux.ads \ a-numaux.ads<a-numaux-x86.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-mastop.adb<5omastop.adb \ s-mastop.adb<s-mastop-x86.adb \
s-osinte.adb<5iosinte.adb \ s-osinte.adb<s-osinte-posix.adb \
s-osinte.ads<5iosinte.ads \ s-osinte.ads<s-osinte-linux.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<5itaprop.adb \ s-taprop.adb<s-taprop-linux.adb \
s-taspri.ads<5itaspri.ads \ s-taspri.ads<s-taspri-linux.ads \
s-tpopsp.adb<5atpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
s-parame.adb<5lparame.adb \ s-parame.adb<s-parame-linux.adb \
system.ads<5lsystem.ads system.ads<system-linux-x86.ads
TOOLS_TARGET_PAIRS = \ TOOLS_TARGET_PAIRS = \
mlib-tgt.adb<5lml-tgt.adb mlib-tgt.adb<mlib-tgt-linux.adb
SYMLIB = $(ADDR2LINE_SYMLIB) SYMLIB = $(ADDR2LINE_SYMLIB)
THREADSLIB = -lpthread THREADSLIB = -lpthread
...@@ -792,19 +792,19 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) ...@@ -792,19 +792,19 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),) ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4lintnam.ads \ a-intnam.ads<a-intnam-linux.ads \
a-numaux.adb<86numaux.adb \ a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<86numaux.ads \ a-numaux.ads<a-numaux-x86.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-mastop.adb<5omastop.adb \ s-mastop.adb<s-mastop-x86.adb \
s-osinte.adb<7sosinte.adb \ s-osinte.adb<s-osinte-fsu.adb \
s-osinte.ads<5losinte.ads \ s-osinte.ads<s-osinte-linux-fsu.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<7staprop.adb \ s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<7staspri.ads \ s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<7stpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix.adb \
system.ads<5lsystem.ads system.ads<system-linux-x86.ads
THREADSLIB = -lgthreads -lmalloc THREADSLIB = -lgthreads -lmalloc
endif endif
...@@ -812,23 +812,23 @@ endif ...@@ -812,23 +812,23 @@ endif
ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),) ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<45intnam.ads \ a-intnam.ads<a-intnam-freebsd.ads \
a-numaux.adb<86numaux.adb \ a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<86numaux.ads \ a-numaux.ads<a-numaux-x86.ads \
g-soccon.ads<35soccon.ads \ g-soccon.ads<g-soccon-freebsd.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-mastop.adb<5omastop.adb \ s-mastop.adb<s-mastop-x86.adb \
s-osinte.adb<55osinte.adb \ s-osinte.adb<s-osinte-freebsd.adb \
s-osinte.ads<55osinte.ads \ s-osinte.ads<s-osinte-freebsd.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<7staprop.adb \ s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<7staspri.ads \ s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<7stpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix.adb \
system.ads<56system.ads system.ads<system-freebsd-x86.ads
TOOLS_TARGET_PAIRS = \ TOOLS_TARGET_PAIRS = \
mlib-tgt.adb<5lml-tgt.adb mlib-tgt.adb<mlib-tgt-linux.adb
GNATLIB_SHARED = gnatlib-shared-dual GNATLIB_SHARED = gnatlib-shared-dual
SYMLIB = $(ADDR2LINE_SYMLIB) SYMLIB = $(ADDR2LINE_SYMLIB)
...@@ -841,34 +841,34 @@ endif ...@@ -841,34 +841,34 @@ endif
ifeq ($(strip $(filter-out s390% linux%,$(arch) $(osys))),) ifeq ($(strip $(filter-out s390% linux%,$(arch) $(osys))),)
ifeq ($(strip $(filter-out s390x,$(arch))),) ifeq ($(strip $(filter-out s390x,$(arch))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4lintnam.ads \ a-intnam.ads<a-intnam-linux.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-osinte.adb<5iosinte.adb \ s-osinte.adb<s-osinte-posix.adb \
s-osinte.ads<5iosinte.ads \ s-osinte.ads<s-osinte-linux.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<5itaprop.adb \ s-taprop.adb<s-taprop-linux.adb \
s-taspri.ads<5itaspri.ads \ s-taspri.ads<s-taspri-linux.ads \
s-tpopsp.adb<5atpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
s-parame.adb<5lparame.adb \ s-parame.adb<s-parame-linux.adb \
system.ads<system-linux-s390x.ads system.ads<system-linux-s390x.ads
else else
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4lintnam.ads \ a-intnam.ads<a-intnam-linux.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-osinte.adb<5iosinte.adb \ s-osinte.adb<s-osinte-posix.adb \
s-osinte.ads<5iosinte.ads \ s-osinte.ads<s-osinte-linux.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<5itaprop.adb \ s-taprop.adb<s-taprop-linux.adb \
s-taspri.ads<5itaspri.ads \ s-taspri.ads<s-taspri-linux.ads \
s-tpopsp.adb<5atpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
s-parame.adb<5lparame.adb \ s-parame.adb<s-parame-linux.adb \
system.ads<system-linux-s390.ads system.ads<system-linux-s390.ads
endif endif
TOOLS_TARGET_PAIRS = \ TOOLS_TARGET_PAIRS = \
mlib-tgt.adb<5lml-tgt.adb mlib-tgt.adb<mlib-tgt-linux.adb
THREADSLIB = -lpthread THREADSLIB = -lpthread
GNATLIB_SHARED = gnatlib-shared-dual GNATLIB_SHARED = gnatlib-shared-dual
...@@ -879,48 +879,48 @@ endif ...@@ -879,48 +879,48 @@ endif
ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),) ifeq ($(strip $(filter-out mips sgi irix%,$(targ))),)
ifeq ($(strip $(filter-out mips sgi irix6%,$(targ))),) ifeq ($(strip $(filter-out mips sgi irix6%,$(targ))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4gintnam.ads \ a-intnam.ads<a-intnam-irix.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<5fintman.adb \ s-intman.adb<s-intman-irix.adb \
s-mastop.adb<5gmastop.adb \ s-mastop.adb<s-mastop-irix.adb \
s-osinte.adb<5fosinte.adb \ s-osinte.adb<s-osinte-irix.adb \
s-osinte.ads<5fosinte.ads \ s-osinte.ads<s-osinte-irix.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-proinf.adb<5gproinf.adb \ s-proinf.adb<s-proinf-irix-athread.adb \
s-proinf.ads<5gproinf.ads \ s-proinf.ads<s-proinf-irix-athread.ads \
s-taprop.adb<5ftaprop.adb \ s-taprop.adb<s-taprop-irix.adb \
s-tasinf.ads<5ftasinf.ads \ s-tasinf.ads<s-tasinf-irix.ads \
s-taspri.ads<7staspri.ads \ s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<7stpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix.adb \
s-traceb.adb<7straceb.adb \ s-traceb.adb<s-traceb-mastop.adb \
g-soccon.ads<3gsoccon.ads \ g-soccon.ads<g-soccon-irix.ads \
system.ads<5gsystem.ads system.ads<system-irix-n32.ads
THREADSLIB = -lpthread THREADSLIB = -lpthread
GNATLIB_SHARED = gnatlib-shared-default GNATLIB_SHARED = gnatlib-shared-default
else else
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4gintnam.ads \ a-intnam.ads<a-intnam-irix.ads \
s-inmaop.adb<5ninmaop.adb \ s-inmaop.adb<s-inmaop-dummy.adb \
s-interr.adb<5ginterr.adb \ s-interr.adb<s-interr-sigaction.adb \
s-intman.adb<5gintman.adb \ s-intman.adb<s-intman-irix-athread.adb \
s-mastop.adb<5gmastop.adb \ s-mastop.adb<s-mastop-irix.adb \
s-osinte.adb<5fosinte.adb \ s-osinte.adb<s-osinte-irix.adb \
s-osinte.ads<5gosinte.ads \ s-osinte.ads<s-osinte-irix-athread.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-proinf.adb<5gproinf.adb \ s-proinf.adb<s-proinf-irix-athread.adb \
s-proinf.ads<5gproinf.ads \ s-proinf.ads<s-proinf-irix-athread.ads \
s-taprop.adb<5gtaprop.adb \ s-taprop.adb<s-taprop-irix-athread.adb \
s-tasinf.adb<5gtasinf.adb \ s-tasinf.adb<s-tasinf-irix-athread.adb \
s-tasinf.ads<5gtasinf.ads \ s-tasinf.ads<s-tasinf-irix-athread.ads \
s-taspri.ads<7staspri.ads \ s-taspri.ads<s-taspri-posix.ads \
s-traceb.adb<7straceb.adb \ s-traceb.adb<s-traceb-mastop.adb \
g-soccon.ads<3gsoccon.ads \ g-soccon.ads<g-soccon-irix.ads \
system.ads<5fsystem.ads system.ads<system-irix-o32.ads
endif endif
TOOLS_TARGET_PAIRS = mlib-tgt.adb<5gml-tgt.adb TOOLS_TARGET_PAIRS = mlib-tgt.adb<mlib-tgt-irix.adb
TGT_LIB = -lexc TGT_LIB = -lexc
MISCLIB = -lexc MISCLIB = -lexc
SO_OPTS = -Wl,-all,-set_version,sgi1.0,-update_registry,../so_locations,-soname, SO_OPTS = -Wl,-all,-set_version,sgi1.0,-update_registry,../so_locations,-soname,
...@@ -930,41 +930,41 @@ endif ...@@ -930,41 +930,41 @@ endif
ifeq ($(strip $(filter-out hppa% hp hpux10%,$(targ))),) ifeq ($(strip $(filter-out hppa% hp hpux10%,$(targ))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-excpol.adb<4wexcpol.adb \ a-excpol.adb<a-excpol-abort.adb \
a-intnam.ads<4hintnam.ads \ a-intnam.ads<a-intnam-hpux.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-interr.adb<5ginterr.adb \ s-interr.adb<s-interr-sigaction.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-osinte.adb<5hosinte.adb \ s-osinte.adb<s-osinte-hpux-dce.adb \
s-osinte.ads<5hosinte.ads \ s-osinte.ads<s-osinte-hpux-dce.ads \
s-parame.ads<5hparame.ads \ s-parame.ads<s-parame-hpux.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<5htaprop.adb \ s-taprop.adb<s-taprop-hpux-dce.adb \
s-taspri.ads<5htaspri.ads \ s-taspri.ads<s-taspri-hpux-dce.ads \
s-tpopsp.adb<7stpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix.adb \
g-soccon.ads<3hsoccon.ads \ g-soccon.ads<g-soccon-hpux.ads \
system.ads<5hsystem.ads system.ads<system-hpux.ads
PREFIX_OBJS = $(PREFIX_REAL_OBJS) PREFIX_OBJS = $(PREFIX_REAL_OBJS)
endif endif
ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),) ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4hintnam.ads \ a-intnam.ads<a-intnam-hpux.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-osinte.adb<5iosinte.adb \ s-osinte.adb<s-osinte-posix.adb \
s-osinte.ads<53osinte.ads \ s-osinte.ads<s-osinte-hpux.ads \
s-parame.ads<5hparame.ads \ s-parame.ads<s-parame-hpux.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-traceb.adb<5htraceb.adb \ s-traceb.adb<s-traceb-hpux.adb \
s-taprop.adb<7staprop.adb \ s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<7staspri.ads \ s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<5atpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
g-soccon.ads<3hsoccon.ads \ g-soccon.ads<g-soccon-hpux.ads \
system.ads<5hsystem.ads system.ads<system-hpux.ads
TOOLS_TARGET_PAIRS = mlib-tgt.adb<5hml-tgt.adb TOOLS_TARGET_PAIRS = mlib-tgt.adb<mlib-tgt-hpux.adb
TGT_LIB = /usr/lib/libcl.a TGT_LIB = /usr/lib/libcl.a
THREADSLIB = -lpthread THREADSLIB = -lpthread
SYMLIB = $(ADDR2LINE_SYMLIB) SYMLIB = $(ADDR2LINE_SYMLIB)
...@@ -977,20 +977,20 @@ ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),) ...@@ -977,20 +977,20 @@ ifeq ($(strip $(filter-out hppa% hp hpux11%,$(targ))),)
ifeq ($(strip $(filter-out dce DCE,$(THREAD_KIND))),) ifeq ($(strip $(filter-out dce DCE,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-excpol.adb<4wexcpol.adb \ a-excpol.adb<a-excpol-abort.adb \
a-intnam.ads<4hintnam.ads \ a-intnam.ads<a-intnam-hpux.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-interr.adb<5ginterr.adb \ s-interr.adb<s-interr-sigaction.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-osinte.adb<5hosinte.adb \ s-osinte.adb<s-osinte-hpux-dce.adb \
s-osinte.ads<5hosinte.ads \ s-osinte.ads<s-osinte-hpux-dce.ads \
s-parame.ads<5hparame.ads \ s-parame.ads<s-parame-hpux.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<5htaprop.adb \ s-taprop.adb<s-taprop-hpux-dce.adb \
s-taspri.ads<5htaspri.ads \ s-taspri.ads<s-taspri-hpux-dce.ads \
s-tpopsp.adb<7stpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix.adb \
g-soccon.ads<3hsoccon.ads \ g-soccon.ads<g-soccon-hpux.ads \
system.ads<5hsystem.ads system.ads<system-hpux.ads
TGT_LIB = TGT_LIB =
THREADSLIB = -lcma THREADSLIB = -lcma
...@@ -999,39 +999,39 @@ endif ...@@ -999,39 +999,39 @@ endif
ifeq ($(strip $(filter-out ibm aix%,$(manu) $(osys))),) ifeq ($(strip $(filter-out ibm aix%,$(manu) $(osys))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4cintnam.ads \ a-intnam.ads<a-intnam-aix.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-osinte.adb<5bosinte.adb \ s-osinte.adb<s-osinte-aix.adb \
s-osinte.ads<5bosinte.ads \ s-osinte.ads<s-osinte-aix.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<7staprop.adb \ s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<7staspri.ads \ s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<7stpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix.adb \
g-soccon.ads<3bsoccon.ads \ g-soccon.ads<g-soccon-aix.ads \
system.ads<5bsystem.ads system.ads<system-aix.ads
THREADSLIB = -lpthreads THREADSLIB = -lpthreads
PREFIX_OBJS=$(PREFIX_REAL_OBJS) PREFIX_OBJS=$(PREFIX_REAL_OBJS)
ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),) ifeq ($(strip $(filter-out fsu FSU,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4cintnam.ads \ a-intnam.ads<a-intnam-aix.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-osinte.adb<7sosinte.adb \ s-osinte.adb<s-osinte-fsu.adb \
s-osinte.ads<5cosinte.ads \ s-osinte.ads<s-osinte-aix-fsu.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<7staprop.adb \ s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<7staspri.ads \ s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<7stpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix.adb \
g-soccon.ads<3bsoccon.ads \ g-soccon.ads<g-soccon-aix.ads \
system.ads<5bsystem.ads system.ads<system-aix.ads
THREADSLIB = -lgthreads -lmalloc THREADSLIB = -lgthreads -lmalloc
endif endif
TOOLS_TARGET_PAIRS = mlib-tgt.adb<5bml-tgt.adb TOOLS_TARGET_PAIRS = mlib-tgt.adb<mlib-tgt-aix.adb
GMEM_LIB = gmemlib GMEM_LIB = gmemlib
SYMLIB = $(ADDR2LINE_SYMLIB) SYMLIB = $(ADDR2LINE_SYMLIB)
...@@ -1040,47 +1040,47 @@ endif ...@@ -1040,47 +1040,47 @@ endif
ifeq ($(strip $(filter-out lynxos,$(osys))),) ifeq ($(strip $(filter-out lynxos,$(osys))),)
ifeq ($(strip $(filter-out %86 lynxos,$(arch) $(osys))),) ifeq ($(strip $(filter-out %86 lynxos,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-numaux.adb<86numaux.adb \ a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<86numaux.ads \ a-numaux.ads<a-numaux-x86.ads \
a-intnam.ads<42intnam.ads \ a-intnam.ads<a-intnam-lynxos.ads \
s-mastop.adb<5omastop.adb \ s-mastop.adb<s-mastop-x86.adb \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-osinte.adb<56osinte.adb \ s-osinte.adb<s-osinte-lynxos.adb \
s-osinte.ads<56osinte.ads \ s-osinte.ads<s-osinte-lynxos.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<56taprop.adb \ s-taprop.adb<s-taprop-lynxos.adb \
s-taspri.ads<56taspri.ads \ s-taspri.ads<s-taspri-lynxos.ads \
s-tpopsp.adb<56tpopsp.adb \ s-tpopsp.adb<s-tpopsp-lynxos.adb \
system.ads<58system.ads system.ads<system-lynxos-x86.ads
PREFIX_OBJS=$(PREFIX_REAL_OBJS) PREFIX_OBJS=$(PREFIX_REAL_OBJS)
else else
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<42intnam.ads \ a-intnam.ads<a-intnam-lynxos.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-osinte.adb<52osinte.adb \ s-osinte.adb<s-osinte-lynxos-3.adb \
s-osinte.ads<52osinte.ads \ s-osinte.ads<s-osinte-lynxos-3.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<7staprop.adb \ s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<7staspri.ads \ s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<7stpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix.adb \
system.ads<57system.ads system.ads<system-lynxos-ppc.ads
ifeq ($(strip $(filter-out pthread PTHREAD,$(THREAD_KIND))),) ifeq ($(strip $(filter-out pthread PTHREAD,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<42intnam.ads \ a-intnam.ads<a-intnam-lynxos.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-osinte.adb<56osinte.adb \ s-osinte.adb<s-osinte-lynxos.adb \
s-osinte.ads<56osinte.ads \ s-osinte.ads<s-osinte-lynxos.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<56taprop.adb \ s-taprop.adb<s-taprop-lynxos.adb \
s-taspri.ads<56taspri.ads \ s-taspri.ads<s-taspri-lynxos.ads \
s-tpopsp.adb<56tpopsp.adb \ s-tpopsp.adb<s-tpopsp-lynxos.adb \
system.ads<57system.ads system.ads<system-lynxos-ppc.ads
endif endif
endif endif
...@@ -1089,35 +1089,35 @@ endif ...@@ -1089,35 +1089,35 @@ endif
ifeq ($(strip $(filter-out rtems%,$(osys))),) ifeq ($(strip $(filter-out rtems%,$(osys))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4rintnam.ads \ a-intnam.ads<4rintnam.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-osinte.adb<5rosinte.adb \ s-osinte.adb<5rosinte.adb \
s-osinte.ads<5rosinte.ads \ s-osinte.ads<5rosinte.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-parame.adb<5rparame.adb \ s-parame.adb<5rparame.adb \
s-taprop.adb<7staprop.adb \ s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<7staspri.ads \ s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<5rtpopsp.adb s-tpopsp.adb<5rtpopsp.adb
endif endif
ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),) ifeq ($(strip $(filter-out alpha% dec osf%,$(targ))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4aintnam.ads \ a-intnam.ads<a-intnam-tru64.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-mastop.adb<5amastop.adb \ s-mastop.adb<s-mastop-tru64.adb \
s-osinte.adb<5aosinte.adb \ s-osinte.adb<s-osinte-tru64.adb \
s-osinte.ads<5aosinte.ads \ s-osinte.ads<s-osinte-tru64.ads \
s-osprim.adb<5posprim.adb \ s-osprim.adb<s-osprim-unix.adb \
s-taprop.adb<5ataprop.adb \ s-taprop.adb<s-taprop-tru64.adb \
s-tasinf.ads<5atasinf.ads \ s-tasinf.ads<s-tasinf-tru64.ads \
s-taspri.ads<5ataspri.ads \ s-taspri.ads<s-taspri-tru64.ads \
s-tpopsp.adb<5atpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
s-traceb.adb<7straceb.adb \ s-traceb.adb<s-traceb-mastop.adb \
g-soccon.ads<3asoccon.ads \ g-soccon.ads<g-soccon-tru64.ads \
system.ads<5asystem.ads system.ads<system-tru64.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5aml-tgt.adb TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-tru64.adb
GMEM_LIB=gmemlib GMEM_LIB=gmemlib
SYMLIB = $(ADDR2LINE_SYMLIB) SYMLIB = $(ADDR2LINE_SYMLIB)
...@@ -1146,62 +1146,62 @@ ifeq ($(strip $(filter-out alpha% ia64 dec hp vms% openvms% alphavms%,$(targ))), ...@@ -1146,62 +1146,62 @@ ifeq ($(strip $(filter-out alpha% ia64 dec hp vms% openvms% alphavms%,$(targ))),
ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),) ifeq ($(strip $(filter-out ia64 hp vms% openvms%,$(targ))),)
LIBGNAT_TARGET_PAIRS_AUX1 = \ LIBGNAT_TARGET_PAIRS_AUX1 = \
s-auxdec.ads<5qauxdec.ads \ s-auxdec.ads<5qauxdec.ads \
s-crtl.ads<5xcrtl.ads \ s-crtl.ads<s-crtl-vms.ads \
s-osinte.adb<5xosinte.adb \ s-osinte.adb<s-osinte-vms-ia64.adb \
s-osinte.ads<5xosinte.ads \ s-osinte.ads<s-osinte-vms-ia64.ads \
system.ads<5qsystem.ads system.ads<5qsystem.ads
else else
ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),) ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),)
LIBGNAT_TARGET_PAIRS_AUX1 = \ LIBGNAT_TARGET_PAIRS_AUX1 = \
s-crtl.ads<5vcrtl.ads \ s-crtl.ads<s-crtl-vms.ads \
s-osinte.adb<5vosinte.adb \ s-osinte.adb<s-osinte-vms.adb \
s-osinte.ads<5vosinte.ads \ s-osinte.ads<s-osinte-vms.ads \
system.ads<5xsystem.ads system.ads<system-vms-zcx.ads
endif endif
endif endif
ifeq ($(strip $(filter-out express EXPRESS,$(THREAD_KIND))),) ifeq ($(strip $(filter-out express EXPRESS,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS_AUX2 = \ LIBGNAT_TARGET_PAIRS_AUX2 = \
s-parame.ads<5xparame.ads s-parame.ads<s-parame-vms-restrict.ads
else else
LIBGNAT_TARGET_PAIRS_AUX2 = \ LIBGNAT_TARGET_PAIRS_AUX2 = \
s-parame.ads<5vparame.ads s-parame.ads<s-parame-vms.ads
endif endif
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-caldel.adb<4vcaldel.adb \ a-caldel.adb<a-caldel-vms.adb \
a-calend.adb<4vcalend.adb \ a-calend.adb<a-calend-vms.adb \
a-calend.ads<4vcalend.ads \ a-calend.ads<a-calend-vms.ads \
a-dirval.adb<5vdirval.adb \ a-dirval.adb<a-dirval-vms.adb \
a-excpol.adb<4wexcpol.adb \ a-excpol.adb<a-excpol-abort.adb \
a-intnam.ads<4vintnam.ads \ a-intnam.ads<a-intnam-vms.ads \
a-numaux.ads<4vnumaux.ads \ a-numaux.ads<a-numaux-vms.ads \
g-expect.adb<3vexpect.adb \ g-expect.adb<g-expect-vms.adb \
g-soccon.ads<3vsoccon.ads \ g-soccon.ads<g-soccon-vms.adb \
g-socthi.ads<3vsocthi.ads \ g-socthi.ads<g-socthi-vms.ads \
g-socthi.adb<3vsocthi.adb \ g-socthi.adb<g-socthi-vms.adb \
g-trasym.adb<3vtrasym.adb \ g-trasym.adb<g-trasym-vms.adb \
i-cstrea.adb<6vcstrea.adb \ i-cstrea.adb<i-cstrea-vms.adb \
i-cpp.adb<6vcpp.adb \ i-cpp.adb<i-cpp-vms.adb \
interfac.ads<6vinterf.ads \ interfac.ads<interfac-vms.ads \
s-asthan.adb<5vasthan.adb \ s-asthan.adb<s-asthan-vms.adb \
s-inmaop.adb<5vinmaop.adb \ s-inmaop.adb<s-inmaop-vms.adb \
s-interr.adb<5vinterr.adb \ s-interr.adb<s-interr-vms.adb \
s-intman.adb<5vintman.adb \ s-intman.adb<s-intman-vms.adb \
s-intman.ads<5vintman.ads \ s-intman.ads<s-intman-vms.ads \
s-osprim.adb<5vosprim.adb \ s-osprim.adb<s-osprim-vms.adb \
s-osprim.ads<5vosprim.ads \ s-osprim.ads<s-osprim-vms.ads \
s-taprop.adb<5vtaprop.adb \ s-taprop.adb<s-taprop-vms.adb \
s-taspri.ads<5vtaspri.ads \ s-taspri.ads<s-taspri-vms.ads \
s-tpopsp.adb<7stpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix.adb \
s-tpopde.adb<5vtpopde.adb \ s-tpopde.adb<s-tpopde-vms.adb \
s-tpopde.ads<5vtpopde.ads \ s-tpopde.ads<s-tpopde-vms.ads \
s-traent.adb<5vtraent.adb \ s-traent.adb<s-traent-vms.adb \
s-traent.ads<5vtraent.ads \ s-traent.ads<s-traent-vms.ads \
s-vaflop.adb<5vvaflop.adb \ s-vaflop.adb<s-vaflop-vms.adb \
$(LIBGNAT_TARGET_PAIRS_AUX1) \ $(LIBGNAT_TARGET_PAIRS_AUX1) \
$(LIBGNAT_TARGET_PAIRS_AUX2) $(LIBGNAT_TARGET_PAIRS_AUX2)
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5vml-tgt.adb TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vms.adb
GNATLIB_SHARED=gnatlib-shared-vms GNATLIB_SHARED=gnatlib-shared-vms
ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),) ifeq ($(strip $(filter-out alpha% dec vms% openvms% alphavms%,$(targ))),)
...@@ -1220,29 +1220,29 @@ endif ...@@ -1220,29 +1220,29 @@ endif
ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-calend.adb<4wcalend.adb \ a-calend.adb<a-calend-mingw.adb \
a-dirval.adb<5wdirval.adb \ a-dirval.adb<a-dirval-mingw.adb \
a-excpol.adb<4wexcpol.adb \ a-excpol.adb<a-excpol-abort.adb \
a-intnam.ads<4wintnam.ads \ a-intnam.ads<a-intnam-mingw.ads \
a-numaux.adb<86numaux.adb \ a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<86numaux.ads \ a-numaux.ads<a-numaux-x86.ads \
s-gloloc.adb<5wgloloc.adb \ s-gloloc.adb<s-gloloc-mingw.adb \
s-inmaop.adb<5ninmaop.adb \ s-inmaop.adb<s-inmaop-dummy.adb \
s-interr.adb<5ginterr.adb \ s-interr.adb<s-interr-sigaction.adb \
s-intman.adb<5wintman.adb \ s-intman.adb<s-intman-mingw.adb \
s-mastop.adb<5omastop.adb \ s-mastop.adb<s-mastop-x86.adb \
s-memory.adb<5wmemory.adb \ s-memory.adb<s-memory-mingw.adb \
s-osinte.ads<5wosinte.ads \ s-osinte.ads<s-osinte-mingw.ads \
s-osprim.adb<5wosprim.adb \ s-osprim.adb<s-osprim-mingw.adb \
s-taprop.adb<5wtaprop.adb \ s-taprop.adb<s-taprop-mingw.adb \
s-taspri.ads<5wtaspri.ads \ s-taspri.ads<s-taspri-mingw.ads \
g-socthi.ads<3wsocthi.ads \ g-socthi.ads<g-socthi-mingw.ads \
g-socthi.adb<3wsocthi.adb \ g-socthi.adb<g-socthi-mingw.adb \
g-soccon.ads<3wsoccon.ads \ g-soccon.ads<g-soccon-mingw.ads \
g-soliop.ads<3wsoliop.ads \ g-soliop.ads<g-soliop-mingw.ads \
system.ads<5wsystem.ads system.ads<system-mingw.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5wml-tgt.adb TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-mingw.adb
MISCLIB = -lwsock32 MISCLIB = -lwsock32
SYMLIB = $(ADDR2LINE_SYMLIB) SYMLIB = $(ADDR2LINE_SYMLIB)
GMEM_LIB = gmemlib GMEM_LIB = gmemlib
...@@ -1259,18 +1259,18 @@ endif ...@@ -1259,18 +1259,18 @@ endif
ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),) ifeq ($(strip $(filter-out %ia64 linux%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4lintnam.ads \ a-intnam.ads<a-intnam-linux.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-osinte.ads<5iosinte.ads \ s-osinte.ads<s-osinte-linux.ads \
s-osinte.adb<5iosinte.adb \ s-osinte.adb<s-osinte-posix.adb \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<5itaprop.adb \ s-taprop.adb<s-taprop-linux.adb \
s-tpopsp.adb<5atpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
s-taspri.ads<5itaspri.ads \ s-taspri.ads<s-taspri-linux.ads \
system.ads<55system.ads system.ads<s-osinte-linux-ia64.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5lml-tgt.adb TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-linux.adb
MISCLIB= MISCLIB=
THREADSLIB=-lpthread THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual GNATLIB_SHARED=gnatlib-shared-dual
...@@ -1280,20 +1280,20 @@ endif ...@@ -1280,20 +1280,20 @@ endif
ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),) ifeq ($(strip $(filter-out %x86_64 linux%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<4lintnam.ads \ a-intnam.ads<a-intnam-linux.ads \
a-numaux.adb<86numaux.adb \ a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<86numaux.ads \ a-numaux.ads<a-numaux-x86.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-osinte.ads<5iosinte.ads \ s-osinte.ads<s-osinte-linux.ads \
s-osinte.adb<5iosinte.adb \ s-osinte.adb<s-osinte-posix.adb \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<5itaprop.adb \ s-taprop.adb<s-taprop-linux.adb \
s-tpopsp.adb<5atpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
s-taspri.ads<5itaspri.ads \ s-taspri.ads<s-taspri-linux.ads \
system.ads<5nsystem.ads system.ads<system-linux-x86_64.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<5lml-tgt.adb TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-linux.adb
SYMLIB = $(ADDR2LINE_SYMLIB) SYMLIB = $(ADDR2LINE_SYMLIB)
THREADSLIB=-lpthread THREADSLIB=-lpthread
GNATLIB_SHARED=gnatlib-shared-dual GNATLIB_SHARED=gnatlib-shared-dual
...@@ -1305,15 +1305,15 @@ endif ...@@ -1305,15 +1305,15 @@ endif
ifeq ($(strip $(filter-out powerpc darwin%,$(arch) $(osys))),) ifeq ($(strip $(filter-out powerpc darwin%,$(arch) $(osys))),)
LIBGNAT_TARGET_PAIRS = \ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<a-intnam-darwin.ads \ a-intnam.ads<a-intnam-darwin.ads \
s-inmaop.adb<7sinmaop.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<7sintman.adb \ s-intman.adb<s-intman-posix.adb \
s-osinte.adb<s-osinte-darwin.adb \ s-osinte.adb<s-osinte-darwin.adb \
s-osinte.ads<s-osinte-darwin.ads \ s-osinte.ads<s-osinte-darwin.ads \
s-osprim.adb<7sosprim.adb \ s-osprim.adb<s-osprim-posix.adb \
s-taprop.adb<7staprop.adb \ s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<7staspri.ads \ s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<5atpopsp.adb \ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
g-soccon.ads<3bsoccon.ads \ g-soccon.ads<g-soccon-aix.ads \
system.ads<system-darwin-ppc.ads system.ads<system-darwin-ppc.ads
endif endif
......
gcc/ada/a-numaux-x86.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . A U X --
-- --
-- B o d y --
-- (Machine Version for x86) --
-- --
-- Copyright (C) 1998-2001 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- File a-numaux.adb <- 86numaux.adb
-- This version of Numerics.Aux is for the IEEE Double Extended floating
-- point format on x86.
with System.Machine_Code; use System.Machine_Code;
package body Ada.Numerics.Aux is
NL : constant String := ASCII.LF & ASCII.HT;
type FPU_Stack_Pointer is range 0 .. 7;
for FPU_Stack_Pointer'Size use 3;
type FPU_Status_Word is record
B : Boolean; -- FPU Busy (for 8087 compatibility only)
ES : Boolean; -- Error Summary Status
SF : Boolean; -- Stack Fault
Top : FPU_Stack_Pointer;
-- Condition Code Flags
-- C2 is set by FPREM and FPREM1 to indicate incomplete reduction.
-- In case of successfull recorction, C0, C3 and C1 are set to the
-- three least significant bits of the result (resp. Q2, Q1 and Q0).
-- C2 is used by FPTAN, FSIN, FCOS, and FSINCOS to indicate that
-- that source operand is beyond the allowable range of
-- -2.0**63 .. 2.0**63.
C3 : Boolean;
C2 : Boolean;
C1 : Boolean;
C0 : Boolean;
-- Exception Flags
PE : Boolean; -- Precision
UE : Boolean; -- Underflow
OE : Boolean; -- Overflow
ZE : Boolean; -- Zero Divide
DE : Boolean; -- Denormalized Operand
IE : Boolean; -- Invalid Operation
end record;
for FPU_Status_Word use record
B at 0 range 15 .. 15;
C3 at 0 range 14 .. 14;
Top at 0 range 11 .. 13;
C2 at 0 range 10 .. 10;
C1 at 0 range 9 .. 9;
C0 at 0 range 8 .. 8;
ES at 0 range 7 .. 7;
SF at 0 range 6 .. 6;
PE at 0 range 5 .. 5;
UE at 0 range 4 .. 4;
OE at 0 range 3 .. 3;
ZE at 0 range 2 .. 2;
DE at 0 range 1 .. 1;
IE at 0 range 0 .. 0;
end record;
for FPU_Status_Word'Size use 16;
-----------------------
-- Local subprograms --
-----------------------
function Is_Nan (X : Double) return Boolean;
-- Return True iff X is a IEEE NaN value
function Logarithmic_Pow (X, Y : Double) return Double;
-- Implementation of X**Y using Exp and Log functions (binary base)
-- to calculate the exponentiation. This is used by Pow for values
-- for values of Y in the open interval (-0.25, 0.25)
function Reduce (X : Double) return Double;
-- Implement partial reduction of X by Pi in the x86.
-- Note that for the Sin, Cos and Tan functions completely accurate
-- reduction of the argument is done for arguments in the range of
-- -2.0**63 .. 2.0**63, using a 66-bit approximation of Pi.
pragma Inline (Is_Nan);
pragma Inline (Reduce);
---------------------------------
-- Basic Elementary Functions --
---------------------------------
-- This section implements a few elementary functions that are
-- used to build the more complex ones. This ordering enables
-- better inlining.
----------
-- Atan --
----------
function Atan (X : Double) return Double is
Result : Double;
begin
Asm (Template =>
"fld1" & NL
& "fpatan",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", X));
-- The result value is NaN iff input was invalid
if not (Result = Result) then
raise Argument_Error;
end if;
return Result;
end Atan;
---------
-- Exp --
---------
function Exp (X : Double) return Double is
Result : Double;
begin
Asm (Template =>
"fldl2e " & NL
& "fmulp %%st, %%st(1)" & NL -- X * log2 (E)
& "fld %%st(0) " & NL
& "frndint " & NL -- Integer (X * Log2 (E))
& "fsubr %%st, %%st(1)" & NL -- Fraction (X * Log2 (E))
& "fxch " & NL
& "f2xm1 " & NL -- 2**(...) - 1
& "fld1 " & NL
& "faddp %%st, %%st(1)" & NL -- 2**(Fraction (X * Log2 (E)))
& "fscale " & NL -- E ** X
& "fstp %%st(1) ",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", X));
return Result;
end Exp;
------------
-- Is_Nan --
------------
function Is_Nan (X : Double) return Boolean is
begin
-- The IEEE NaN values are the only ones that do not equal themselves
return not (X = X);
end Is_Nan;
---------
-- Log --
---------
function Log (X : Double) return Double is
Result : Double;
begin
Asm (Template =>
"fldln2 " & NL
& "fxch " & NL
& "fyl2x " & NL,
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", X));
return Result;
end Log;
------------
-- Reduce --
------------
function Reduce (X : Double) return Double is
Result : Double;
begin
Asm
(Template =>
-- Partial argument reduction
"fldpi " & NL
& "fadd %%st(0), %%st" & NL
& "fxch %%st(1) " & NL
& "fprem1 " & NL
& "fstp %%st(1) ",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", X));
return Result;
end Reduce;
----------
-- Sqrt --
----------
function Sqrt (X : Double) return Double is
Result : Double;
begin
if X < 0.0 then
raise Argument_Error;
end if;
Asm (Template => "fsqrt",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", X));
return Result;
end Sqrt;
---------------------------------
-- Other Elementary Functions --
---------------------------------
-- These are built using the previously implemented basic functions
----------
-- Acos --
----------
function Acos (X : Double) return Double is
Result : Double;
begin
Result := 2.0 * Atan (Sqrt ((1.0 - X) / (1.0 + X)));
-- The result value is NaN iff input was invalid
if Is_Nan (Result) then
raise Argument_Error;
end if;
return Result;
end Acos;
----------
-- Asin --
----------
function Asin (X : Double) return Double is
Result : Double;
begin
Result := Atan (X / Sqrt ((1.0 - X) * (1.0 + X)));
-- The result value is NaN iff input was invalid
if Is_Nan (Result) then
raise Argument_Error;
end if;
return Result;
end Asin;
---------
-- Cos --
---------
function Cos (X : Double) return Double is
Reduced_X : Double := X;
Result : Double;
Status : FPU_Status_Word;
begin
loop
Asm
(Template =>
"fcos " & NL
& "xorl %%eax, %%eax " & NL
& "fnstsw %%ax ",
Outputs => (Double'Asm_Output ("=t", Result),
FPU_Status_Word'Asm_Output ("=a", Status)),
Inputs => Double'Asm_Input ("0", Reduced_X));
exit when not Status.C2;
-- Original argument was not in range and the result
-- is the unmodified argument.
Reduced_X := Reduce (Result);
end loop;
return Result;
end Cos;
---------------------
-- Logarithmic_Pow --
---------------------
function Logarithmic_Pow (X, Y : Double) return Double is
Result : Double;
begin
Asm (Template => "" -- X : Y
& "fyl2x " & NL -- Y * Log2 (X)
& "fst %%st(1) " & NL -- Y * Log2 (X) : Y * Log2 (X)
& "frndint " & NL -- Int (...) : Y * Log2 (X)
& "fsubr %%st, %%st(1)" & NL -- Int (...) : Fract (...)
& "fxch " & NL -- Fract (...) : Int (...)
& "f2xm1 " & NL -- 2**Fract (...) - 1 : Int (...)
& "fld1 " & NL -- 1 : 2**Fract (...) - 1 : Int (...)
& "faddp %%st, %%st(1)" & NL -- 2**Fract (...) : Int (...)
& "fscale " & NL -- 2**(Fract (...) + Int (...))
& "fstp %%st(1) ",
Outputs => Double'Asm_Output ("=t", Result),
Inputs =>
(Double'Asm_Input ("0", X),
Double'Asm_Input ("u", Y)));
return Result;
end Logarithmic_Pow;
---------
-- Pow --
---------
function Pow (X, Y : Double) return Double is
type Mantissa_Type is mod 2**Double'Machine_Mantissa;
-- Modular type that can hold all bits of the mantissa of Double
-- For negative exponents, a division is done
-- at the end of the processing.
Negative_Y : constant Boolean := Y < 0.0;
Abs_Y : constant Double := abs Y;
-- During this function the following invariant is kept:
-- X ** (abs Y) = Base**(Exp_High + Exp_Mid + Exp_Low) * Factor
Base : Double := X;
Exp_High : Double := Double'Floor (Abs_Y);
Exp_Mid : Double;
Exp_Low : Double;
Exp_Int : Mantissa_Type;
Factor : Double := 1.0;
begin
-- Select algorithm for calculating Pow:
-- integer cases fall through
if Exp_High >= 2.0**Double'Machine_Mantissa then
-- In case of Y that is IEEE infinity, just raise constraint error
if Exp_High > Double'Safe_Last then
raise Constraint_Error;
end if;
-- Large values of Y are even integers and will stay integer
-- after division by two.
loop
-- Exp_Mid and Exp_Low are zero, so
-- X**(abs Y) = Base ** Exp_High = (Base**2) ** (Exp_High / 2)
Exp_High := Exp_High / 2.0;
Base := Base * Base;
exit when Exp_High < 2.0**Double'Machine_Mantissa;
end loop;
elsif Exp_High /= Abs_Y then
Exp_Low := Abs_Y - Exp_High;
Factor := 1.0;
if Exp_Low /= 0.0 then
-- Exp_Low now is in interval (0.0, 1.0)
-- Exp_Mid := Double'Floor (Exp_Low * 4.0) / 4.0;
Exp_Mid := 0.0;
Exp_Low := Exp_Low - Exp_Mid;
if Exp_Low >= 0.5 then
Factor := Sqrt (X);
Exp_Low := Exp_Low - 0.5; -- exact
if Exp_Low >= 0.25 then
Factor := Factor * Sqrt (Factor);
Exp_Low := Exp_Low - 0.25; -- exact
end if;
elsif Exp_Low >= 0.25 then
Factor := Sqrt (Sqrt (X));
Exp_Low := Exp_Low - 0.25; -- exact
end if;
-- Exp_Low now is in interval (0.0, 0.25)
-- This means it is safe to call Logarithmic_Pow
-- for the remaining part.
Factor := Factor * Logarithmic_Pow (X, Exp_Low);
end if;
elsif X = 0.0 then
return 0.0;
end if;
-- Exp_High is non-zero integer smaller than 2**Double'Machine_Mantissa
Exp_Int := Mantissa_Type (Exp_High);
-- Standard way for processing integer powers > 0
while Exp_Int > 1 loop
if (Exp_Int and 1) = 1 then
-- Base**Y = Base**(Exp_Int - 1) * Exp_Int for Exp_Int > 0
Factor := Factor * Base;
end if;
-- Exp_Int is even and Exp_Int > 0, so
-- Base**Y = (Base**2)**(Exp_Int / 2)
Base := Base * Base;
Exp_Int := Exp_Int / 2;
end loop;
-- Exp_Int = 1 or Exp_Int = 0
if Exp_Int = 1 then
Factor := Base * Factor;
end if;
if Negative_Y then
Factor := 1.0 / Factor;
end if;
return Factor;
end Pow;
---------
-- Sin --
---------
function Sin (X : Double) return Double is
Reduced_X : Double := X;
Result : Double;
Status : FPU_Status_Word;
begin
loop
Asm
(Template =>
"fsin " & NL
& "xorl %%eax, %%eax " & NL
& "fnstsw %%ax ",
Outputs => (Double'Asm_Output ("=t", Result),
FPU_Status_Word'Asm_Output ("=a", Status)),
Inputs => Double'Asm_Input ("0", Reduced_X));
exit when not Status.C2;
-- Original argument was not in range and the result
-- is the unmodified argument.
Reduced_X := Reduce (Result);
end loop;
return Result;
end Sin;
---------
-- Tan --
---------
function Tan (X : Double) return Double is
Reduced_X : Double := X;
Result : Double;
Status : FPU_Status_Word;
begin
loop
Asm
(Template =>
"fptan " & NL
& "xorl %%eax, %%eax " & NL
& "fnstsw %%ax " & NL
& "ffree %%st(0) " & NL
& "fincstp ",
Outputs => (Double'Asm_Output ("=t", Result),
FPU_Status_Word'Asm_Output ("=a", Status)),
Inputs => Double'Asm_Input ("0", Reduced_X));
exit when not Status.C2;
-- Original argument was not in range and the result
-- is the unmodified argument.
Reduced_X := Reduce (Result);
end loop;
return Result;
end Tan;
----------
-- Sinh --
----------
function Sinh (X : Double) return Double is
begin
-- Mathematically Sinh (x) is defined to be (Exp (X) - Exp (-X)) / 2.0
if abs X < 25.0 then
return (Exp (X) - Exp (-X)) / 2.0;
else
return Exp (X) / 2.0;
end if;
end Sinh;
----------
-- Cosh --
----------
function Cosh (X : Double) return Double is
begin
-- Mathematically Cosh (X) is defined to be (Exp (X) + Exp (-X)) / 2.0
if abs X < 22.0 then
return (Exp (X) + Exp (-X)) / 2.0;
else
return Exp (X) / 2.0;
end if;
end Cosh;
----------
-- Tanh --
----------
function Tanh (X : Double) return Double is
begin
-- Return the Hyperbolic Tangent of x
--
-- x -x
-- e - e Sinh (X)
-- Tanh (X) is defined to be ----------- = --------
-- x -x Cosh (X)
-- e + e
if abs X > 23.0 then
return Double'Copy_Sign (1.0, X);
end if;
return 1.0 / (1.0 + Exp (-2.0 * X)) - 1.0 / (1.0 + Exp (2.0 * X));
end Tanh;
end Ada.Numerics.Aux;
gcc/ada/a-numaux-x86.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . N U M E R I C S . A U X --
-- --
-- S p e c --
-- (Machine Version for x86) --
-- --
-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides the basic computational interface for the generic
-- elementary functions. This implementation is based on the glibc assembly
-- sources for the x86 glibc math library.
-- Note: there are two versions of this package. One using the 80-bit x86
-- long double format (which is this version), and one using 64-bit IEEE
-- double (see file a-numaux.ads). The latter version imports the C
-- routines directly.
package Ada.Numerics.Aux is
pragma Pure (Aux);
type Double is new Long_Long_Float;
function Sin (X : Double) return Double;
function Cos (X : Double) return Double;
function Tan (X : Double) return Double;
function Exp (X : Double) return Double;
function Sqrt (X : Double) return Double;
function Log (X : Double) return Double;
function Atan (X : Double) return Double;
function Acos (X : Double) return Double;
function Asin (X : Double) return Double;
function Sinh (X : Double) return Double;
function Cosh (X : Double) return Double;
function Tanh (X : Double) return Double;
function Pow (X, Y : Double) return Double;
private
pragma Inline (Atan);
pragma Inline (Cos);
pragma Inline (Tan);
pragma Inline (Exp);
pragma Inline (Log);
pragma Inline (Sin);
pragma Inline (Sqrt);
end Ada.Numerics.Aux;
gcc/ada/i-cpp-vms.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- I N T E R F A C E S . C P P --
-- --
-- B o d y --
-- --
-- Copyright (C) 2000-2004, 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. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the OpenVMS/Alpha DEC C++ (cxx) version of this package
with Ada.Tags; use Ada.Tags;
with System; use System;
with System.Storage_Elements; use System.Storage_Elements;
with Unchecked_Conversion;
package body Interfaces.CPP is
subtype Cstring is String (Positive);
type Cstring_Ptr is access all Cstring;
type Tag_Table is array (Natural range <>) of Vtable_Ptr;
pragma Suppress_Initialization (Tag_Table);
type Type_Specific_Data is record
Idepth : Natural;
Expanded_Name : Cstring_Ptr;
External_Tag : Cstring_Ptr;
HT_Link : Tag;
Ancestor_Tags : Tag_Table (Natural);
end record;
type Vtable_Entry is record
Pfn : System.Address;
end record;
type Type_Specific_Data_Ptr is access all Type_Specific_Data;
type Vtable_Entry_Array is array (Positive range <>) of Vtable_Entry;
type VTable is record
Prims_Ptr : Vtable_Entry_Array (Positive);
TSD : Type_Specific_Data_Ptr;
-- Location of TSD is unknown so it got moved here to be out of the
-- way of Prims_Ptr. Find it later. ???
end record;
--------------------------------------------------------
-- Unchecked Conversions for Tag, Vtable_Ptr, and TSD --
--------------------------------------------------------
function To_Type_Specific_Data_Ptr is
new Unchecked_Conversion (Address, Type_Specific_Data_Ptr);
function To_Address is
new Unchecked_Conversion (Type_Specific_Data_Ptr, Address);
---------------------------------------------
-- Unchecked Conversions for String Fields --
---------------------------------------------
function To_Cstring_Ptr is
new Unchecked_Conversion (Address, Cstring_Ptr);
function To_Address is
new Unchecked_Conversion (Cstring_Ptr, Address);
-----------------------
-- Local Subprograms --
-----------------------
function Length (Str : Cstring_Ptr) return Natural;
-- Length of string represented by the given pointer (treating the
-- string as a C-style string, which is Nul terminated).
--------------------
-- Displaced_This --
--------------------
function Displaced_This
(Current_This : System.Address;
Vptr : Vtable_Ptr;
Position : Positive) return System.Address
is
pragma Warnings (Off, Vptr);
pragma Warnings (Off, Position);
begin
return Current_This;
-- + Storage_Offset (Vptr.Prims_Ptr (Position).Delta1);
-- why is above line commented out ???
end Displaced_This;
-----------------------
-- CPP_CW_Membership --
-----------------------
function CPP_CW_Membership
(Obj_Tag : Vtable_Ptr;
Typ_Tag : Vtable_Ptr) return Boolean
is
Pos : constant Integer := Obj_Tag.TSD.Idepth - Typ_Tag.TSD.Idepth;
begin
return Pos >= 0 and then Obj_Tag.TSD.Ancestor_Tags (Pos) = Typ_Tag;
end CPP_CW_Membership;
---------------------------
-- CPP_Get_Expanded_Name --
---------------------------
function CPP_Get_Expanded_Name (T : Vtable_Ptr) return Address is
begin
return To_Address (T.TSD.Expanded_Name);
end CPP_Get_Expanded_Name;
--------------------------
-- CPP_Get_External_Tag --
--------------------------
function CPP_Get_External_Tag (T : Vtable_Ptr) return Address is
begin
return To_Address (T.TSD.External_Tag);
end CPP_Get_External_Tag;
-------------------------------
-- CPP_Get_Inheritance_Depth --
-------------------------------
function CPP_Get_Inheritance_Depth (T : Vtable_Ptr) return Natural is
begin
return T.TSD.Idepth;
end CPP_Get_Inheritance_Depth;
-----------------------
-- CPP_Get_RC_Offset --
-----------------------
function CPP_Get_RC_Offset (T : Vtable_Ptr) return SSE.Storage_Offset is
pragma Warnings (Off, T);
begin
return 0;
end CPP_Get_RC_Offset;
-----------------------------
-- CPP_Get_Prim_Op_Address --
-----------------------------
function CPP_Get_Prim_Op_Address
(T : Vtable_Ptr;
Position : Positive) return Address
is
begin
return T.Prims_Ptr (Position).Pfn;
end CPP_Get_Prim_Op_Address;
-------------------------------
-- CPP_Get_Remotely_Callable --
-------------------------------
function CPP_Get_Remotely_Callable (T : Vtable_Ptr) return Boolean is
pragma Warnings (Off, T);
begin
return True;
end CPP_Get_Remotely_Callable;
-----------------
-- CPP_Get_TSD --
-----------------
function CPP_Get_TSD (T : Vtable_Ptr) return Address is
begin
return To_Address (T.TSD);
end CPP_Get_TSD;
--------------------
-- CPP_Inherit_DT --
--------------------
procedure CPP_Inherit_DT
(Old_T : Vtable_Ptr;
New_T : Vtable_Ptr;
Entry_Count : Natural)
is
begin
if Old_T /= null then
New_T.Prims_Ptr (1 .. Entry_Count) :=
Old_T.Prims_Ptr (1 .. Entry_Count);
end if;
end CPP_Inherit_DT;
---------------------
-- CPP_Inherit_TSD --
---------------------
procedure CPP_Inherit_TSD
(Old_TSD : Address;
New_Tag : Vtable_Ptr)
is
TSD : constant Type_Specific_Data_Ptr :=
To_Type_Specific_Data_Ptr (Old_TSD);
New_TSD : Type_Specific_Data renames New_Tag.TSD.all;
begin
if TSD /= null then
New_TSD.Idepth := TSD.Idepth + 1;
New_TSD.Ancestor_Tags (1 .. New_TSD.Idepth)
:= TSD.Ancestor_Tags (0 .. TSD.Idepth);
else
New_TSD.Idepth := 0;
end if;
New_TSD.Ancestor_Tags (0) := New_Tag;
end CPP_Inherit_TSD;
---------------------------
-- CPP_Set_Expanded_Name --
---------------------------
procedure CPP_Set_Expanded_Name (T : Vtable_Ptr; Value : Address) is
begin
T.TSD.Expanded_Name := To_Cstring_Ptr (Value);
end CPP_Set_Expanded_Name;
--------------------------
-- CPP_Set_External_Tag --
--------------------------
procedure CPP_Set_External_Tag (T : Vtable_Ptr; Value : Address) is
begin
T.TSD.External_Tag := To_Cstring_Ptr (Value);
end CPP_Set_External_Tag;
-------------------------------
-- CPP_Set_Inheritance_Depth --
-------------------------------
procedure CPP_Set_Inheritance_Depth
(T : Vtable_Ptr;
Value : Natural)
is
begin
T.TSD.Idepth := Value;
end CPP_Set_Inheritance_Depth;
-----------------------------
-- CPP_Set_Prim_Op_Address --
-----------------------------
procedure CPP_Set_Prim_Op_Address
(T : Vtable_Ptr;
Position : Positive;
Value : Address)
is
begin
T.Prims_Ptr (Position).Pfn := Value;
end CPP_Set_Prim_Op_Address;
-----------------------
-- CPP_Set_RC_Offset --
-----------------------
procedure CPP_Set_RC_Offset (T : Vtable_Ptr; Value : SSE.Storage_Offset) is
pragma Warnings (Off, T);
pragma Warnings (Off, Value);
begin
null;
end CPP_Set_RC_Offset;
-------------------------------
-- CPP_Set_Remotely_Callable --
-------------------------------
procedure CPP_Set_Remotely_Callable (T : Vtable_Ptr; Value : Boolean) is
pragma Warnings (Off, T);
pragma Warnings (Off, Value);
begin
null;
end CPP_Set_Remotely_Callable;
-----------------
-- CPP_Set_TSD --
-----------------
procedure CPP_Set_TSD (T : Vtable_Ptr; Value : Address) is
begin
T.TSD := To_Type_Specific_Data_Ptr (Value);
end CPP_Set_TSD;
-------------------
-- Expanded_Name --
-------------------
function Expanded_Name (T : Vtable_Ptr) return String is
Result : constant Cstring_Ptr := T.TSD.Expanded_Name;
begin
return Result (1 .. Length (Result));
end Expanded_Name;
------------------
-- External_Tag --
------------------
function External_Tag (T : Vtable_Ptr) return String is
Result : constant Cstring_Ptr := T.TSD.External_Tag;
begin
return Result (1 .. Length (Result));
end External_Tag;
------------
-- Length --
------------
function Length (Str : Cstring_Ptr) return Natural is
Len : Integer := 1;
begin
while Str (Len) /= ASCII.Nul loop
Len := Len + 1;
end loop;
return Len - 1;
end Length;
end Interfaces.CPP;
gcc/ada/i-cstrea-vms.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- I N T E R F A C E S . C _ S T R E A M S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2004 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. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the Alpha/VMS version.
with Unchecked_Conversion;
package body Interfaces.C_Streams is
use type System.CRTL.size_t;
-- As the functions fread, fwrite and setvbuf are too big to be inlined,
-- they are just wrappers to the following implementation functions.
function fread_impl
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t;
function fread_impl
(buffer : voids;
index : size_t;
size : size_t;
count : size_t;
stream : FILEs) return size_t;
function fwrite_impl
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t;
function setvbuf_impl
(stream : FILEs;
buffer : chars;
mode : int;
size : size_t) return int;
------------
-- fread --
------------
function fread_impl
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
Get_Count : size_t := 0;
type Buffer_Type is array (size_t range 1 .. count,
size_t range 1 .. size) of Character;
type Buffer_Access is access Buffer_Type;
function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
BA : constant Buffer_Access := To_BA (buffer);
Ch : int;
begin
-- This Fread goes with the Fwrite below.
-- The C library fread sometimes can't read fputc generated files.
for C in 1 .. count loop
for S in 1 .. size loop
Ch := fgetc (stream);
if Ch = EOF then
return Get_Count;
end if;
BA.all (C, S) := Character'Val (Ch);
end loop;
Get_Count := Get_Count + 1;
end loop;
return Get_Count;
end fread_impl;
function fread_impl
(buffer : voids;
index : size_t;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
Get_Count : size_t := 0;
type Buffer_Type is array (size_t range 1 .. count,
size_t range 1 .. size) of Character;
type Buffer_Access is access Buffer_Type;
function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
BA : constant Buffer_Access := To_BA (buffer);
Ch : int;
begin
-- This Fread goes with the Fwrite below.
-- The C library fread sometimes can't read fputc generated files.
for C in 1 + index .. count + index loop
for S in 1 .. size loop
Ch := fgetc (stream);
if Ch = EOF then
return Get_Count;
end if;
BA.all (C, S) := Character'Val (Ch);
end loop;
Get_Count := Get_Count + 1;
end loop;
return Get_Count;
end fread_impl;
function fread
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
begin
return fread_impl (buffer, size, count, stream);
end fread;
function fread
(buffer : voids;
index : size_t;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
begin
return fread_impl (buffer, index, size, count, stream);
end fread;
------------
-- fwrite --
------------
function fwrite_impl
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
Put_Count : size_t := 0;
type Buffer_Type is array (size_t range 1 .. count,
size_t range 1 .. size) of Character;
type Buffer_Access is access Buffer_Type;
function To_BA is new Unchecked_Conversion (voids, Buffer_Access);
BA : constant Buffer_Access := To_BA (buffer);
begin
-- Fwrite on VMS has the undesirable effect of always generating at
-- least one record of output per call, regardless of buffering. To
-- get around this, we do multiple fputc calls instead.
for C in 1 .. count loop
for S in 1 .. size loop
if fputc (Character'Pos (BA.all (C, S)), stream) = EOF then
return Put_Count;
end if;
end loop;
Put_Count := Put_Count + 1;
end loop;
return Put_Count;
end fwrite_impl;
function fwrite
(buffer : voids;
size : size_t;
count : size_t;
stream : FILEs) return size_t
is
begin
return fwrite_impl (buffer, size, count, stream);
end fwrite;
-------------
-- setvbuf --
-------------
function setvbuf_impl
(stream : FILEs;
buffer : chars;
mode : int;
size : size_t) return int
is
use type System.Address;
begin
-- In order for the above fwrite hack to work, we must always buffer
-- stdout and stderr. Is_regular_file on VMS cannot detect when
-- these are redirected to a file, so checking for that condition
-- doesnt help.
if mode = IONBF
and then (stream = stdout or else stream = stderr)
then
return System.CRTL.setvbuf
(stream, buffer, IOLBF, System.CRTL.size_t (size));
else
return System.CRTL.setvbuf
(stream, buffer, mode, System.CRTL.size_t (size));
end if;
end setvbuf_impl;
function setvbuf
(stream : FILEs;
buffer : chars;
mode : int;
size : size_t) return int
is
begin
return setvbuf_impl (stream, buffer, mode, size);
end setvbuf;
end Interfaces.C_Streams;
gcc/ada/interfac-vms.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- I N T E R F A C E S --
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2003 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 implementation dependent sections of this file. --
-- --
-- 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. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is the OpenVMS version of this package which adds Float_Representation
-- pragmas to the IEEE floating point types to ensure they remain IEEE in
-- the presence of a configuration pragma Float_Representation (Vax_Float).
-- It assumes integer sizes of 8, 16, 32 and 64 are available, and that IEEE
-- floating-point formats are available.
package Interfaces is
pragma Pure (Interfaces);
type Integer_8 is range -2 ** 7 .. 2 ** 7 - 1;
for Integer_8'Size use 8;
type Integer_16 is range -2 ** 15 .. 2 ** 15 - 1;
for Integer_16'Size use 16;
type Integer_32 is range -2 ** 31 .. 2 ** 31 - 1;
for Integer_32'Size use 32;
type Integer_64 is range -2 ** 63 .. 2 ** 63 - 1;
for Integer_64'Size use 64;
type Unsigned_8 is mod 2 ** 8;
for Unsigned_8'Size use 8;
type Unsigned_16 is mod 2 ** 16;
for Unsigned_16'Size use 16;
type Unsigned_32 is mod 2 ** 32;
for Unsigned_32'Size use 32;
type Unsigned_64 is mod 2 ** 64;
for Unsigned_64'Size use 64;
function Shift_Left
(Value : Unsigned_8;
Amount : Natural)
return Unsigned_8;
function Shift_Right
(Value : Unsigned_8;
Amount : Natural)
return Unsigned_8;
function Shift_Right_Arithmetic
(Value : Unsigned_8;
Amount : Natural)
return Unsigned_8;
function Rotate_Left
(Value : Unsigned_8;
Amount : Natural)
return Unsigned_8;
function Rotate_Right
(Value : Unsigned_8;
Amount : Natural)
return Unsigned_8;
function Shift_Left
(Value : Unsigned_16;
Amount : Natural)
return Unsigned_16;
function Shift_Right
(Value : Unsigned_16;
Amount : Natural)
return Unsigned_16;
function Shift_Right_Arithmetic
(Value : Unsigned_16;
Amount : Natural)
return Unsigned_16;
function Rotate_Left
(Value : Unsigned_16;
Amount : Natural)
return Unsigned_16;
function Rotate_Right
(Value : Unsigned_16;
Amount : Natural)
return Unsigned_16;
function Shift_Left
(Value : Unsigned_32;
Amount : Natural)
return Unsigned_32;
function Shift_Right
(Value : Unsigned_32;
Amount : Natural)
return Unsigned_32;
function Shift_Right_Arithmetic
(Value : Unsigned_32;
Amount : Natural)
return Unsigned_32;
function Rotate_Left
(Value : Unsigned_32;
Amount : Natural)
return Unsigned_32;
function Rotate_Right
(Value : Unsigned_32;
Amount : Natural)
return Unsigned_32;
function Shift_Left
(Value : Unsigned_64;
Amount : Natural)
return Unsigned_64;
function Shift_Right
(Value : Unsigned_64;
Amount : Natural)
return Unsigned_64;
function Shift_Right_Arithmetic
(Value : Unsigned_64;
Amount : Natural)
return Unsigned_64;
function Rotate_Left
(Value : Unsigned_64;
Amount : Natural)
return Unsigned_64;
function Rotate_Right
(Value : Unsigned_64;
Amount : Natural)
return Unsigned_64;
pragma Import (Intrinsic, Shift_Left);
pragma Import (Intrinsic, Shift_Right);
pragma Import (Intrinsic, Shift_Right_Arithmetic);
pragma Import (Intrinsic, Rotate_Left);
pragma Import (Intrinsic, Rotate_Right);
-- Floating point types. We use the digits value to define the IEEE
-- forms, otherwise a configuration pragma specifying VAX float can
-- default the digits to an illegal value for IEEE.
-- Note: it is harmless, and explicitly permitted, to include additional
-- types in interfaces, so it is not wrong to have IEEE_Extended_Float
-- defined even if the extended format is not available.
type IEEE_Float_32 is digits 6;
pragma Float_Representation (IEEE_Float, IEEE_Float_32);
type IEEE_Float_64 is digits 15;
pragma Float_Representation (IEEE_Float, IEEE_Float_64);
type IEEE_Extended_Float is digits 15;
pragma Float_Representation (IEEE_Float, IEEE_Extended_Float);
end Interfaces;
gcc/ada/s-inmaop-posix.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
-- --
-- B o d y --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- 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. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a POSIX-like version of this package.
-- Note: this file can only be used for POSIX compliant systems.
with Interfaces.C;
-- used for int
-- size_t
-- unsigned
with System.OS_Interface;
-- used for various type, constant, and operations
with System.Storage_Elements;
-- used for To_Address
-- Integer_Address
with Unchecked_Conversion;
package body System.Interrupt_Management.Operations is
use Interfaces.C;
use System.OS_Interface;
type Interrupt_Mask_Ptr is access all Interrupt_Mask;
function "+" is new
Unchecked_Conversion (Interrupt_Mask_Ptr, sigset_t_ptr);
---------------------
-- Local Variables --
---------------------
Initial_Action : array (Signal) of aliased struct_sigaction;
Default_Action : aliased struct_sigaction;
Ignore_Action : aliased struct_sigaction;
----------------------------
-- Thread_Block_Interrupt --
----------------------------
procedure Thread_Block_Interrupt
(Interrupt : Interrupt_ID)
is
Result : Interfaces.C.int;
Mask : aliased sigset_t;
begin
Result := sigemptyset (Mask'Access);
pragma Assert (Result = 0);
Result := sigaddset (Mask'Access, Signal (Interrupt));
pragma Assert (Result = 0);
Result := pthread_sigmask (SIG_BLOCK, Mask'Unchecked_Access, null);
pragma Assert (Result = 0);
end Thread_Block_Interrupt;
------------------------------
-- Thread_Unblock_Interrupt --
------------------------------
procedure Thread_Unblock_Interrupt
(Interrupt : Interrupt_ID)
is
Mask : aliased sigset_t;
Result : Interfaces.C.int;
begin
Result := sigemptyset (Mask'Access);
pragma Assert (Result = 0);
Result := sigaddset (Mask'Access, Signal (Interrupt));
pragma Assert (Result = 0);
Result := pthread_sigmask (SIG_UNBLOCK, Mask'Unchecked_Access, null);
pragma Assert (Result = 0);
end Thread_Unblock_Interrupt;
------------------------
-- Set_Interrupt_Mask --
------------------------
procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is
Result : Interfaces.C.int;
begin
Result := pthread_sigmask
(SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), null);
pragma Assert (Result = 0);
end Set_Interrupt_Mask;
procedure Set_Interrupt_Mask
(Mask : access Interrupt_Mask;
OMask : access Interrupt_Mask)
is
Result : Interfaces.C.int;
begin
Result := pthread_sigmask
(SIG_SETMASK, +Interrupt_Mask_Ptr (Mask), +Interrupt_Mask_Ptr (OMask));
pragma Assert (Result = 0);
end Set_Interrupt_Mask;
------------------------
-- Get_Interrupt_Mask --
------------------------
procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is
Result : Interfaces.C.int;
begin
Result := pthread_sigmask
(SIG_SETMASK, null, +Interrupt_Mask_Ptr (Mask));
pragma Assert (Result = 0);
end Get_Interrupt_Mask;
--------------------
-- Interrupt_Wait --
--------------------
function Interrupt_Wait
(Mask : access Interrupt_Mask)
return Interrupt_ID
is
Result : Interfaces.C.int;
Sig : aliased Signal;
begin
Result := sigwait (Mask, Sig'Access);
if Result /= 0 then
return 0;
end if;
return Interrupt_ID (Sig);
end Interrupt_Wait;
----------------------------
-- Install_Default_Action --
----------------------------
procedure Install_Default_Action (Interrupt : Interrupt_ID) is
Result : Interfaces.C.int;
begin
Result := sigaction
(Signal (Interrupt),
Initial_Action (Signal (Interrupt))'Access, null);
pragma Assert (Result = 0);
end Install_Default_Action;
---------------------------
-- Install_Ignore_Action --
---------------------------
procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is
Result : Interfaces.C.int;
begin
Result := sigaction (Signal (Interrupt), Ignore_Action'Access, null);
pragma Assert (Result = 0);
end Install_Ignore_Action;
-------------------------
-- Fill_Interrupt_Mask --
-------------------------
procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is
Result : Interfaces.C.int;
begin
Result := sigfillset (Mask);
pragma Assert (Result = 0);
end Fill_Interrupt_Mask;
--------------------------
-- Empty_Interrupt_Mask --
--------------------------
procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is
Result : Interfaces.C.int;
begin
Result := sigemptyset (Mask);
pragma Assert (Result = 0);
end Empty_Interrupt_Mask;
---------------------------
-- Add_To_Interrupt_Mask --
---------------------------
procedure Add_To_Interrupt_Mask
(Mask : access Interrupt_Mask;
Interrupt : Interrupt_ID)
is
Result : Interfaces.C.int;
begin
Result := sigaddset (Mask, Signal (Interrupt));
pragma Assert (Result = 0);
end Add_To_Interrupt_Mask;
--------------------------------
-- Delete_From_Interrupt_Mask --
--------------------------------
procedure Delete_From_Interrupt_Mask
(Mask : access Interrupt_Mask;
Interrupt : Interrupt_ID)
is
Result : Interfaces.C.int;
begin
Result := sigdelset (Mask, Signal (Interrupt));
pragma Assert (Result = 0);
end Delete_From_Interrupt_Mask;
---------------
-- Is_Member --
---------------
function Is_Member
(Mask : access Interrupt_Mask;
Interrupt : Interrupt_ID) return Boolean
is
Result : Interfaces.C.int;
begin
Result := sigismember (Mask, Signal (Interrupt));
pragma Assert (Result = 0 or else Result = 1);
return Result = 1;
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
Result : Interfaces.C.int;
begin
Result := kill (getpid, Signal (Interrupt));
pragma Assert (Result = 0);
end Interrupt_Self_Process;
begin
declare
mask : aliased sigset_t;
allmask : aliased sigset_t;
Result : Interfaces.C.int;
begin
for Sig in 1 .. Signal'Last loop
Result := sigaction
(Sig, null, Initial_Action (Sig)'Unchecked_Access);
-- ??? [assert 1]
-- we can't check Result here since sigaction will fail on
-- SIGKILL, SIGSTOP, and possibly other signals
-- pragma Assert (Result = 0);
end loop;
-- Setup the masks to be exported.
Result := sigemptyset (mask'Access);
pragma Assert (Result = 0);
Result := sigfillset (allmask'Access);
pragma Assert (Result = 0);
Default_Action.sa_flags := 0;
Default_Action.sa_mask := mask;
Default_Action.sa_handler :=
Storage_Elements.To_Address
(Storage_Elements.Integer_Address (SIG_DFL));
Ignore_Action.sa_flags := 0;
Ignore_Action.sa_mask := mask;
Ignore_Action.sa_handler :=
Storage_Elements.To_Address
(Storage_Elements.Integer_Address (SIG_IGN));
for J in Interrupt_ID loop
-- We need to check whether J is in Keep_Unmasked because
-- the index type of the Keep_Unmasked array is not always
-- Interrupt_ID; it may be a subtype of Interrupt_ID.
if J in Keep_Unmasked'Range and then Keep_Unmasked (J) then
Result := sigaddset (mask'Access, Signal (J));
pragma Assert (Result = 0);
Result := sigdelset (allmask'Access, Signal (J));
pragma Assert (Result = 0);
end if;
end loop;
-- The Keep_Unmasked signals should be unmasked for Environment task
Result := pthread_sigmask (SIG_UNBLOCK, mask'Unchecked_Access, null);
pragma Assert (Result = 0);
-- Get the signal mask of the Environment Task
Result := pthread_sigmask (SIG_SETMASK, null, mask'Unchecked_Access);
pragma Assert (Result = 0);
-- Setup the constants exported
Environment_Mask := Interrupt_Mask (mask);
All_Tasks_Mask := Interrupt_Mask (allmask);
end;
end System.Interrupt_Management.Operations;
gcc/ada/s-intman-posix.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 --
-- --
-- Copyright (C) 1992-2003, 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. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is the POSIX threads version of this package
-- PLEASE DO NOT add any dependences on other packages. ??? why not ???
-- This package is designed to work with or without tasking support.
-- See the other warnings in the package specification before making
-- any modifications to this file.
-- 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.
-- Since this is a multi target file, the signal <-> exception mapping
-- is simple minded. If you need a more precise and target specific
-- signal handling, create a new s-intman.adb that will fit your needs.
-- This file assumes that:
-- SIGFPE, SIGILL, SIGSEGV and SIGBUS exist. They are mapped as follows:
-- SIGPFE => Constraint_Error
-- SIGILL => Program_Error
-- SIGSEGV => Storage_Error
-- SIGBUS => Storage_Error
-- SIGINT exists and will be kept unmasked unless the pragma
-- Unreserve_All_Interrupts is specified anywhere in the application.
-- System.OS_Interface contains the following:
-- SIGADAABORT: the signal that will be used to abort tasks.
-- Unmasked: the OS specific set of signals that should be unmasked in
-- all the threads. SIGADAABORT is unmasked by
-- default
-- Reserved: the OS specific set of signals that are reserved.
with Interfaces.C;
-- used for int and other types
with System.OS_Interface;
-- used for various Constants, Signal and types
package body System.Interrupt_Management is
use Interfaces.C;
use System.OS_Interface;
type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
Exception_Interrupts : constant Interrupt_List :=
(SIGFPE, SIGILL, SIGSEGV, SIGBUS);
Unreserve_All_Interrupts : Interfaces.C.int;
pragma Import
(C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
-----------------------
-- Local Subprograms --
-----------------------
procedure Notify_Exception (signo : Signal);
-- 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.
----------------------
-- Notify_Exception --
----------------------
Signal_Mask : aliased sigset_t;
-- The set of signals handled by Notify_Exception
procedure Notify_Exception (signo : Signal) is
Result : Interfaces.C.int;
begin
-- With the __builtin_longjmp, the signal mask is not restored, so we
-- need to restore it explicitely.
Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null);
pragma Assert (Result = 0);
-- Check that treatment of exception propagation here
-- is consistent with treatment of the abort signal in
-- System.Task_Primitives.Operations.
case signo is
when SIGFPE =>
raise Constraint_Error;
when SIGILL =>
raise Program_Error;
when SIGSEGV =>
raise Storage_Error;
when SIGBUS =>
raise Storage_Error;
when others =>
null;
end case;
end Notify_Exception;
---------------------------
-- Initialize_Interrupts --
---------------------------
-- Nothing needs to be done on this platform.
procedure Initialize_Interrupts is
begin
null;
end Initialize_Interrupts;
-------------------------
-- Package Elaboration --
-------------------------
begin
declare
act : aliased struct_sigaction;
old_act : aliased struct_sigaction;
Result : System.OS_Interface.int;
function State (Int : Interrupt_ID) return Character;
pragma Import (C, State, "__gnat_get_interrupt_state");
-- Get interrupt state. Defined in a-init.c
-- The input argument is the interrupt number,
-- and the result is one of the following:
User : constant Character := 'u';
Runtime : constant Character := 'r';
Default : constant Character := 's';
-- 'n' this interrupt not set by any Interrupt_State pragma
-- 'u' Interrupt_State pragma set state to User
-- 'r' Interrupt_State pragma set state to Runtime
-- 's' Interrupt_State pragma set state to System (use "default"
-- system handler)
begin
-- Need to call pthread_init very early because it is doing signal
-- initializations.
pthread_init;
Abort_Task_Interrupt := SIGADAABORT;
act.sa_handler := Notify_Exception'Address;
act.sa_flags := SA_SIGINFO;
-- Setting SA_SIGINFO asks the kernel to pass more than just the signal
-- number argument to the handler when it is called. The set of extra
-- parameters typically includes a pointer to a structure describing
-- the interrupted context. Although the Notify_Exception handler does
-- not use this information, it is actually required for the GCC/ZCX
-- exception propagation scheme because on some targets (at least
-- alpha-tru64), the structure contents are not even filled when this
-- flag is not set.
-- On some targets, we set sa_flags to SA_NODEFER so that during the
-- handler execution we do not change the Signal_Mask to be masked for
-- the Signal.
-- This is a temporary fix to the problem that the Signal_Mask is
-- not restored after the exception (longjmp) from the handler.
-- The right fix should be made in sigsetjmp so that we save
-- the Signal_Set and restore it after a longjmp.
-- Since SA_NODEFER is obsolete, instead we reset explicitely
-- the mask in the exception handler.
Result := sigemptyset (Signal_Mask'Access);
pragma Assert (Result = 0);
-- Add signals that map to Ada exceptions to the mask.
for J in Exception_Interrupts'Range loop
if State (Exception_Interrupts (J)) /= Default then
Result :=
sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J)));
pragma Assert (Result = 0);
end if;
end loop;
act.sa_mask := Signal_Mask;
pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
pragma Assert (Reserve = (Interrupt_ID'Range => False));
-- Process state of exception signals
for J in Exception_Interrupts'Range loop
if State (Exception_Interrupts (J)) /= User then
Keep_Unmasked (Exception_Interrupts (J)) := True;
Reserve (Exception_Interrupts (J)) := True;
if State (Exception_Interrupts (J)) /= Default then
Result :=
sigaction
(Signal (Exception_Interrupts (J)), act'Unchecked_Access,
old_act'Unchecked_Access);
pragma Assert (Result = 0);
end if;
end if;
end loop;
if State (Abort_Task_Interrupt) /= User then
Keep_Unmasked (Abort_Task_Interrupt) := True;
Reserve (Abort_Task_Interrupt) := True;
end if;
-- Set SIGINT to unmasked state as long as it is not in "User"
-- state. Check for Unreserve_All_Interrupts last
if State (SIGINT) /= User then
Keep_Unmasked (SIGINT) := True;
Reserve (SIGINT) := True;
end if;
-- Check all signals for state that requires keeping them
-- unmasked and reserved
for J in Interrupt_ID'Range loop
if State (J) = Default or else State (J) = Runtime then
Keep_Unmasked (J) := True;
Reserve (J) := True;
end if;
end loop;
-- Add the set of signals that must always be unmasked for this target
for J in Unmasked'Range loop
Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
Reserve (Interrupt_ID (Unmasked (J))) := True;
end loop;
-- Add target-specific reserved signals
for J in Reserved'Range loop
Reserve (Interrupt_ID (Reserved (J))) := True;
end loop;
-- Process pragma Unreserve_All_Interrupts. This overrides any
-- settings due to pragma Interrupt_State:
if Unreserve_All_Interrupts /= 0 then
Keep_Unmasked (SIGINT) := False;
Reserve (SIGINT) := False;
end if;
-- We do not have Signal 0 in reality. We just use this value
-- to identify non-existent signals (see s-intnam.ads). Therefore,
-- Signal 0 should not be used in all signal related operations hence
-- mark it as reserved.
Reserve (0) := True;
end;
end System.Interrupt_Management;
gcc/ada/s-osinte-fsu.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 --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- 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. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a FSU Threads 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;
-------------
-- sigwait --
-------------
-- FSU_THREADS has a nonstandard sigwait
function sigwait
(set : access sigset_t;
sig : access Signal) return int
is
Result : int;
function sigwait_base (set : access sigset_t) return int;
pragma Import (C, sigwait_base, "sigwait");
begin
Result := sigwait_base (set);
if Result = -1 then
sig.all := 0;
return errno;
end if;
sig.all := Signal (Result);
return 0;
end sigwait;
------------------------
-- pthread_mutex_lock --
------------------------
-- FSU_THREADS has nonstandard pthread_mutex_lock and unlock.
-- It sets errno but the standard Posix requires it to be returned.
function pthread_mutex_lock (mutex : access pthread_mutex_t) return int is
function pthread_mutex_lock_base
(mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_mutex_lock_base, "pthread_mutex_lock");
Result : int;
begin
Result := pthread_mutex_lock_base (mutex);
if Result /= 0 then
return errno;
end if;
return 0;
end pthread_mutex_lock;
--------------------------
-- pthread_mutex_unlock --
--------------------------
function pthread_mutex_unlock
(mutex : access pthread_mutex_t) return int
is
function pthread_mutex_unlock_base
(mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_mutex_unlock_base, "pthread_mutex_unlock");
Result : int;
begin
Result := pthread_mutex_unlock_base (mutex);
if Result /= 0 then
return errno;
end if;
return 0;
end pthread_mutex_unlock;
-----------------------
-- pthread_cond_wait --
-----------------------
-- FSU_THREADS has a nonstandard pthread_cond_wait.
-- The FSU_THREADS version returns EINTR when interrupted.
function pthread_cond_wait
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t) return int
is
function pthread_cond_wait_base
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t) return int;
pragma Import (C, pthread_cond_wait_base, "pthread_cond_wait");
Result : int;
begin
Result := pthread_cond_wait_base (cond, mutex);
if Result = EINTR then
return 0;
else
return Result;
end if;
end pthread_cond_wait;
----------------------------
-- pthread_cond_timedwait --
----------------------------
-- FSU_THREADS has a nonstandard pthread_cond_timedwait. The
-- FSU_THREADS version returns -1 and set errno to EAGAIN for timeout.
function pthread_cond_timedwait
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t;
abstime : access timespec) return int
is
function pthread_cond_timedwait_base
(cond : access pthread_cond_t;
mutex : access pthread_mutex_t;
abstime : access timespec) return int;
pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait");
Result : int;
begin
Result := pthread_cond_timedwait_base (cond, mutex, abstime);
if Result = -1 then
if errno = EAGAIN then
return ETIMEDOUT;
else
return EINVAL;
end if;
end if;
return 0;
end pthread_cond_timedwait;
---------------------------
-- pthread_setschedparam --
---------------------------
-- FSU_THREADS does not have pthread_setschedparam
-- This routine returns a non-negative value upon failure
-- but the error code can not be set conforming the POSIX standard.
function pthread_setschedparam
(thread : pthread_t;
policy : int;
param : access struct_sched_param) return int
is
function pthread_setschedattr
(thread : pthread_t;
attr : pthread_attr_t) return int;
pragma Import (C, pthread_setschedattr, "pthread_setschedattr");
attr : aliased pthread_attr_t;
Result : int;
begin
Result := pthread_attr_init (attr'Access);
if Result /= 0 then
return Result;
end if;
attr.sched := policy;
-- Short-cut around pthread_attr_setprio
attr.prio := param.sched_priority;
Result := pthread_setschedattr (thread, attr);
if Result /= 0 then
return Result;
end if;
Result := pthread_attr_destroy (attr'Access);
if Result /= 0 then
return Result;
else
return 0;
end if;
end pthread_setschedparam;
-------------------------
-- pthread_getspecific --
-------------------------
-- FSU_THREADS has a nonstandard pthread_getspecific
function pthread_getspecific (key : pthread_key_t) return System.Address is
function pthread_getspecific_base
(key : pthread_key_t;
value : access System.Address) return int;
pragma Import (C, pthread_getspecific_base, "pthread_getspecific");
Tmp : aliased System.Address;
Result : int;
begin
Result := pthread_getspecific_base (key, Tmp'Access);
if Result /= 0 then
return System.Null_Address;
end if;
return Tmp;
end pthread_getspecific;
---------------------------------
-- pthread_attr_setdetachstate --
---------------------------------
function pthread_attr_setdetachstate
(attr : access pthread_attr_t;
detachstate : int) return int
is
function pthread_attr_setdetachstate_base
(attr : access pthread_attr_t;
detachstate : access int) return int;
pragma Import
(C, pthread_attr_setdetachstate_base, "pthread_attr_setdetachstate");
Tmp : aliased int := detachstate;
begin
return pthread_attr_setdetachstate_base (attr, Tmp'Access);
end pthread_attr_setdetachstate;
-----------------
-- sched_yield --
-----------------
-- FSU_THREADS does not have sched_yield;
function sched_yield return int is
procedure sched_yield_base (arg : System.Address);
pragma Import (C, sched_yield_base, "pthread_yield");
begin
sched_yield_base (System.Null_Address);
return 0;
end sched_yield;
----------------
-- Stack_Base --
----------------
function Get_Stack_Base (thread : pthread_t) return Address is
begin
return thread.stack_base;
end Get_Stack_Base;
end System.OS_Interface;
gcc/ada/s-osprim-posix.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . O S _ P R I M I T I V E S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2003 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. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This version is for POSIX-like operating systems
package body System.OS_Primitives is
-- ??? These definitions are duplicated from System.OS_Interface
-- because we don't want to depend on any package. Consider removing
-- these declarations in System.OS_Interface and move these ones in
-- the spec.
type struct_timezone is record
tz_minuteswest : Integer;
tz_dsttime : Integer;
end record;
pragma Convention (C, struct_timezone);
type struct_timezone_ptr is access all struct_timezone;
type time_t is new Long_Integer;
type struct_timeval is record
tv_sec : time_t;
tv_usec : Long_Integer;
end record;
pragma Convention (C, struct_timeval);
function gettimeofday
(tv : access struct_timeval;
tz : struct_timezone_ptr) return Integer;
pragma Import (C, gettimeofday, "gettimeofday");
type timespec is record
tv_sec : time_t;
tv_nsec : Long_Integer;
end record;
pragma Convention (C, timespec);
function nanosleep (rqtp, rmtp : access timespec) return Integer;
pragma Import (C, nanosleep, "nanosleep");
-----------
-- Clock --
-----------
function Clock return Duration is
TV : aliased struct_timeval;
Result : Integer;
pragma Unreferenced (Result);
begin
Result := gettimeofday (TV'Access, null);
return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6;
end Clock;
---------------------
-- Monotonic_Clock --
---------------------
function Monotonic_Clock return Duration renames Clock;
-----------------
-- To_Timespec --
-----------------
function To_Timespec (D : Duration) return 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_Integer (Long_Long_Integer (F * 10#1#E9)));
end To_Timespec;
-----------------
-- Timed_Delay --
-----------------
procedure Timed_Delay
(Time : Duration;
Mode : Integer)
is
Request : aliased timespec;
Remaind : aliased timespec;
Rel_Time : Duration;
Abs_Time : Duration;
Check_Time : Duration := Clock;
Result : Integer;
pragma Unreferenced (Result);
begin
if Mode = Relative then
Rel_Time := Time;
Abs_Time := Time + Check_Time;
else
Rel_Time := Time - Check_Time;
Abs_Time := Time;
end if;
if Rel_Time > 0.0 then
loop
Request := To_Timespec (Rel_Time);
Result := nanosleep (Request'Access, Remaind'Access);
Check_Time := Clock;
exit when Abs_Time <= Check_Time;
Rel_Time := Abs_Time - Check_Time;
end loop;
end if;
end Timed_Delay;
end System.OS_Primitives;
gcc/ada/s-stchop-vxworks.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2004 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. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is the VxWorks version of this package.
-- This file should be kept synchronized with the general implementation
-- provided by s-stchop.adb.
pragma Restrictions (No_Elaboration_Code);
-- We want to guarantee the absence of elaboration code because the
-- binder does not handle references to this package.
with Ada.Exceptions;
with System.Storage_Elements; use System.Storage_Elements;
with System.Parameters; use System.Parameters;
with System.Soft_Links;
with Interfaces.C;
with System.OS_Interface;
package body System.Stack_Checking.Operations is
-- In order to have stack checking working appropriately on
-- VxWorks we need to extract the stack size information from the
-- VxWorks kernel itself. It means that the library for showing
-- task-related information needs to be linked into the VxWorks
-- system, when using stack checking. The TaskShow library can be
-- linked into the VxWorks system by either:
-- * defining INCLUDE_SHOW_ROUTINES in config.h when using
-- configuration header files, or
-- * selecting INCLUDE_TASK_SHOW when using the Tornado project
-- facility.
function Set_Stack_Info (Stack : access Stack_Access) return Stack_Access;
-- The function Set_Stack_Info is the actual function that updates
-- the cache containing a pointer to the Stack_Info. It may also
-- be used for detecting asynchronous abort in combination with
-- Invalidate_Self_Cache.
-- Set_Stack_Info should do the following things in order:
-- 1) Get the Stack_Access value for the current task
-- 2) Set Stack.all to the value obtained in 1)
-- 3) Optionally Poll to check for asynchronous abort
-- This order is important because if at any time a write to
-- the stack cache is pending, that write should be followed
-- by a Poll to prevent loosing signals.
-- Note: This function must be compiled with Polling turned off
-- Note: on systems like VxWorks and OS/2 with real thread-local storage,
-- Set_Stack_Info should return an access value for such local
-- storage. In those cases the cache will always be up-to-date.
-- The following constants should be imported from some system-specific
-- constants package. The constants must be static for performance reasons.
----------------------------
-- Invalidate_Stack_Cache --
----------------------------
procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is
pragma Warnings (Off, Any_Stack);
begin
Cache := Null_Stack;
end Invalidate_Stack_Cache;
--------------------
-- Set_Stack_Info --
--------------------
function Set_Stack_Info
(Stack : access Stack_Access) return Stack_Access
is
-- Task descriptor that is handled internally by the VxWorks kernel
type Task_Descriptor is record
T_Id : Interfaces.C.int; -- task identifier
Td_Name : System.Address; -- task name
Td_Priority : Interfaces.C.int; -- task priority
Td_Status : Interfaces.C.int; -- task status
Td_Options : Interfaces.C.int; -- task option bits (see below)
Td_Entry : System.Address; -- original entry point of task
Td_Sp : System.Address; -- saved stack pointer
Td_PStackBase : System.Address; -- the bottom of the stack
Td_PStackLimit : System.Address; -- the effective end of the stack
Td_PStackEnd : System.Address; -- the actual end of the stack
Td_StackSize : Interfaces.C.int; -- size of stack in bytes
Td_StackCurrent : Interfaces.C.int; -- current stack usage in bytes
Td_StackHigh : Interfaces.C.int; -- maximum stack usage in bytes
Td_StackMargin : Interfaces.C.int; -- current stack margin in bytes
Td_ErrorStatus : Interfaces.C.int; -- most recent task error status
Td_Delay : Interfaces.C.int; -- delay/timeout ticks
end record;
-- This VxWorks procedure fills in a specified task descriptor
-- for a specified task.
procedure TaskInfoGet (T_Id : System.OS_Interface.t_id;
Task_Desc : access Task_Descriptor);
pragma Import (C, TaskInfoGet, "taskInfoGet");
My_Stack : Stack_Access;
Task_Desc : aliased Task_Descriptor;
begin
-- The order of steps 1 .. 3 is important, see specification.
-- 1) Get the Stack_Access value for the current task
My_Stack := Soft_Links.Get_Stack_Info.all;
if My_Stack.Base = Null_Address then
-- First invocation. Ask the VxWorks kernel about stack
-- values.
TaskInfoGet (System.OS_Interface.taskIdSelf, Task_Desc'Access);
My_Stack.Size := System.Storage_Elements.Storage_Offset
(Task_Desc.Td_StackSize);
My_Stack.Base := Task_Desc.Td_PStackBase;
My_Stack.Limit := Task_Desc.Td_PStackLimit;
end if;
-- 2) Set Stack.all to the value obtained in 1)
Stack.all := My_Stack;
-- 3) Optionally Poll to check for asynchronous abort
if Soft_Links.Check_Abort_Status.all /= 0 then
raise Standard'Abort_Signal;
end if;
return My_Stack; -- Never trust the cached value, but return local copy!
end Set_Stack_Info;
--------------------
-- Set_Stack_Size --
--------------------
-- Specify the stack size for the current frame.
procedure Set_Stack_Size
(Stack_Size : System.Storage_Elements.Storage_Offset)
is
My_Stack : Stack_Access;
Frame_Address : constant System.Address := My_Stack'Address;
begin
My_Stack := Stack_Check (Frame_Address);
if Stack_Grows_Down then
My_Stack.Limit := My_Stack.Base - Stack_Size;
else
My_Stack.Limit := My_Stack.Base + Stack_Size;
end if;
end Set_Stack_Size;
-----------------
-- Stack_Check --
-----------------
function Stack_Check
(Stack_Address : System.Address) return Stack_Access
is
type Frame_Marker is null record;
Marker : Frame_Marker;
Cached_Stack : constant Stack_Access := Cache;
Frame_Address : constant System.Address := Marker'Address;
begin
-- This function first does a "cheap" check which is correct
-- if it succeeds. In case of failure, the full check is done.
-- Ideally the cheap check should be done in an optimized manner,
-- or be inlined.
if (Stack_Grows_Down and then
(Frame_Address <= Cached_Stack.Base
and
Stack_Address > Cached_Stack.Limit))
or else
(not Stack_Grows_Down and then
(Frame_Address >= Cached_Stack.Base
and
Stack_Address < Cached_Stack.Limit))
then
-- Cached_Stack is valid as it passed the stack check
return Cached_Stack;
end if;
Full_Check :
declare
My_Stack : constant Stack_Access := Set_Stack_Info (Cache'Access);
-- At this point Stack.all might already be invalid, so
-- it is essential to use our local copy of Stack!
begin
if (Stack_Grows_Down and then
Stack_Address < My_Stack.Limit)
or else
(not Stack_Grows_Down and then
Stack_Address > My_Stack.Limit)
then
Ada.Exceptions.Raise_Exception
(E => Storage_Error'Identity,
Message => "stack overflow detected");
end if;
return My_Stack;
end Full_Check;
end Stack_Check;
------------------------
-- Update_Stack_Cache --
------------------------
procedure Update_Stack_Cache (Stack : Stack_Access) is
begin
if not Multi_Processor then
Cache := Stack;
end if;
end Update_Stack_Cache;
end System.Stack_Checking.Operations;
gcc/ada/s-taspri-posix.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 --
-- --
-- Copyright (C) 1991-1994, Florida State University --
-- Copyright (C) 1995-2003, Ada Core Technologies --
-- --
-- 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. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a POSIX-like version of this package.
-- Note: this file can only be used for POSIX compliant systems.
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 new System.OS_Interface.pthread_mutex_t;
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.
LWP : aliased System.Address;
-- The purpose of this field is to provide a better tasking support on
-- gdb. The order of the two first fields (Thread and LWP) is important.
-- On targets where lwp is not relevant, this is equivalent to Thread.
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/s-taspri-vxworks.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 --
-- --
-- Copyright (C) 2001-2002 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. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a VxWorks 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 System.OS_Interface;
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 Priority_Type is (Prio_None, Prio_Protect, Prio_Inherit);
type Lock is record
Mutex : System.OS_Interface.SEM_ID;
Protocol : Priority_Type;
Prio_Ceiling : System.OS_Interface.int;
-- priority ceiling of lock
end record;
type RTS_Lock is new Lock;
type Private_Data is record
Thread : aliased System.OS_Interface.t_id := 0;
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.
LWP : aliased System.Address;
-- The purpose of this field is to provide a better tasking support on
-- gdb. The order of the two first fields (Thread and LWP) is important.
-- On targets where lwp is not relevant, this is equivalent to Thread.
CV : aliased System.OS_Interface.SEM_ID;
L : aliased RTS_Lock;
-- Protection for all components is lock L
end record;
end System.Task_Primitives;
gcc/ada/s-tfsetr-default.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T R A C E S . S E N D --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2002 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. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This version is for all targets, provided that System.IO.Put_Line is
-- functional. It prints debug information to Standard Output
with System.IO; use System.IO;
with GNAT.Regpat; use GNAT.Regpat;
----------------
-- Send_Trace --
----------------
-- Prints debug information both in a human readable form
-- and in the form they are sent from upper layers.
separate (System.Traces.Format)
procedure Send_Trace (Id : Trace_T; Info : String) is
type Param_Type is
(Name_Param,
Caller_Param,
Entry_Param,
Timeout_Param,
Acceptor_Param,
Parent_Param,
Number_Param);
-- Type of parameter found in the message
Info_Trace : String_Trace := Format_Trace (Info);
function Get_Param
(Input : String_Trace;
Param : Param_Type;
How_Many : Integer)
return String;
-- Extract a parameter from the given input string
---------------
-- Get_Param --
---------------
function Get_Param
(Input : String_Trace;
Param : Param_Type;
How_Many : Integer)
return String
is
pragma Unreferenced (How_Many);
Matches : Match_Array (1 .. 2);
begin
-- We need comments here ???
case Param is
when Name_Param =>
Match ("/N:([\w]+)", Input, Matches);
when Caller_Param =>
Match ("/C:([\w]+)", Input, Matches);
when Entry_Param =>
Match ("/E:([\s]*) +([0-9 ,]+)", Input, Matches);
when Timeout_Param =>
Match ("/T:([\s]*) +([0-9]+.[0-9]+)", Input, Matches);
when Acceptor_Param =>
Match ("/A:([\w]+)", Input, Matches);
when Parent_Param =>
Match ("/P:([\w]+)", Input, Matches);
when Number_Param =>
Match ("/#:([\s]*) +([0-9]+)", Input, Matches);
end case;
if Matches (1).First < Input'First then
return "";
end if;
case Param is
when Timeout_Param | Entry_Param | Number_Param =>
return Input (Matches (2).First .. Matches (2).Last);
when others =>
return Input (Matches (1).First .. Matches (1).Last);
end case;
end Get_Param;
-- Start of processing for Send_Trace
begin
New_Line;
Put_Line ("- Trace Debug Info ----------------");
Put ("Caught event Id : ");
case Id is
when M_Accept_Complete => Put ("M_Accept_Complete");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " completes accept on entry "
& Get_Param (Info_Trace, Entry_Param, 1) & " with "
& Get_Param (Info_Trace, Caller_Param, 1));
when M_Select_Else => Put ("M_Select_Else");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " selects else statement");
when M_RDV_Complete => Put ("M_RDV_Complete");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " completes rendezvous with "
& Get_Param (Info_Trace, Caller_Param, 1));
when M_Call_Complete => Put ("M_Call_Complete");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " completes call");
when M_Delay => Put ("M_Delay");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " completes delay "
& Get_Param (Info_Trace, Timeout_Param, 1));
when E_Missed => Put ("E_Missed");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " got an invalid acceptor "
& Get_Param (Info_Trace, Acceptor_Param, 1));
when E_Timeout => Put ("E_Timeout");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " ends select due to timeout ");
when E_Kill => Put ("E_Kill");
New_Line;
Put_Line ("Asynchronous Transfer of Control on task "
& Get_Param (Info_Trace, Name_Param, 1));
when W_Delay => Put ("W_Delay");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " sleeping "
& Get_Param (Info_Trace, Timeout_Param, 1)
& " seconds");
when WU_Delay => Put ("WU_Delay");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " sleeping until "
& Get_Param (Info_Trace, Timeout_Param, 1));
when W_Call => Put ("W_Call");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " calling entry "
& Get_Param (Info_Trace, Entry_Param, 1)
& " of " & Get_Param (Info_Trace, Acceptor_Param, 1));
when W_Accept => Put ("W_Accept");
New_Line;
Put ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " waiting on "
& Get_Param (Info_Trace, Number_Param, 1)
& " accept(s)"
& ", " & Get_Param (Info_Trace, Entry_Param, 1));
New_Line;
when W_Select => Put ("W_Select");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " waiting on "
& Get_Param (Info_Trace, Number_Param, 1)
& " select(s)"
& ", " & Get_Param (Info_Trace, Entry_Param, 1));
New_Line;
when W_Completion => Put ("W_Completion");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " waiting for completion ");
when WT_Select => Put ("WT_Select");
New_Line;
Put ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " waiting " & Get_Param (Info_Trace, Timeout_Param, 1)
& " seconds on "
& Get_Param (Info_Trace, Number_Param, 1)
& " select(s)");
if Get_Param (Info_Trace, Number_Param, 1) /= "" then
Put (", " & Get_Param (Info_Trace, Entry_Param, 1));
end if;
New_Line;
when WT_Call => Put ("WT_Call");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " calling entry "
& Get_Param (Info_Trace, Entry_Param, 1)
& " of " & Get_Param (Info_Trace, Acceptor_Param, 1)
& " with timeout "
& Get_Param (Info_Trace, Timeout_Param, 1));
when WT_Completion => Put ("WT_Completion");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " waiting "
& Get_Param (Info_Trace, Timeout_Param, 1)
& " for call completion");
when PO_Call => Put ("PO_Call");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " calling protected entry "
& Get_Param (Info_Trace, Entry_Param, 1));
when POT_Call => Put ("POT_Call");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " calling protected entry "
& Get_Param (Info_Trace, Entry_Param, 1)
& " with timeout "
& Get_Param (Info_Trace, Timeout_Param, 1));
when PO_Run => Put ("PO_Run");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " running entry "
& Get_Param (Info_Trace, Entry_Param, 1)
& " for "
& Get_Param (Info_Trace, Caller_Param, 1));
when PO_Done => Put ("PO_Done");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " finished call from "
& Get_Param (Info_Trace, Caller_Param, 1));
when PO_Lock => Put ("PO_Lock");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " took lock");
when PO_Unlock => Put ("PO_Unlock");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " released lock");
when T_Create => Put ("T_Create");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " created");
when T_Activate => Put ("T_Activate");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " activated");
when T_Abort => Put ("T_Abort");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " aborted by "
& Get_Param (Info_Trace, Parent_Param, 1));
when T_Terminate => Put ("T_Terminate");
New_Line;
Put_Line ("Task " & Get_Param (Info_Trace, Name_Param, 1)
& " terminated");
when others
=> Put ("Invalid Id");
end case;
Put_Line (" --> " & Info_Trace);
Put_Line ("-----------------------------------");
New_Line;
end Send_Trace;
gcc/ada/s-tfsetr-vxworks.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T R A C E S . S E N D --
-- --
-- B o d y --
-- --
-- Copyright (C) 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. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This version is for VxWorks targets.
-- Trace information is sent to WindView using the wvEvent function.
-- Note that wvEvent is from the VxWorks API.
-- When adding a new event, just give an Id to then event, and then modify
-- the WindView events database.
-- Refer to WindView User's Guide for more details on how to add new events
-- to the events database.
----------------
-- Send_Trace --
----------------
-- This procedure formats the string, maps the event Id to an Id
-- recognized by WindView, and send the event using wvEvent
separate (System.Traces.Format)
procedure Send_Trace (Id : Trace_T; Info : String) is
procedure Wv_Event
(Id : Integer;
Buffer : System.Address;
Size : Integer);
pragma Import (C, Wv_Event, "wvEvent");
Info_Trace : String_Trace;
Id_Event : Integer;
begin
Info_Trace := Format_Trace (Info);
case Id is
when M_Accept_Complete => Id_Event := 30000;
when M_Select_Else => Id_Event := 30001;
when M_RDV_Complete => Id_Event := 30002;
when M_Call_Complete => Id_Event := 30003;
when M_Delay => Id_Event := 30004;
when E_Kill => Id_Event := 30005;
when E_Missed => Id_Event := 30006;
when E_Timeout => Id_Event := 30007;
when W_Call => Id_Event := 30010;
when W_Accept => Id_Event := 30011;
when W_Select => Id_Event := 30012;
when W_Completion => Id_Event := 30013;
when W_Delay => Id_Event := 30014;
when WT_Select => Id_Event := 30015;
when WT_Call => Id_Event := 30016;
when WT_Completion => Id_Event := 30017;
when WU_Delay => Id_Event := 30018;
when PO_Call => Id_Event := 30020;
when POT_Call => Id_Event := 30021;
when PO_Run => Id_Event := 30022;
when PO_Lock => Id_Event := 30023;
when PO_Unlock => Id_Event := 30024;
when PO_Done => Id_Event := 30025;
when T_Create => Id_Event := 30030;
when T_Activate => Id_Event := 30031;
when T_Abort => Id_Event := 30032;
when T_Terminate => Id_Event := 30033;
-- Unrecognized events are given the special Id_Event value 29999
when others => Id_Event := 29999;
end case;
Wv_Event (Id_Event, Info_Trace'Address, Max_Size);
end Send_Trace;
gcc/ada/s-tpopsp-posix.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, Free Software Fundation, 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. --
-- Extensive contributions were provided by Ada Core Technologies, Inc. --
-- --
------------------------------------------------------------------------------
-- This is a POSIX-like version of this package.
separate (System.Task_Primitives.Operations)
package body Specific is
----------------
-- Initialize --
----------------
procedure Initialize (Environment_Task : Task_ID) is
pragma Warnings (Off, Environment_Task);
Result : Interfaces.C.int;
begin
Result := pthread_key_create (ATCB_Key'Access, null);
pragma Assert (Result = 0);
end Initialize;
-------------------
-- Is_Valid_Task --
-------------------
function Is_Valid_Task return Boolean is
begin
return pthread_getspecific (ATCB_Key) /= System.Null_Address;
end Is_Valid_Task;
---------
-- Set --
---------
procedure Set (Self_Id : Task_ID) is
Result : Interfaces.C.int;
begin
Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
pragma Assert (Result = 0);
end Set;
----------
-- Self --
----------
function Self return Task_ID is
begin
return To_Task_ID (pthread_getspecific (ATCB_Key));
end Self;
end Specific;
gcc/ada/s-traceb-mastop.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S Y S T E M . T R A C E B A C K --
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2003 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. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This version assumes that System.Machine_State_Operations.Pop_Frame can
-- work with the Info parameter being null.
with System.Machine_State_Operations;
package body System.Traceback is
use System.Machine_State_Operations;
----------------
-- Call_Chain --
----------------
procedure Call_Chain
(Traceback : System.Address;
Max_Len : Natural;
Len : out Natural;
Exclude_Min : System.Address := System.Null_Address;
Exclude_Max : System.Address := System.Null_Address;
Skip_Frames : Natural := 1)
is
type Tracebacks_Array is array (1 .. Max_Len) of Code_Loc;
pragma Suppress_Initialization (Tracebacks_Array);
M : Machine_State;
Code : Code_Loc;
Trace : Tracebacks_Array;
for Trace'Address use Traceback;
N_Skips : Natural := 0;
begin
M := Allocate_Machine_State;
Set_Machine_State (M);
-- Skip the requested number of frames
loop
Code := Get_Code_Loc (M);
exit when Code = Null_Address or else N_Skips = Skip_Frames;
Pop_Frame (M, System.Null_Address);
N_Skips := N_Skips + 1;
end loop;
-- Now, record the frames outside the exclusion bounds, updating
-- the Len output value along the way.
Len := 0;
loop
Code := Get_Code_Loc (M);
exit when Code = Null_Address or else Len = Max_Len;
if Code < Exclude_Min or else Code > Exclude_Max then
Len := Len + 1;
Trace (Len) := Code;
end if;
Pop_Frame (M, System.Null_Address);
end loop;
Free_Machine_State (M);
end Call_Chain;
------------------
-- C_Call_Chain --
------------------
function C_Call_Chain
(Traceback : System.Address;
Max_Len : Natural) return Natural
is
Val : Natural;
begin
Call_Chain (Traceback, Max_Len, Val);
return Val;
end C_Call_Chain;
end System.Traceback;
gcc/ada/s-traces-default.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T R A C E S --
-- --
-- B o d y --
-- --
-- Copyright (C) 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. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with System.Soft_Links;
with System.Parameters;
with System.Traces.Format;
package body System.Traces is
package SSL renames System.Soft_Links;
use System.Traces.Format;
----------------------
-- Send_Trace_Info --
----------------------
procedure Send_Trace_Info (Id : Trace_T) is
Task_S : String := SSL.Task_Name.all;
Trace_S : String (1 .. 3 + Task_S'Length);
begin
if Parameters.Runtime_Traces then
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. Trace_S'Last) := Task_S;
Send_Trace (Id, Trace_S);
end if;
end Send_Trace_Info;
procedure Send_Trace_Info (Id : Trace_T; Timeout : Duration) is
Task_S : String := SSL.Task_Name.all;
Timeout_S : String := Duration'Image (Timeout);
Trace_S : String (1 .. 6 + Task_S'Length + Timeout_S'Length);
begin
if Parameters.Runtime_Traces then
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + Task_S'Length) := Task_S;
Trace_S (4 + Task_S'Length .. 6 + Task_S'Length) := "/T:";
Trace_S (7 + Task_S'Length .. Trace_S'Last) := Timeout_S;
Send_Trace (Id, Trace_S);
end if;
end Send_Trace_Info;
end System.Traces;
gcc/ada/s-trafor-default.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T R A C E S . F O R M A T --
-- --
-- B o d y --
-- --
-- Copyright (C) 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. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with System.Parameters;
package body System.Traces.Format is
procedure Send_Trace (Id : Trace_T; Info : String) is separate;
------------------
-- Format_Trace --
------------------
function Format_Trace (Source : in String) return String_Trace is
Length : Integer := Source'Length;
Result : String_Trace := (others => ' ');
begin
-- If run-time tracing active, then fill the string
if Parameters.Runtime_Traces then
if Max_Size - Length > 0 then
Result (1 .. Length) := Source (1 .. Length);
Result (Length + 1 .. Max_Size) := (others => ' ');
Result (Length + 1) := ASCII.NUL;
else
Result (1 .. Max_Size - 1) := Source (1 .. Max_Size - 1);
Result (Max_Size) := ASCII.NUL;
end if;
end if;
return Result;
end Format_Trace;
------------
-- Append --
------------
function Append
(Source : String_Trace;
Annex : String)
return String_Trace
is
Result : String_Trace := (others => ' ');
Source_Length : Integer := 1;
Annex_Length : Integer := Annex'Length;
begin
if Parameters.Runtime_Traces then
-- First we determine the size used, without the spaces at the
-- end, if a String_Trace is present. Look at
-- System.Traces.Tasking for examples.
while Source (Source_Length) /= ASCII.NUL loop
Source_Length := Source_Length + 1;
end loop;
-- Then we fill the string.
if Source_Length - 1 + Annex_Length <= Max_Size then
Result (1 .. Source_Length - 1) :=
Source (1 .. Source_Length - 1);
Result (Source_Length .. Source_Length - 1 + Annex_Length) :=
Annex (1 .. Annex_Length);
Result (Source_Length + Annex_Length) := ASCII.NUL;
Result (Source_Length + Annex_Length + 1 .. Max_Size) :=
(others => ' ');
else
Result (1 .. Source_Length - 1) := Source (1 .. Source_Length - 1);
Result (Source_Length .. Max_Size - 1) :=
Annex (1 .. Max_Size - Source_Length);
Result (Max_Size) := ASCII.NUL;
end if;
end if;
return Result;
end Append;
end System.Traces.Format;
gcc/ada/s-trafor-default.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T R A C E S . F O R M A T --
-- --
-- S p e c --
-- --
-- Copyright (C) 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. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package implements functions to format run-time traces
package System.Traces.Format is
Max_Size : constant Integer := 128;
-- Event messages' maximum size.
subtype String_Trace is String (1 .. Max_Size);
-- Specific type in which trace information is stored. An ASCII.NUL
-- character ends the string so that it is compatible with C strings
-- which is useful on some targets (eg. VxWorks)
-- These private functions handles String_Trace formatting
function Format_Trace (Source : String) return String_Trace;
-- Put a String in a String_Trace, truncates the string if necessary.
-- Similar to Head( .. ) found in Ada.Strings.Bounded
function Append
(Source : String_Trace;
Annex : String)
return String_Trace;
pragma Inline (Append);
-- Concatenates two string, similar to & operator from Ada.String.Unbounded
procedure Send_Trace (Id : Trace_T; Info : String);
-- This function (which is a subunit) send messages to external programs
end System.Traces.Format;
gcc/ada/s-tratas-default.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
-- S Y S T E M . T R A C E S . T A S K I N G --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2002 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. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with System.Tasking; use System.Tasking;
with System.Soft_Links;
with System.Parameters;
with System.Traces.Format; use System.Traces.Format;
with System.Traces; use System.Traces;
package body System.Traces.Tasking is
use System.Tasking;
use System.Traces;
use System.Traces.Format;
package SSL renames System.Soft_Links;
function Extract_Accepts (Task_Name : Task_ID) return String_Trace;
-- This function is used to extract data joined with
-- W_Select, WT_Select, W_Accept events
---------------------
-- Send_Trace_Info --
---------------------
procedure Send_Trace_Info (Id : Trace_T; Task_Name2 : Task_ID) is
Task_S : constant String := SSL.Task_Name.all;
Task2_S : constant String :=
Task_Name2.Common.Task_Image
(1 .. Task_Name2.Common.Task_Image_Len);
Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length);
L0 : Integer := Task_S'Length;
L1 : Integer := Task2_S'Length;
begin
if Parameters.Runtime_Traces then
case Id is
when M_RDV_Complete | PO_Done =>
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/C:";
Trace_S (7 + L0 .. Trace_S'Last) := Task2_S;
Send_Trace (Id, Trace_S);
when E_Missed =>
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/A:";
Trace_S (7 + L0 .. Trace_S'Last) := Task2_S;
Send_Trace (Id, Trace_S);
when E_Kill =>
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L1) := Task2_S;
Trace_S (4 + L1 .. Trace_S'Last) := (others => ' ');
Send_Trace (Id, Trace_S);
when T_Create =>
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L1) := Task2_S;
Trace_S (4 + L1 .. Trace_S'Last) := (others => ' ');
Send_Trace (Id, Trace_S);
when others =>
null;
-- should raise an exception ???
end case;
end if;
end Send_Trace_Info;
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name2 : Task_ID;
Entry_Number : Entry_Index)
is
Task_S : constant String := SSL.Task_Name.all;
Task2_S : constant String :=
Task_Name2.Common.Task_Image
(1 .. Task_Name2.Common.Task_Image_Len);
Entry_S : String := Integer'Image (Integer (Entry_Number));
Trace_S : String (1 .. 9 + Task_S'Length
+ Task2_S'Length + Entry_S'Length);
L0 : Integer := Task_S'Length;
L1 : Integer := Task_S'Length + Entry_S'Length;
L2 : Integer := Task_S'Length + Task2_S'Length;
begin
if Parameters.Runtime_Traces then
case Id is
when M_Accept_Complete =>
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/E:";
Trace_S (7 + L0 .. 6 + L1) := Entry_S;
Trace_S (7 + L1 .. 9 + L1) := "/C:";
Trace_S (10 + L1 .. Trace_S'Last) := Task2_S;
Send_Trace (Id, Trace_S);
when W_Call =>
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/A:";
Trace_S (7 + L0 .. 6 + L2) := Task2_S;
Trace_S (7 + L2 .. 9 + L2) := "/C:";
Trace_S (10 + L2 .. Trace_S'Last) := Entry_S;
Send_Trace (Id, Trace_S);
when others =>
null;
-- should raise an exception ???
end case;
end if;
end Send_Trace_Info;
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : Task_ID;
Task_Name2 : Task_ID;
Entry_Number : Entry_Index)
is
Task_S : constant String :=
Task_Name.Common.Task_Image
(1 .. Task_Name.Common.Task_Image_Len);
Task2_S : constant String :=
Task_Name2.Common.Task_Image
(1 .. Task_Name2.Common.Task_Image_Len);
Entry_S : String := Integer'Image (Integer (Entry_Number));
Trace_S : String (1 .. 9 + Task_S'Length
+ Task2_S'Length + Entry_S'Length);
L0 : Integer := Task_S'Length;
L1 : Integer := Task_S'Length + Entry_S'Length;
begin
if Parameters.Runtime_Traces then
case Id is
when PO_Run =>
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/E:";
Trace_S (7 + L0 .. 6 + L1) := Entry_S;
Trace_S (7 + L1 .. 9 + L1) := "/C:";
Trace_S (10 + L1 .. Trace_S'Last) := Task2_S;
Send_Trace (Id, Trace_S);
when others =>
null;
-- should raise an exception ???
end case;
end if;
end Send_Trace_Info;
procedure Send_Trace_Info (Id : Trace_T; Entry_Number : Entry_Index) is
Task_S : String := SSL.Task_Name.all;
Entry_S : String := Integer'Image (Integer (Entry_Number));
Trace_S : String (1 .. 6 + Task_S'Length + Entry_S'Length);
L0 : Integer := Task_S'Length;
begin
if Parameters.Runtime_Traces then
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/E:";
Trace_S (7 + L0 .. Trace_S'Last) := Entry_S;
Send_Trace (Id, Trace_S);
end if;
end Send_Trace_Info;
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : Task_ID;
Task_Name2 : Task_ID)
is
Task_S : constant String :=
Task_Name.Common.Task_Image
(1 .. Task_Name.Common.Task_Image_Len);
Task2_S : constant String :=
Task_Name2.Common.Task_Image
(1 .. Task_Name2.Common.Task_Image_Len);
Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length);
L0 : Integer := Task2_S'Length;
begin
if Parameters.Runtime_Traces then
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task2_S;
Trace_S (4 + L0 .. 6 + L0) := "/P:";
Trace_S (7 + L0 .. Trace_S'Last) := Task_S;
Send_Trace (Id, Trace_S);
end if;
end Send_Trace_Info;
procedure Send_Trace_Info
(Id : Trace_T;
Acceptor : Task_ID;
Entry_Number : Entry_Index;
Timeout : Duration)
is
Task_S : constant String := SSL.Task_Name.all;
Acceptor_S : constant String :=
Acceptor.Common.Task_Image
(1 .. Acceptor.Common.Task_Image_Len);
Entry_S : String := Integer'Image (Integer (Entry_Number));
Timeout_S : String := Duration'Image (Timeout);
Trace_S : String (1 .. 12 + Task_S'Length + Acceptor_S'Length
+ Entry_S'Length + Timeout_S'Length);
L0 : Integer := Task_S'Length;
L1 : Integer := Task_S'Length + Acceptor_S'Length;
L2 : Integer := Task_S'Length + Acceptor_S'Length + Entry_S'Length;
begin
if Parameters.Runtime_Traces then
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/A:";
Trace_S (7 + L0 .. 6 + L1) := Acceptor_S;
Trace_S (7 + L1 .. 9 + L1) := "/E:";
Trace_S (10 + L1 .. 9 + L2) := Entry_S;
Trace_S (10 + L2 .. 12 + L2) := "/T:";
Trace_S (13 + L2 .. Trace_S'Last) := Timeout_S;
Send_Trace (Id, Trace_S);
end if;
end Send_Trace_Info;
procedure Send_Trace_Info
(Id : Trace_T;
Entry_Number : Entry_Index;
Timeout : Duration)
is
Task_S : String := SSL.Task_Name.all;
Entry_S : String := Integer'Image (Integer (Entry_Number));
Timeout_S : String := Duration'Image (Timeout);
Trace_S : String (1 .. 9 + Task_S'Length
+ Entry_S'Length + Timeout_S'Length);
L0 : Integer := Task_S'Length;
L1 : Integer := Task_S'Length + Entry_S'Length;
begin
if Parameters.Runtime_Traces then
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/E:";
Trace_S (7 + L0 .. 6 + L1) := Entry_S;
Trace_S (7 + L1 .. 9 + L1) := "/T:";
Trace_S (10 + L1 .. Trace_S'Last) := Timeout_S;
Send_Trace (Id, Trace_S);
end if;
end Send_Trace_Info;
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : Task_ID;
Number : Integer)
is
Task_S : String := SSL.Task_Name.all;
Number_S : String := Integer'Image (Number);
Accepts_S : String := Extract_Accepts (Task_Name);
Trace_S : String (1 .. 9 + Task_S'Length
+ Number_S'Length + Accepts_S'Length);
L0 : Integer := Task_S'Length;
L1 : Integer := Task_S'Length + Number_S'Length;
begin
if Parameters.Runtime_Traces then
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/#:";
Trace_S (7 + L0 .. 6 + L1) := Number_S;
Trace_S (7 + L1 .. 9 + L1) := "/E:";
Trace_S (10 + L1 .. Trace_S'Last) := Accepts_S;
Send_Trace (Id, Trace_S);
end if;
end Send_Trace_Info;
procedure Send_Trace_Info
(Id : Trace_T;
Task_Name : Task_ID;
Number : Integer;
Timeout : Duration)
is
Task_S : String := SSL.Task_Name.all;
Timeout_S : String := Duration'Image (Timeout);
Number_S : String := Integer'Image (Number);
Accepts_S : String := Extract_Accepts (Task_Name);
Trace_S : String (1 .. 12 + Task_S'Length + Timeout_S'Length
+ Number_S'Length + Accepts_S'Length);
L0 : Integer := Task_S'Length;
L1 : Integer := Task_S'Length + Timeout_S'Length;
L2 : Integer := Task_S'Length + Timeout_S'Length + Number_S'Length;
begin
if Parameters.Runtime_Traces then
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/T:";
Trace_S (7 + L0 .. 6 + L1) := Timeout_S;
Trace_S (7 + L1 .. 9 + L1) := "/#:";
Trace_S (10 + L1 .. 9 + L2) := Number_S;
Trace_S (10 + L2 .. 12 + L2) := "/E:";
Trace_S (13 + L2 .. Trace_S'Last) := Accepts_S;
Send_Trace (Id, Trace_S);
end if;
end Send_Trace_Info;
---------------------
-- Extract_Accepts --
---------------------
-- This function returns a string in which all opened
-- Accepts or Selects are given, separated by semi-colons.
function Extract_Accepts (Task_Name : Task_ID) return String_Trace is
Info_Annex : String_Trace := (ASCII.NUL, others => ' ');
begin
for J in Task_Name.Open_Accepts'First ..
Task_Name.Open_Accepts'Last - 1
loop
Info_Annex := Append (Info_Annex, Integer'Image
(Integer (Task_Name.Open_Accepts (J).S)) & ",");
end loop;
Info_Annex := Append (Info_Annex,
Integer'Image (Integer
(Task_Name.Open_Accepts
(Task_Name.Open_Accepts'Last).S)));
return Info_Annex;
end Extract_Accepts;
end System.Traces.Tasking;
gcc/ada/5hsystem.ads → gcc/ada/system-hpux.ads
...@@ -138,7 +138,7 @@ private ...@@ -138,7 +138,7 @@ private
Support_Long_Shifts : constant Boolean := True; Support_Long_Shifts : constant Boolean := True;
Suppress_Standard_Library : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False; ZCX_By_Default : constant Boolean := True;
GCC_ZCX_Support : constant Boolean := True; GCC_ZCX_Support : constant Boolean := True;
Front_End_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := False;
......
gcc/ada/5gsystem.ads → gcc/ada/system-irix-n32.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- (SGI Irix, n32 ABI) -- -- (SGI Irix, n32 ABI) --
-- -- -- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -138,8 +138,8 @@ private ...@@ -138,8 +138,8 @@ private
Support_Long_Shifts : constant Boolean := True; Support_Long_Shifts : constant Boolean := True;
Suppress_Standard_Library : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False; ZCX_By_Default : constant Boolean := True;
GCC_ZCX_Support : constant Boolean := False; GCC_ZCX_Support : constant Boolean := True;
Front_End_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := False;
-- Obsolete entries, to be removed eventually (bootstrap issues!) -- Obsolete entries, to be removed eventually (bootstrap issues!)
......
gcc/ada/5fsystem.ads → gcc/ada/system-irix-o32.ads
...@@ -138,8 +138,8 @@ private ...@@ -138,8 +138,8 @@ private
Support_Long_Shifts : constant Boolean := True; Support_Long_Shifts : constant Boolean := True;
Suppress_Standard_Library : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False; ZCX_By_Default : constant Boolean := True;
GCC_ZCX_Support : constant Boolean := False; GCC_ZCX_Support : constant Boolean := True;
Front_End_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := False;
-- Obsolete entries, to be removed eventually (bootstrap issues!) -- Obsolete entries, to be removed eventually (bootstrap issues!)
......
gcc/ada/5wsystem.ads → gcc/ada/system-mingw.ads
...@@ -139,7 +139,7 @@ private ...@@ -139,7 +139,7 @@ private
Suppress_Standard_Library : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False;
ZCX_By_Default : constant Boolean := False; ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False; GCC_ZCX_Support : constant Boolean := True;
Front_End_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := False;
-- Obsolete entries, to be removed eventually (bootstrap issues!) -- Obsolete entries, to be removed eventually (bootstrap issues!)
......
gcc/ada/system-vxworks-alpha.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M --
-- --
-- S p e c --
-- (VxWorks Version Alpha) --
-- --
-- Copyright (C) 1992-2003 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. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
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 := 1.0 / 60.0;
-- Storage-related Declarations
type Address is private;
Null_Address : constant Address;
Storage_Unit : constant := 8;
Word_Size : constant := 64;
Memory_Size : constant := 2 ** 64;
-- Address comparison
function "<" (Left, Right : Address) return Boolean;
function "<=" (Left, Right : Address) return Boolean;
function ">" (Left, Right : Address) return Boolean;
function ">=" (Left, Right : Address) return Boolean;
function "=" (Left, Right : Address) return Boolean;
pragma Import (Intrinsic, "<");
pragma Import (Intrinsic, "<=");
pragma Import (Intrinsic, ">");
pragma Import (Intrinsic, ">=");
pragma Import (Intrinsic, "=");
-- 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)
-- 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 .. 255;
subtype Priority is Any_Priority range 0 .. 245;
subtype Interrupt_Priority is Any_Priority range 246 .. 255;
Default_Priority : constant Priority := 122;
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;
Backend_Divide_Checks : constant Boolean := False;
Backend_Overflow_Checks : constant Boolean := False;
Command_Line_Args : constant Boolean := False;
Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := False;
Duration_32_Bits : constant Boolean := False;
Exit_Status_Supported : constant Boolean := True;
Fractional_Fixed_Ops : constant Boolean := False;
Frontend_Layout : constant Boolean := False;
Functions_Return_By_DSP : 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;
Support_64_Bit_Divides : constant Boolean := True;
Support_Aggregates : constant Boolean := True;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
Suppress_Standard_Library : 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;
-- Obsolete entries, to be removed eventually (bootstrap issues!)
High_Integrity_Mode : constant Boolean := False;
Long_Shifts_Inlined : constant Boolean := False;
end System;
gcc/ada/5ysystem.ads → gcc/ada/system-vxworks-ppc.ads
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
-- S p e c -- -- S p e c --
-- (VxWorks Version PPC) -- -- (VxWorks Version PPC) --
-- -- -- --
-- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- -- -- --
-- This specification is derived from the Ada Reference Manual for use with -- -- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow -- -- GNAT. The copyright notice above, and the license provisions that follow --
...@@ -147,7 +147,7 @@ private ...@@ -147,7 +147,7 @@ private
Suppress_Standard_Library : constant Boolean := False; Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := True; Use_Ada_Main_Program_Name : constant Boolean := True;
ZCX_By_Default : constant Boolean := False; ZCX_By_Default : constant Boolean := False;
GCC_ZCX_Support : constant Boolean := False; GCC_ZCX_Support : constant Boolean := True;
Front_End_ZCX_Support : constant Boolean := False; Front_End_ZCX_Support : constant Boolean := False;
-- Obsolete entries, to be removed eventually (bootstrap issues!) -- Obsolete entries, to be removed eventually (bootstrap issues!)
......
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