From: Arnaud Charlet Date: Fri, 14 May 2004 10:02:00 +0000 (+0200) Subject: Renaming of target specific files for clarity X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=084c663c9911a6649407b9956d9d2d59499cd03c;p=gcc.git 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 --- diff --git a/gcc/ada/31soccon.ads b/gcc/ada/31soccon.ads deleted file mode 100644 index 9f7065f6ffe..00000000000 --- a/gcc/ada/31soccon.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . C O N S T A N T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2003 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 target dependent definitions of constant for use --- by the GNAT.Sockets package (g-socket.ads). This package should not be --- directly with'ed by an applications program. - --- This is the version for UnixWare - -package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 27; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 2; -- Stream socket - SOCK_DGRAM : constant := 1; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 125; -- Address already in use - EADDRNOTAVAIL : constant := 126; -- Cannot assign address - EAFNOSUPPORT : constant := 124; -- Addr family not supported - EALREADY : constant := 149; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 130; -- Connection aborted - ECONNREFUSED : constant := 146; -- Connection refused - ECONNRESET : constant := 131; -- Connection reset by peer - EDESTADDRREQ : constant := 96; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 147; -- Host is down - EHOSTUNREACH : constant := 148; -- No route to host - EINPROGRESS : constant := 150; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 133; -- Socket already connected - ELOOP : constant := 90; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 97; -- Message too long - ENAMETOOLONG : constant := 78; -- Name too long - ENETDOWN : constant := 127; -- Network is down - ENETRESET : constant := 129; -- Disconn. on network reset - ENETUNREACH : constant := 128; -- Network is unreachable - ENOBUFS : constant := 132; -- No buffer space available - ENOPROTOOPT : constant := 99; -- Protocol not available - ENOTCONN : constant := 134; -- Socket not connected - ENOTSOCK : constant := 95; -- Operation on non socket - EOPNOTSUPP : constant := 122; -- Operation not supported - EPFNOSUPPORT : constant := 123; -- Unknown protocol family - EPROTONOSUPPORT : constant := 120; -- Unknown protocol - EPROTOTYPE : constant := 98; -- Unknown protocol type - ESHUTDOWN : constant := 143; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported - ETIMEDOUT : constant := 145; -- Connection timed out - ETOOMANYREFS : constant := 144; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_ERROR : constant := 4103; -- Get/clear error status - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - IP_ADD_MEMBERSHIP : constant := 11; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 12; -- Leave a multicast group - IP_MULTICAST_TTL : constant := 16; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 10; -- Set/get mcast loopback - -end GNAT.Sockets.Constants; diff --git a/gcc/ada/31soliop.ads b/gcc/ada/31soliop.ads deleted file mode 100644 index 754cafd6a1e..00000000000 --- a/gcc/ada/31soliop.ads +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-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 package is used to provide target specific linker_options for the --- support of scokets as required by the package GNAT.Sockets. - --- This is the UnixWare version of this package - -package GNAT.Sockets.Linker_Options is -private - pragma Linker_Options ("-lnsl"); - pragma Linker_Options ("-lsocket"); -end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/35soccon.ads b/gcc/ada/35soccon.ads deleted file mode 100644 index cd19222e1a7..00000000000 --- a/gcc/ada/35soccon.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . C O N S T A N T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2003 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 target dependent definitions of constant for use --- by the GNAT.Sockets package (g-socket.ads). This package should not be --- directly with'ed by an applications program. - --- This is the version for i386 FreeBSD - -package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 28; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 48; -- Address already in use - EADDRNOTAVAIL : constant := 49; -- Cannot assign address - EAFNOSUPPORT : constant := 47; -- Addr family not supported - EALREADY : constant := 37; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 53; -- Connection aborted - ECONNREFUSED : constant := 61; -- Connection refused - ECONNRESET : constant := 54; -- Connection reset by peer - EDESTADDRREQ : constant := 39; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 64; -- Host is down - EHOSTUNREACH : constant := 65; -- No route to host - EINPROGRESS : constant := 36; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 56; -- Socket already connected - ELOOP : constant := 62; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 40; -- Message too long - ENAMETOOLONG : constant := 63; -- Name too long - ENETDOWN : constant := 50; -- Network is down - ENETRESET : constant := 52; -- Disconn. on network reset - ENETUNREACH : constant := 51; -- Network is unreachable - ENOBUFS : constant := 55; -- No buffer space available - ENOPROTOOPT : constant := 42; -- Protocol not available - ENOTCONN : constant := 57; -- Socket not connected - ENOTSOCK : constant := 38; -- Operation on non socket - EOPNOTSUPP : constant := 45; -- Operation not supported - EPFNOSUPPORT : constant := 46; -- Unknown protocol family - EPROTONOSUPPORT : constant := 43; -- Unknown protocol - EPROTOTYPE : constant := 41; -- Unknown protocol type - ESHUTDOWN : constant := 58; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported - ETIMEDOUT : constant := 60; -- Connection timed out - ETOOMANYREFS : constant := 59; -- Too many references - EWOULDBLOCK : constant := 35; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_ERROR : constant := 4103; -- Get/clear error status - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - -end GNAT.Sockets.Constants; diff --git a/gcc/ada/3asoccon.ads b/gcc/ada/3asoccon.ads deleted file mode 100644 index ef3536e4bbc..00000000000 --- a/gcc/ada/3asoccon.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . C O N S T A N T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2003 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 target dependent definitions of constant for use --- by the GNAT.Sockets package (g-socket.ads). This package should not be --- directly with'ed by an applications program. - --- This is the version for OSF - -package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 26; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 48; -- Address already in use - EADDRNOTAVAIL : constant := 49; -- Cannot assign address - EAFNOSUPPORT : constant := 47; -- Addr family not supported - EALREADY : constant := 37; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 53; -- Connection aborted - ECONNREFUSED : constant := 61; -- Connection refused - ECONNRESET : constant := 54; -- Connection reset by peer - EDESTADDRREQ : constant := 39; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 64; -- Host is down - EHOSTUNREACH : constant := 65; -- No route to host - EINPROGRESS : constant := 36; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 56; -- Socket already connected - ELOOP : constant := 62; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 40; -- Message too long - ENAMETOOLONG : constant := 63; -- Name too long - ENETDOWN : constant := 50; -- Network is down - ENETRESET : constant := 52; -- Disconn. on network reset - ENETUNREACH : constant := 51; -- Network is unreachable - ENOBUFS : constant := 55; -- No buffer space available - ENOPROTOOPT : constant := 42; -- Protocol not available - ENOTCONN : constant := 57; -- Socket not connected - ENOTSOCK : constant := 38; -- Operation on non socket - EOPNOTSUPP : constant := 45; -- Operation not supported - EPFNOSUPPORT : constant := 46; -- Unknown protocol family - EPROTONOSUPPORT : constant := 43; -- Unknown protocol - EPROTOTYPE : constant := 41; -- Unknown protocol type - ESHUTDOWN : constant := 58; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported - ETIMEDOUT : constant := 60; -- Connection timed out - ETOOMANYREFS : constant := 59; -- Too many references - EWOULDBLOCK : constant := 35; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_ERROR : constant := 4103; -- Get/clear error status - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - -end GNAT.Sockets.Constants; diff --git a/gcc/ada/3bsoccon.ads b/gcc/ada/3bsoccon.ads deleted file mode 100644 index 0f5fe9d4c6b..00000000000 --- a/gcc/ada/3bsoccon.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . C O N S T A N T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2003 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 target dependent definitions of constant for use --- by the GNAT.Sockets package (g-socket.ads). This package should not be --- directly with'ed by an applications program. - --- This is the version for AIX - -package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 24; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 67; -- Address already in use - EADDRNOTAVAIL : constant := 68; -- Cannot assign address - EAFNOSUPPORT : constant := 66; -- Addr family not supported - EALREADY : constant := 56; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 72; -- Connection aborted - ECONNREFUSED : constant := 79; -- Connection refused - ECONNRESET : constant := 73; -- Connection reset by peer - EDESTADDRREQ : constant := 58; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 80; -- Host is down - EHOSTUNREACH : constant := 81; -- No route to host - EINPROGRESS : constant := 55; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 75; -- Socket already connected - ELOOP : constant := 85; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 59; -- Message too long - ENAMETOOLONG : constant := 86; -- Name too long - ENETDOWN : constant := 69; -- Network is down - ENETRESET : constant := 71; -- Disconn. on network reset - ENETUNREACH : constant := 70; -- Network is unreachable - ENOBUFS : constant := 74; -- No buffer space available - ENOPROTOOPT : constant := 61; -- Protocol not available - ENOTCONN : constant := 76; -- Socket not connected - ENOTSOCK : constant := 57; -- Operation on non socket - EOPNOTSUPP : constant := 64; -- Operation not supported - EPFNOSUPPORT : constant := 65; -- Unknown protocol family - EPROTONOSUPPORT : constant := 62; -- Unknown protocol - EPROTOTYPE : constant := 60; -- Unknown protocol type - ESHUTDOWN : constant := 77; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 63; -- Socket type not supported - ETIMEDOUT : constant := 78; -- Connection timed out - ETOOMANYREFS : constant := 115; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_ERROR : constant := 4103; -- Get/clear error status - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - -end GNAT.Sockets.Constants; diff --git a/gcc/ada/3gsoccon.ads b/gcc/ada/3gsoccon.ads deleted file mode 100644 index f19f3cde5f6..00000000000 --- a/gcc/ada/3gsoccon.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . C O N S T A N T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2003 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 target dependent definitions of constant for use --- by the GNAT.Sockets package (g-socket.ads). This package should not be --- directly with'ed by an applications program. - --- This is the version for SGI - -package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 24; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 2; -- Stream socket - SOCK_DGRAM : constant := 1; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 125; -- Address already in use - EADDRNOTAVAIL : constant := 126; -- Cannot assign address - EAFNOSUPPORT : constant := 124; -- Addr family not supported - EALREADY : constant := 149; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 130; -- Connection aborted - ECONNREFUSED : constant := 146; -- Connection refused - ECONNRESET : constant := 131; -- Connection reset by peer - EDESTADDRREQ : constant := 96; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 147; -- Host is down - EHOSTUNREACH : constant := 148; -- No route to host - EINPROGRESS : constant := 150; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 133; -- Socket already connected - ELOOP : constant := 90; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 97; -- Message too long - ENAMETOOLONG : constant := 78; -- Name too long - ENETDOWN : constant := 127; -- Network is down - ENETRESET : constant := 129; -- Disconn. on network reset - ENETUNREACH : constant := 128; -- Network is unreachable - ENOBUFS : constant := 132; -- No buffer space available - ENOPROTOOPT : constant := 99; -- Protocol not available - ENOTCONN : constant := 134; -- Socket not connected - ENOTSOCK : constant := 95; -- Operation on non socket - EOPNOTSUPP : constant := 122; -- Operation not supported - EPFNOSUPPORT : constant := 123; -- Unknown protocol family - EPROTONOSUPPORT : constant := 120; -- Unknown protocol - EPROTOTYPE : constant := 98; -- Unknown protocol type - ESHUTDOWN : constant := 143; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported - ETIMEDOUT : constant := 145; -- Connection timed out - ETOOMANYREFS : constant := 144; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_ERROR : constant := 4103; -- Get/clear error status - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - IP_ADD_MEMBERSHIP : constant := 23; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 24; -- Leave a multicast group - IP_MULTICAST_TTL : constant := 21; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 22; -- Set/get mcast loopback - -end GNAT.Sockets.Constants; diff --git a/gcc/ada/3hsoccon.ads b/gcc/ada/3hsoccon.ads deleted file mode 100644 index cbca2bee7a5..00000000000 --- a/gcc/ada/3hsoccon.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . C O N S T A N T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2003 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 target dependent definitions of constant for use --- by the GNAT.Sockets package (g-socket.ads). This package should not be --- directly with'ed by an applications program. - --- This is the version for HP/UX - -package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 26; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 226; -- Address already in use - EADDRNOTAVAIL : constant := 227; -- Cannot assign address - EAFNOSUPPORT : constant := 225; -- Addr family not supported - EALREADY : constant := 244; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 231; -- Connection aborted - ECONNREFUSED : constant := 239; -- Connection refused - ECONNRESET : constant := 232; -- Connection reset by peer - EDESTADDRREQ : constant := 217; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 241; -- Host is down - EHOSTUNREACH : constant := 242; -- No route to host - EINPROGRESS : constant := 245; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 234; -- Socket already connected - ELOOP : constant := 249; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 218; -- Message too long - ENAMETOOLONG : constant := 248; -- Name too long - ENETDOWN : constant := 228; -- Network is down - ENETRESET : constant := 230; -- Disconn. on network reset - ENETUNREACH : constant := 229; -- Network is unreachable - ENOBUFS : constant := 233; -- No buffer space available - ENOPROTOOPT : constant := 220; -- Protocol not available - ENOTCONN : constant := 235; -- Socket not connected - ENOTSOCK : constant := 216; -- Operation on non socket - EOPNOTSUPP : constant := 223; -- Operation not supported - EPFNOSUPPORT : constant := 224; -- Unknown protocol family - EPROTONOSUPPORT : constant := 221; -- Unknown protocol - EPROTOTYPE : constant := 219; -- Unknown protocol type - ESHUTDOWN : constant := 236; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 222; -- Socket type not supported - ETIMEDOUT : constant := 238; -- Connection timed out - ETOOMANYREFS : constant := 237; -- Too many references - EWOULDBLOCK : constant := 246; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_ERROR : constant := 4103; -- Get/clear error status - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group - IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback - -end GNAT.Sockets.Constants; diff --git a/gcc/ada/3psoccon.ads b/gcc/ada/3psoccon.ads deleted file mode 100644 index 61903079b82..00000000000 --- a/gcc/ada/3psoccon.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . C O N S T A N T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2003 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 target dependent definitions of constant for use --- by the GNAT.Sockets package (g-socket.ads). This package should not be --- directly with'ed by an applications program. - --- This is the version for Interix - -package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := -1; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 48; -- Address already in use - EADDRNOTAVAIL : constant := 49; -- Cannot assign address - EAFNOSUPPORT : constant := 47; -- Addr family not supported - EALREADY : constant := 37; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 53; -- Connection aborted - ECONNREFUSED : constant := 61; -- Connection refused - ECONNRESET : constant := 54; -- Connection reset by peer - EDESTADDRREQ : constant := 82; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 64; -- Host is down - EHOSTUNREACH : constant := 65; -- No route to host - EINPROGRESS : constant := 80; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 56; -- Socket already connected - ELOOP : constant := 62; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 83; -- Message too long - ENAMETOOLONG : constant := 38; -- Name too long - ENETDOWN : constant := 50; -- Network is down - ENETRESET : constant := 52; -- Disconn. on network reset - ENETUNREACH : constant := 51; -- Network is unreachable - ENOBUFS : constant := 55; -- No buffer space available - ENOPROTOOPT : constant := 85; -- Protocol not available - ENOTCONN : constant := 57; -- Socket not connected - ENOTSOCK : constant := 81; -- Operation on non socket - EOPNOTSUPP : constant := 45; -- Operation not supported - EPFNOSUPPORT : constant := 46; -- Unknown protocol family - EPROTONOSUPPORT : constant := 43; -- Unknown protocol - EPROTOTYPE : constant := 84; -- Unknown protocol type - ESHUTDOWN : constant := 58; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported - ETIMEDOUT : constant := 60; -- Connection timed out - ETOOMANYREFS : constant := 59; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 90; -- Unknown host - TRY_AGAIN : constant := 91; -- Host name lookup failure - NO_DATA : constant := 93; -- No data record for name - NO_RECOVERY : constant := 92; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195390; -- Set/clear non-blocking io - FIONREAD : constant := 1074030081; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_ERROR : constant := 4103; -- Get/clear error status - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group - IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback - -end GNAT.Sockets.Constants; diff --git a/gcc/ada/3ssoccon.ads b/gcc/ada/3ssoccon.ads deleted file mode 100644 index 1ad58838ca9..00000000000 --- a/gcc/ada/3ssoccon.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . C O N S T A N T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2003 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 target dependent definitions of constant for use --- by the GNAT.Sockets package (g-socket.ads). This package should not be --- directly with'ed by an applications program. - --- This is the version for Solaris - -package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 26; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 2; -- Stream socket - SOCK_DGRAM : constant := 1; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 125; -- Address already in use - EADDRNOTAVAIL : constant := 126; -- Cannot assign address - EAFNOSUPPORT : constant := 124; -- Addr family not supported - EALREADY : constant := 149; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 130; -- Connection aborted - ECONNREFUSED : constant := 146; -- Connection refused - ECONNRESET : constant := 131; -- Connection reset by peer - EDESTADDRREQ : constant := 96; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 147; -- Host is down - EHOSTUNREACH : constant := 148; -- No route to host - EINPROGRESS : constant := 150; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 133; -- Socket already connected - ELOOP : constant := 90; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 97; -- Message too long - ENAMETOOLONG : constant := 78; -- Name too long - ENETDOWN : constant := 127; -- Network is down - ENETRESET : constant := 129; -- Disconn. on network reset - ENETUNREACH : constant := 128; -- Network is unreachable - ENOBUFS : constant := 132; -- No buffer space available - ENOPROTOOPT : constant := 99; -- Protocol not available - ENOTCONN : constant := 134; -- Socket not connected - ENOTSOCK : constant := 95; -- Operation on non socket - EOPNOTSUPP : constant := 122; -- Operation not supported - EPFNOSUPPORT : constant := 123; -- Unknown protocol family - EPROTONOSUPPORT : constant := 120; -- Unknown protocol - EPROTOTYPE : constant := 98; -- Unknown protocol type - ESHUTDOWN : constant := 143; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported - ETIMEDOUT : constant := 145; -- Connection timed out - ETOOMANYREFS : constant := 144; -- Too many references - EWOULDBLOCK : constant := 11; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_ERROR : constant := 4103; -- Get/clear error status - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - IP_ADD_MEMBERSHIP : constant := 19; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 20; -- Leave a multicast group - IP_MULTICAST_TTL : constant := 17; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 18; -- Set/get mcast loopback - -end GNAT.Sockets.Constants; diff --git a/gcc/ada/3ssoliop.ads b/gcc/ada/3ssoliop.ads deleted file mode 100644 index 82ac94ff280..00000000000 --- a/gcc/ada/3ssoliop.ads +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-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 package is used to provide target specific linker_options for the --- support of scokets as required by the package GNAT.Sockets. - --- This is the Solaris version of this package - -package GNAT.Sockets.Linker_Options is -private - pragma Linker_Options ("-lnsl"); - pragma Linker_Options ("-lsocket"); -end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/3veacodu.adb b/gcc/ada/3veacodu.adb deleted file mode 100644 index 2c31a28e299..00000000000 --- a/gcc/ada/3veacodu.adb +++ /dev/null @@ -1,73 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . E X C E P T I O N _ A C T I O N S . C O R E _ D U M P -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003 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 VMS version. - -with System; -with System.Aux_DEC; -separate (GNAT.Exception_Actions) -procedure Core_Dump (Occurrence : Exception_Occurrence) is - - use System; - use System.Aux_DEC; - - pragma Unreferenced (Occurrence); - - SS_IMGDMP : constant := 1276; - - subtype Cond_Value_Type is Unsigned_Longword; - subtype Access_Mode_Type is - Unsigned_Word range 0 .. 3; - Access_Mode_Zero : constant Access_Mode_Type := 0; - - Status : Cond_Value_Type; - - procedure Setexv ( - Status : out Cond_Value_Type; - Vector : in Unsigned_Longword := 0; - Addres : in Address := Address_Zero; - Acmode : in Access_Mode_Type := Access_Mode_Zero; - Prvhnd : in Unsigned_Longword := 0); - pragma Interface (External, Setexv); - pragma Import_Valued_Procedure (Setexv, "SYS$SETEXV", - (Cond_Value_Type, Unsigned_Longword, Address, Access_Mode_Type, - Unsigned_Longword), - (Value, Value, Value, Value, Value)); - - procedure Lib_Signal (I : in Integer); - pragma Interface (C, Lib_Signal); - pragma Import_Procedure (Lib_Signal, "LIB$SIGNAL", Mechanism => (Value)); -begin - Setexv (Status, 1, Address_Zero, 3); - Lib_Signal (SS_IMGDMP); -end Core_Dump; diff --git a/gcc/ada/3vexpect.adb b/gcc/ada/3vexpect.adb deleted file mode 100644 index 1f18885c813..00000000000 --- a/gcc/ada/3vexpect.adb +++ /dev/null @@ -1,1184 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . E X P E C T -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-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 is the VMS version. - -with System; use System; -with Ada.Calendar; use Ada.Calendar; - -with GNAT.IO; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with GNAT.Regpat; use GNAT.Regpat; - -with Unchecked_Deallocation; - -package body GNAT.Expect is - - type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access; - - Save_Input : File_Descriptor; - Save_Output : File_Descriptor; - Save_Error : File_Descriptor; - - procedure Expect_Internal - (Descriptors : in out Array_Of_Pd; - Result : out Expect_Match; - Timeout : Integer; - Full_Buffer : Boolean); - -- Internal function used to read from the process Descriptor. - -- - -- Three outputs are possible: - -- Result=Expect_Timeout, if no output was available before the timeout - -- expired. - -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters - -- had to be discarded from the internal buffer of Descriptor. - -- Result=, indicates how many characters were added to the - -- internal buffer. These characters are from indexes - -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index - -- Process_Died is raised if the process is no longer valid. - - procedure Reinitialize_Buffer - (Descriptor : in out Process_Descriptor'Class); - -- Reinitialize the internal buffer. - -- The buffer is deleted up to the end of the last match. - - procedure Free is new Unchecked_Deallocation - (Pattern_Matcher, Pattern_Matcher_Access); - - procedure Call_Filters - (Pid : Process_Descriptor'Class; - Str : String; - Filter_On : Filter_Type); - -- Call all the filters that have the appropriate type. - -- This function does nothing if the filters are locked - - ------------------------------ - -- Target dependent section -- - ------------------------------ - - function Dup (Fd : File_Descriptor) return File_Descriptor; - pragma Import (C, Dup); - - procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); - pragma Import (C, Dup2); - - procedure Kill (Pid : Process_Id; Sig_Num : Integer); - pragma Import (C, Kill); - - function Create_Pipe (Pipe : access Pipe_Type) return Integer; - pragma Import (C, Create_Pipe, "__gnat_pipe"); - - function Poll - (Fds : System.Address; - Num_Fds : Integer; - Timeout : Integer; - Is_Set : System.Address) return Integer; - pragma Import (C, Poll, "__gnat_expect_poll"); - -- Check whether there is any data waiting on the file descriptor - -- Out_fd, and wait if there is none, at most Timeout milliseconds - -- Returns -1 in case of error, 0 if the timeout expired before - -- data became available. - -- - -- Out_Is_Set is set to 1 if data was available, 0 otherwise. - - function Waitpid (Pid : Process_Id) return Integer; - pragma Import (C, Waitpid, "__gnat_waitpid"); - -- Wait for a specific process id, and return its exit code. - - --------- - -- "+" -- - --------- - - function "+" (S : String) return GNAT.OS_Lib.String_Access is - begin - return new String'(S); - end "+"; - - --------- - -- "+" -- - --------- - - function "+" - (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access - is - begin - return new GNAT.Regpat.Pattern_Matcher'(P); - end "+"; - - ---------------- - -- Add_Filter -- - ---------------- - - procedure Add_Filter - (Descriptor : in out Process_Descriptor; - Filter : Filter_Function; - Filter_On : Filter_Type := Output; - User_Data : System.Address := System.Null_Address; - After : Boolean := False) - is - Current : Filter_List := Descriptor.Filters; - - begin - if After then - while Current /= null and then Current.Next /= null loop - Current := Current.Next; - end loop; - - if Current = null then - Descriptor.Filters := - new Filter_List_Elem' - (Filter => Filter, Filter_On => Filter_On, - User_Data => User_Data, Next => null); - else - Current.Next := - new Filter_List_Elem' - (Filter => Filter, Filter_On => Filter_On, - User_Data => User_Data, Next => null); - end if; - - else - Descriptor.Filters := - new Filter_List_Elem' - (Filter => Filter, Filter_On => Filter_On, - User_Data => User_Data, Next => Descriptor.Filters); - end if; - end Add_Filter; - - ------------------ - -- Call_Filters -- - ------------------ - - procedure Call_Filters - (Pid : Process_Descriptor'Class; - Str : String; - Filter_On : Filter_Type) - is - Current_Filter : Filter_List; - - begin - if Pid.Filters_Lock = 0 then - Current_Filter := Pid.Filters; - - while Current_Filter /= null loop - if Current_Filter.Filter_On = Filter_On then - Current_Filter.Filter - (Pid, Str, Current_Filter.User_Data); - end if; - - Current_Filter := Current_Filter.Next; - end loop; - end if; - end Call_Filters; - - ----------- - -- Close -- - ----------- - - procedure Close - (Descriptor : in out Process_Descriptor; - Status : out Integer) - is - begin - Close (Descriptor.Input_Fd); - - if Descriptor.Error_Fd /= Descriptor.Output_Fd then - Close (Descriptor.Error_Fd); - end if; - - Close (Descriptor.Output_Fd); - - -- ??? Should have timeouts for different signals - Kill (Descriptor.Pid, 9); - - GNAT.OS_Lib.Free (Descriptor.Buffer); - Descriptor.Buffer_Size := 0; - - Status := Waitpid (Descriptor.Pid); - end Close; - - procedure Close (Descriptor : in out Process_Descriptor) is - Status : Integer; - begin - Close (Descriptor, Status); - end Close; - - ------------ - -- Expect -- - ------------ - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : String; - Timeout : Integer := 10000; - Full_Buffer : Boolean := False) - is - begin - if Regexp = "" then - Expect (Descriptor, Result, Never_Match, Timeout, Full_Buffer); - else - Expect (Descriptor, Result, Compile (Regexp), Timeout, Full_Buffer); - end if; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : String; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; - Full_Buffer : Boolean := False) - is - begin - pragma Assert (Matched'First = 0); - if Regexp = "" then - Expect - (Descriptor, Result, Never_Match, Matched, Timeout, Full_Buffer); - else - Expect - (Descriptor, Result, Compile (Regexp), Matched, Timeout, - Full_Buffer); - end if; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : GNAT.Regpat.Pattern_Matcher; - Timeout : Integer := 10000; - Full_Buffer : Boolean := False) - is - Matched : GNAT.Regpat.Match_Array (0 .. 0); - - begin - Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer); - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : GNAT.Regpat.Pattern_Matcher; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; - Full_Buffer : Boolean := False) - is - N : Expect_Match; - Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); - Try_Until : constant Time := Clock + Duration (Timeout) / 1000.0; - Timeout_Tmp : Integer := Timeout; - - begin - pragma Assert (Matched'First = 0); - Reinitialize_Buffer (Descriptor); - - loop - -- First, test if what is already in the buffer matches (This is - -- required if this package is used in multi-task mode, since one of - -- the tasks might have added something in the buffer, and we don't - -- want other tasks to wait for new input to be available before - -- checking the regexps). - - Match - (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); - - if Descriptor.Buffer_Index >= 1 and then Matched (0).First /= 0 then - Result := 1; - Descriptor.Last_Match_Start := Matched (0).First; - Descriptor.Last_Match_End := Matched (0).Last; - return; - end if; - - -- Else try to read new input - - Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer); - - if N = Expect_Timeout or else N = Expect_Full_Buffer then - Result := N; - return; - end if; - - -- Calculate the timeout for the next turn. - -- Note that Timeout is, from the caller's perspective, the maximum - -- time until a match, not the maximum time until some output is - -- read, and thus can not be reused as is for Expect_Internal. - - if Timeout /= -1 then - Timeout_Tmp := Integer (Try_Until - Clock) * 1000; - - if Timeout_Tmp < 0 then - Result := Expect_Timeout; - exit; - end if; - end if; - end loop; - - -- Even if we had the general timeout above, we have to test that the - -- last test we read from the external process didn't match. - - Match - (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); - - if Matched (0).First /= 0 then - Result := 1; - Descriptor.Last_Match_Start := Matched (0).First; - Descriptor.Last_Match_End := Matched (0).Last; - return; - end if; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Regexp_Array; - Timeout : Integer := 10000; - Full_Buffer : Boolean := False) - is - Patterns : Compiled_Regexp_Array (Regexps'Range); - Matched : GNAT.Regpat.Match_Array (0 .. 0); - - begin - for J in Regexps'Range loop - Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); - end loop; - - Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); - - for J in Regexps'Range loop - Free (Patterns (J)); - end loop; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Compiled_Regexp_Array; - Timeout : Integer := 10000; - Full_Buffer : Boolean := False) - is - Matched : GNAT.Regpat.Match_Array (0 .. 0); - - begin - Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer); - end Expect; - - procedure Expect - (Result : out Expect_Match; - Regexps : Multiprocess_Regexp_Array; - Timeout : Integer := 10000; - Full_Buffer : Boolean := False) - is - Matched : GNAT.Regpat.Match_Array (0 .. 0); - - begin - Expect (Result, Regexps, Matched, Timeout, Full_Buffer); - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Regexp_Array; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; - Full_Buffer : Boolean := False) - is - Patterns : Compiled_Regexp_Array (Regexps'Range); - - begin - pragma Assert (Matched'First = 0); - - for J in Regexps'Range loop - Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); - end loop; - - Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); - - for J in Regexps'Range loop - Free (Patterns (J)); - end loop; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Compiled_Regexp_Array; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; - Full_Buffer : Boolean := False) - is - N : Expect_Match; - Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); - - begin - pragma Assert (Matched'First = 0); - - Reinitialize_Buffer (Descriptor); - - loop - -- First, test if what is already in the buffer matches (This is - -- required if this package is used in multi-task mode, since one of - -- the tasks might have added something in the buffer, and we don't - -- want other tasks to wait for new input to be available before - -- checking the regexps). - - if Descriptor.Buffer /= null then - for J in Regexps'Range loop - Match - (Regexps (J).all, - Descriptor.Buffer (1 .. Descriptor.Buffer_Index), - Matched); - - if Matched (0) /= No_Match then - Result := Expect_Match (J); - Descriptor.Last_Match_Start := Matched (0).First; - Descriptor.Last_Match_End := Matched (0).Last; - return; - end if; - end loop; - end if; - - Expect_Internal (Descriptors, N, Timeout, Full_Buffer); - - if N = Expect_Timeout or else N = Expect_Full_Buffer then - Result := N; - return; - end if; - end loop; - end Expect; - - procedure Expect - (Result : out Expect_Match; - Regexps : Multiprocess_Regexp_Array; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10000; - Full_Buffer : Boolean := False) - is - N : Expect_Match; - Descriptors : Array_Of_Pd (Regexps'Range); - - begin - pragma Assert (Matched'First = 0); - - for J in Descriptors'Range loop - Descriptors (J) := Regexps (J).Descriptor; - Reinitialize_Buffer (Regexps (J).Descriptor.all); - end loop; - - loop - -- First, test if what is already in the buffer matches (This is - -- required if this package is used in multi-task mode, since one of - -- the tasks might have added something in the buffer, and we don't - -- want other tasks to wait for new input to be available before - -- checking the regexps). - - for J in Regexps'Range loop - Match (Regexps (J).Regexp.all, - Regexps (J).Descriptor.Buffer - (1 .. Regexps (J).Descriptor.Buffer_Index), - Matched); - - if Matched (0) /= No_Match then - Result := Expect_Match (J); - Regexps (J).Descriptor.Last_Match_Start := Matched (0).First; - Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; - return; - end if; - end loop; - - Expect_Internal (Descriptors, N, Timeout, Full_Buffer); - - if N = Expect_Timeout or else N = Expect_Full_Buffer then - Result := N; - return; - end if; - end loop; - end Expect; - - --------------------- - -- Expect_Internal -- - --------------------- - - procedure Expect_Internal - (Descriptors : in out Array_Of_Pd; - Result : out Expect_Match; - Timeout : Integer; - Full_Buffer : Boolean) - is - Num_Descriptors : Integer; - Buffer_Size : Integer := 0; - - N : Integer; - - type File_Descriptor_Array is - array (Descriptors'Range) of File_Descriptor; - Fds : aliased File_Descriptor_Array; - - type Integer_Array is array (Descriptors'Range) of Integer; - Is_Set : aliased Integer_Array; - - begin - for J in Descriptors'Range loop - Fds (J) := Descriptors (J).Output_Fd; - - if Descriptors (J).Buffer_Size = 0 then - Buffer_Size := Integer'Max (Buffer_Size, 4096); - else - Buffer_Size := - Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); - end if; - end loop; - - declare - Buffer : aliased String (1 .. Buffer_Size); - -- Buffer used for input. This is allocated only once, not for - -- every iteration of the loop - - begin - -- Loop until we match or we have a timeout - - loop - Num_Descriptors := - Poll (Fds'Address, Fds'Length, Timeout, Is_Set'Address); - - case Num_Descriptors is - - -- Error? - - when -1 => - raise Process_Died; - - -- Timeout? - - when 0 => - Result := Expect_Timeout; - return; - - -- Some input - - when others => - for J in Descriptors'Range loop - if Is_Set (J) = 1 then - Buffer_Size := Descriptors (J).Buffer_Size; - - if Buffer_Size = 0 then - Buffer_Size := 4096; - end if; - - N := Read (Descriptors (J).Output_Fd, Buffer'Address, - Buffer_Size); - - -- Error or End of file - - if N <= 0 then - -- ??? Note that ddd tries again up to three times - -- in that case. See LiterateA.C:174 - raise Process_Died; - - else - -- If there is no limit to the buffer size - - if Descriptors (J).Buffer_Size = 0 then - - declare - Tmp : String_Access := Descriptors (J).Buffer; - - begin - if Tmp /= null then - Descriptors (J).Buffer := - new String (1 .. Tmp'Length + N); - Descriptors (J).Buffer (1 .. Tmp'Length) := - Tmp.all; - Descriptors (J).Buffer - (Tmp'Length + 1 .. Tmp'Length + N) := - Buffer (1 .. N); - Free (Tmp); - Descriptors (J).Buffer_Index := - Descriptors (J).Buffer'Last; - - else - Descriptors (J).Buffer := - new String (1 .. N); - Descriptors (J).Buffer.all := - Buffer (1 .. N); - Descriptors (J).Buffer_Index := N; - end if; - end; - - else - -- Add what we read to the buffer - - if Descriptors (J).Buffer_Index + N - 1 > - Descriptors (J).Buffer_Size - then - -- If the user wants to know when we have - -- read more than the buffer can contain. - - if Full_Buffer then - Result := Expect_Full_Buffer; - return; - end if; - - -- Keep as much as possible from the buffer, - -- and forget old characters. - - Descriptors (J).Buffer - (1 .. Descriptors (J).Buffer_Size - N) := - Descriptors (J).Buffer - (N - Descriptors (J).Buffer_Size + - Descriptors (J).Buffer_Index + 1 .. - Descriptors (J).Buffer_Index); - Descriptors (J).Buffer_Index := - Descriptors (J).Buffer_Size - N; - end if; - - -- Keep what we read in the buffer. - - Descriptors (J).Buffer - (Descriptors (J).Buffer_Index + 1 .. - Descriptors (J).Buffer_Index + N) := - Buffer (1 .. N); - Descriptors (J).Buffer_Index := - Descriptors (J).Buffer_Index + N; - end if; - - -- Call each of the output filter with what we - -- read. - - Call_Filters - (Descriptors (J).all, Buffer (1 .. N), Output); - - Result := Expect_Match (N); - return; - end if; - end if; - end loop; - end case; - end loop; - end; - end Expect_Internal; - - ---------------- - -- Expect_Out -- - ---------------- - - function Expect_Out (Descriptor : Process_Descriptor) return String is - begin - return Descriptor.Buffer (1 .. Descriptor.Last_Match_End); - end Expect_Out; - - ---------------------- - -- Expect_Out_Match -- - ---------------------- - - function Expect_Out_Match (Descriptor : Process_Descriptor) return String is - begin - return Descriptor.Buffer - (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End); - end Expect_Out_Match; - - ----------- - -- Flush -- - ----------- - - procedure Flush - (Descriptor : in out Process_Descriptor; - Timeout : Integer := 0) - is - Buffer_Size : constant Integer := 8192; - Num_Descriptors : Integer; - N : Integer; - Is_Set : aliased Integer; - Buffer : aliased String (1 .. Buffer_Size); - - begin - -- Empty the current buffer - - Descriptor.Last_Match_End := Descriptor.Buffer_Index; - Reinitialize_Buffer (Descriptor); - - -- Read everything from the process to flush its output - - loop - Num_Descriptors := - Poll (Descriptor.Output_Fd'Address, 1, Timeout, Is_Set'Address); - - case Num_Descriptors is - - -- Error ? - - when -1 => - raise Process_Died; - - -- Timeout => End of flush - - when 0 => - return; - - -- Some input - - when others => - if Is_Set = 1 then - N := Read (Descriptor.Output_Fd, Buffer'Address, - Buffer_Size); - - if N = -1 then - raise Process_Died; - elsif N = 0 then - return; - end if; - end if; - end case; - end loop; - - end Flush; - - ------------------ - -- Get_Error_Fd -- - ------------------ - - function Get_Error_Fd - (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor - is - begin - return Descriptor.Error_Fd; - end Get_Error_Fd; - - ------------------ - -- Get_Input_Fd -- - ------------------ - - function Get_Input_Fd - (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor - is - begin - return Descriptor.Input_Fd; - end Get_Input_Fd; - - ------------------- - -- Get_Output_Fd -- - ------------------- - - function Get_Output_Fd - (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor - is - begin - return Descriptor.Output_Fd; - end Get_Output_Fd; - - ------------- - -- Get_Pid -- - ------------- - - function Get_Pid - (Descriptor : Process_Descriptor) return Process_Id - is - begin - return Descriptor.Pid; - end Get_Pid; - - --------------- - -- Interrupt -- - --------------- - - procedure Interrupt (Descriptor : in out Process_Descriptor) is - SIGINT : constant := 2; - - begin - Send_Signal (Descriptor, SIGINT); - end Interrupt; - - ------------------ - -- Lock_Filters -- - ------------------ - - procedure Lock_Filters (Descriptor : in out Process_Descriptor) is - begin - Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1; - end Lock_Filters; - - ------------------------ - -- Non_Blocking_Spawn -- - ------------------------ - - procedure Non_Blocking_Spawn - (Descriptor : out Process_Descriptor'Class; - Command : String; - Args : GNAT.OS_Lib.Argument_List; - Buffer_Size : Natural := 4096; - Err_To_Out : Boolean := False) - is - function Alloc_Vfork_Blocks return Integer; - pragma Import (C, Alloc_Vfork_Blocks, "decc$$alloc_vfork_blocks"); - - function Get_Vfork_Jmpbuf return System.Address; - pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf"); - - function Get_Current_Invo_Context - (Addr : System.Address) return Process_Id; - pragma Import (C, Get_Current_Invo_Context, - "LIB$GET_CURRENT_INVO_CONTEXT"); - - Pipe1, Pipe2, Pipe3 : aliased Pipe_Type; - - Arg : String_Access; - Arg_List : aliased array (1 .. Args'Length + 2) of System.Address; - - Command_With_Path : String_Access; - - begin - -- Create the rest of the pipes - - Set_Up_Communications - (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); - - Command_With_Path := Locate_Exec_On_Path (Command); - - if Command_With_Path = null then - raise Invalid_Process; - end if; - - -- Fork a new process. It's not possible to do this in a subprogram. - - if Alloc_Vfork_Blocks >= 0 then - Descriptor.Pid := Get_Current_Invo_Context (Get_Vfork_Jmpbuf); - else - Descriptor.Pid := -1; - end if; - - -- Are we now in the child (or, for Windows, still in the common - -- process). - - if Descriptor.Pid = Null_Pid then - -- Prepare an array of arguments to pass to C - - Arg := new String (1 .. Command_With_Path'Length + 1); - Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; - Arg (Arg'Last) := ASCII.Nul; - Arg_List (1) := Arg.all'Address; - - for J in Args'Range loop - Arg := new String (1 .. Args (J)'Length + 1); - Arg (1 .. Args (J)'Length) := Args (J).all; - Arg (Arg'Last) := ASCII.Nul; - Arg_List (J + 2 - Args'First) := Arg.all'Address; - end loop; - - Arg_List (Arg_List'Last) := System.Null_Address; - - -- This does not return on Unix systems - - Set_Up_Child_Communications - (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all, - Arg_List'Address); - end if; - - Free (Command_With_Path); - - -- Did we have an error when spawning the child ? - - if Descriptor.Pid < Null_Pid then - raise Invalid_Process; - else - -- We are now in the parent process - - Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3); - end if; - - -- Create the buffer - - Descriptor.Buffer_Size := Buffer_Size; - - if Buffer_Size /= 0 then - Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); - end if; - end Non_Blocking_Spawn; - - ------------------------- - -- Reinitialize_Buffer -- - ------------------------- - - procedure Reinitialize_Buffer - (Descriptor : in out Process_Descriptor'Class) - is - begin - if Descriptor.Buffer_Size = 0 then - declare - Tmp : String_Access := Descriptor.Buffer; - - begin - Descriptor.Buffer := - new String - (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End); - - if Tmp /= null then - Descriptor.Buffer.all := Tmp - (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); - Free (Tmp); - end if; - end; - - Descriptor.Buffer_Index := Descriptor.Buffer'Last; - - else - Descriptor.Buffer - (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) := - Descriptor.Buffer - (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); - - if Descriptor.Buffer_Index > Descriptor.Last_Match_End then - Descriptor.Buffer_Index := - Descriptor.Buffer_Index - Descriptor.Last_Match_End; - else - Descriptor.Buffer_Index := 0; - end if; - end if; - - Descriptor.Last_Match_Start := 0; - Descriptor.Last_Match_End := 0; - end Reinitialize_Buffer; - - ------------------- - -- Remove_Filter -- - ------------------- - - procedure Remove_Filter - (Descriptor : in out Process_Descriptor; - Filter : Filter_Function) - is - Previous : Filter_List := null; - Current : Filter_List := Descriptor.Filters; - - begin - while Current /= null loop - if Current.Filter = Filter then - if Previous = null then - Descriptor.Filters := Current.Next; - else - Previous.Next := Current.Next; - end if; - end if; - - Previous := Current; - Current := Current.Next; - end loop; - end Remove_Filter; - - ---------- - -- Send -- - ---------- - - procedure Send - (Descriptor : in out Process_Descriptor; - Str : String; - Add_LF : Boolean := True; - Empty_Buffer : Boolean := False) - is - Full_Str : constant String := Str & ASCII.LF; - Last : Natural; - Result : Expect_Match; - Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); - - Discard : Natural; - pragma Unreferenced (Discard); - - begin - if Empty_Buffer then - - -- Force a read on the process if there is anything waiting - - Expect_Internal (Descriptors, Result, - Timeout => 0, Full_Buffer => False); - Descriptor.Last_Match_End := Descriptor.Buffer_Index; - - -- Empty the buffer - - Reinitialize_Buffer (Descriptor); - end if; - - if Add_LF then - Last := Full_Str'Last; - else - Last := Full_Str'Last - 1; - end if; - - Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input); - - Discard := Write (Descriptor.Input_Fd, - Full_Str'Address, - Last - Full_Str'First + 1); - -- Shouldn't we at least have a pragma Assert on the result ??? - end Send; - - ----------------- - -- Send_Signal -- - ----------------- - - procedure Send_Signal - (Descriptor : Process_Descriptor; - Signal : Integer) - is - begin - Kill (Descriptor.Pid, Signal); - -- ??? Need to check process status here. - end Send_Signal; - - --------------------------------- - -- Set_Up_Child_Communications -- - --------------------------------- - - procedure Set_Up_Child_Communications - (Pid : in out Process_Descriptor; - Pipe1 : in out Pipe_Type; - Pipe2 : in out Pipe_Type; - Pipe3 : in out Pipe_Type; - Cmd : in String; - Args : in System.Address) - is - pragma Warnings (Off, Pid); - - begin - -- Since the code between fork and exec on VMS executes - -- in the context of the parent process, we need to - -- perform the following actions: - -- - save stdin, stdout, stderr - -- - replace them by our pipes - -- - create the child with process handle inheritance - -- - revert to the previous stdin, stdout and stderr. - - Save_Input := Dup (GNAT.OS_Lib.Standin); - Save_Output := Dup (GNAT.OS_Lib.Standout); - Save_Error := Dup (GNAT.OS_Lib.Standerr); - - -- Since we are still called from the parent process, there is no way - -- currently we can cleanly close the unneeded ends of the pipes, but - -- this doesn't really matter. - -- We could close Pipe1.Output, Pipe2.Input, Pipe3.Input. - - Dup2 (Pipe1.Input, GNAT.OS_Lib.Standin); - Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout); - Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr); - - Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.Nul, Args); - - end Set_Up_Child_Communications; - - --------------------------- - -- Set_Up_Communications -- - --------------------------- - - procedure Set_Up_Communications - (Pid : in out Process_Descriptor; - Err_To_Out : Boolean; - Pipe1 : access Pipe_Type; - Pipe2 : access Pipe_Type; - Pipe3 : access Pipe_Type) - is - begin - -- Create the pipes - - if Create_Pipe (Pipe1) /= 0 then - return; - end if; - - if Create_Pipe (Pipe2) /= 0 then - return; - end if; - - Pid.Input_Fd := Pipe1.Output; - Pid.Output_Fd := Pipe2.Input; - - if Err_To_Out then - Pipe3.all := Pipe2.all; - else - if Create_Pipe (Pipe3) /= 0 then - return; - end if; - end if; - - Pid.Error_Fd := Pipe3.Input; - end Set_Up_Communications; - - ---------------------------------- - -- Set_Up_Parent_Communications -- - ---------------------------------- - - procedure Set_Up_Parent_Communications - (Pid : in out Process_Descriptor; - Pipe1 : in out Pipe_Type; - Pipe2 : in out Pipe_Type; - Pipe3 : in out Pipe_Type) - is - pragma Warnings (Off, Pid); - - begin - - Dup2 (Save_Input, GNAT.OS_Lib.Standin); - Dup2 (Save_Output, GNAT.OS_Lib.Standout); - Dup2 (Save_Error, GNAT.OS_Lib.Standerr); - - Close (Save_Input); - Close (Save_Output); - Close (Save_Error); - - Close (Pipe1.Input); - Close (Pipe2.Output); - Close (Pipe3.Output); - end Set_Up_Parent_Communications; - - ------------------ - -- Trace_Filter -- - ------------------ - - procedure Trace_Filter - (Descriptor : Process_Descriptor'Class; - Str : String; - User_Data : System.Address := System.Null_Address) - is - pragma Warnings (Off, Descriptor); - pragma Warnings (Off, User_Data); - - begin - GNAT.IO.Put (Str); - end Trace_Filter; - - -------------------- - -- Unlock_Filters -- - -------------------- - - procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is - begin - if Descriptor.Filters_Lock > 0 then - Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1; - end if; - end Unlock_Filters; - -end GNAT.Expect; diff --git a/gcc/ada/3vsoccon.ads b/gcc/ada/3vsoccon.ads deleted file mode 100644 index 76b2051e07c..00000000000 --- a/gcc/ada/3vsoccon.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . C O N S T A N T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2003 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 target dependent definitions of constant for use --- by the GNAT.Sockets package (g-socket.ads). This package should not be --- directly with'ed by an applications program. - --- This is the version for Alpha/VMS - -package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 26; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 48; -- Address already in use - EADDRNOTAVAIL : constant := 49; -- Cannot assign address - EAFNOSUPPORT : constant := 47; -- Addr family not supported - EALREADY : constant := 37; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 53; -- Connection aborted - ECONNREFUSED : constant := 61; -- Connection refused - ECONNRESET : constant := 54; -- Connection reset by peer - EDESTADDRREQ : constant := 39; -- Destination addr required - EFAULT : constant := 45; -- Bad address - EHOSTDOWN : constant := 64; -- Host is down - EHOSTUNREACH : constant := 65; -- No route to host - EINPROGRESS : constant := 36; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 56; -- Socket already connected - ELOOP : constant := 62; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 40; -- Message too long - ENAMETOOLONG : constant := 63; -- Name too long - ENETDOWN : constant := 50; -- Network is down - ENETRESET : constant := 52; -- Disconn. on network reset - ENETUNREACH : constant := 51; -- Network is unreachable - ENOBUFS : constant := 55; -- No buffer space available - ENOPROTOOPT : constant := 42; -- Protocol not available - ENOTCONN : constant := 57; -- Socket not connected - ENOTSOCK : constant := 38; -- Operation on non socket - EOPNOTSUPP : constant := 95; -- Operation not supported - EPFNOSUPPORT : constant := 46; -- Unknown protocol family - EPROTONOSUPPORT : constant := 43; -- Unknown protocol - EPROTOTYPE : constant := 41; -- Unknown protocol type - ESHUTDOWN : constant := 58; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported - ETIMEDOUT : constant := 60; -- Connection timed out - ETOOMANYREFS : constant := 59; -- Too many references - EWOULDBLOCK : constant := 35; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 16#FFFF#; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_SNDBUF : constant := 16#1001#; -- Set/get send buffer size - SO_RCVBUF : constant := 16#1002#; -- Set/get recv buffer size - SO_REUSEADDR : constant := 16#0004#; -- Bind reuse local address - SO_KEEPALIVE : constant := 16#0008#; -- Enable keep-alive msgs - SO_LINGER : constant := 16#0080#; -- Defer close to flush data - SO_ERROR : constant := 16#1007#; -- Get/clear error status - SO_BROADCAST : constant := 16#0020#; -- Can send broadcast msgs - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - -end GNAT.Sockets.Constants; diff --git a/gcc/ada/3vsocthi.adb b/gcc/ada/3vsocthi.adb deleted file mode 100644 index 41b32d16e9a..00000000000 --- a/gcc/ada/3vsocthi.adb +++ /dev/null @@ -1,551 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2004 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. -- --- -- ------------------------------------------------------------------------------- - --- Temporary version for Alpha/VMS. - -with GNAT.OS_Lib; use GNAT.OS_Lib; -with GNAT.Task_Lock; - -with Interfaces.C; use Interfaces.C; - -package body GNAT.Sockets.Thin is - - Non_Blocking_Sockets : constant Fd_Set_Access - := New_Socket_Set (No_Socket_Set); - -- When this package is initialized with Process_Blocking_IO set - -- to True, sockets are set in non-blocking mode to avoid blocking - -- the whole process when a thread wants to perform a blocking IO - -- operation. But the user can also set a socket in non-blocking - -- mode by purpose. In order to make a difference between these - -- two situations, we track the origin of non-blocking mode in - -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has - -- been set in non-blocking mode by the user. - - Quantum : constant Duration := 0.2; - -- When Thread_Blocking_IO is False, we set sockets in - -- non-blocking mode and we spend a period of time Quantum between - -- two attempts on a blocking operation. - - Thread_Blocking_IO : Boolean := True; - - Unknown_System_Error : constant C.Strings.chars_ptr := - C.Strings.New_String ("Unknown system error"); - - function Syscall_Accept - (S : C.int; - Addr : System.Address; - Addrlen : access C.int) return C.int; - pragma Import (C, Syscall_Accept, "accept"); - - function Syscall_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int; - pragma Import (C, Syscall_Connect, "connect"); - - function Syscall_Ioctl - (S : C.int; - Req : C.int; - Arg : Int_Access) return C.int; - pragma Import (C, Syscall_Ioctl, "ioctl"); - - function Syscall_Recv - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int; - pragma Import (C, Syscall_Recv, "recv"); - - function Syscall_Recvfrom - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - From : Sockaddr_In_Access; - Fromlen : access C.int) return C.int; - pragma Import (C, Syscall_Recvfrom, "recvfrom"); - - function Syscall_Send - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) - return C.int; - pragma Import (C, Syscall_Send, "send"); - - function Syscall_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : Sockaddr_In_Access; - Tolen : C.int) - return C.int; - pragma Import (C, Syscall_Sendto, "sendto"); - - function Syscall_Socket - (Domain, Typ, Protocol : C.int) return C.int; - pragma Import (C, Syscall_Socket, "socket"); - - function Non_Blocking_Socket (S : C.int) return Boolean; - procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean); - - -------------- - -- C_Accept -- - -------------- - - function C_Accept - (S : C.int; - Addr : System.Address; - Addrlen : access C.int) return C.int - is - R : C.int; - Val : aliased C.int := 1; - - Discard : C.int; - pragma Warnings (Off, Discard); - - begin - loop - R := Syscall_Accept (S, Addr, Addrlen); - exit when Thread_Blocking_IO - or else R /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= Constants.EWOULDBLOCK; - delay Quantum; - end loop; - - if not Thread_Blocking_IO - and then R /= Failure - then - -- A socket inherits the properties ot its server especially - -- the FIONBIO flag. Do not use C_Ioctl as this subprogram - -- tracks sockets set in non-blocking mode by user. - - Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); - Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); - end if; - - return R; - end C_Accept; - - --------------- - -- C_Connect -- - --------------- - - function C_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int - is - Res : C.int; - - begin - Res := Syscall_Connect (S, Name, Namelen); - - if Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= Constants.EINPROGRESS - then - return Res; - end if; - - declare - WSet : Fd_Set_Access; - Now : aliased Timeval; - - begin - WSet := New_Socket_Set (No_Socket_Set); - loop - Insert_Socket_In_Set (WSet, S); - Now := Immediat; - Res := C_Select - (S + 1, - No_Fd_Set, - WSet, - No_Fd_Set, - Now'Unchecked_Access); - - exit when Res > 0; - - if Res = Failure then - Free_Socket_Set (WSet); - return Res; - end if; - - delay Quantum; - end loop; - - Free_Socket_Set (WSet); - end; - - Res := Syscall_Connect (S, Name, Namelen); - - if Res = Failure - and then Errno = Constants.EISCONN - then - return Thin.Success; - else - return Res; - end if; - end C_Connect; - - ------------- - -- C_Ioctl -- - ------------- - - function C_Ioctl - (S : C.int; - Req : C.int; - Arg : Int_Access) return C.int - is - begin - if not Thread_Blocking_IO - and then Req = Constants.FIONBIO - then - if Arg.all /= 0 then - Set_Non_Blocking_Socket (S, True); - end if; - end if; - - return Syscall_Ioctl (S, Req, Arg); - end C_Ioctl; - - ------------ - -- C_Recv -- - ------------ - - function C_Recv - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Recv (S, Msg, Len, Flags); - exit when Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= Constants.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Recv; - - ---------------- - -- C_Recvfrom -- - ---------------- - - function C_Recvfrom - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - From : Sockaddr_In_Access; - Fromlen : access C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); - exit when Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= Constants.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Recvfrom; - - ------------ - -- C_Send -- - ------------ - - function C_Send - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Send (S, Msg, Len, Flags); - exit when Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= Constants.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Send; - - -------------- - -- C_Sendto -- - -------------- - - function C_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : Sockaddr_In_Access; - Tolen : C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); - exit when Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= Constants.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Sendto; - - -------------- - -- C_Socket -- - -------------- - - function C_Socket - (Domain : C.int; - Typ : C.int; - Protocol : C.int) return C.int - is - R : C.int; - Val : aliased C.int := 1; - - Discard : C.int; - pragma Unreferenced (Discard); - - begin - R := Syscall_Socket (Domain, Typ, Protocol); - - if not Thread_Blocking_IO - and then R /= Failure - then - -- Do not use C_Ioctl as this subprogram tracks sockets set - -- in non-blocking mode by user. - - Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); - Set_Non_Blocking_Socket (R, False); - end if; - - return R; - end C_Socket; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize is - begin - null; - end Finalize; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Process_Blocking_IO : Boolean) is - begin - Thread_Blocking_IO := not Process_Blocking_IO; - end Initialize; - - ------------------------- - -- Non_Blocking_Socket -- - ------------------------- - - function Non_Blocking_Socket (S : C.int) return Boolean is - R : Boolean; - begin - Task_Lock.Lock; - R := Is_Socket_In_Set (Non_Blocking_Sockets, S); - Task_Lock.Unlock; - return R; - end Non_Blocking_Socket; - - ----------------- - -- Set_Address -- - ----------------- - - procedure Set_Address (Sin : Sockaddr_In_Access; Address : In_Addr) is - begin - Sin.Sin_Addr := Address; - end Set_Address; - - ---------------- - -- Set_Family -- - ---------------- - - procedure Set_Family (Sin : Sockaddr_In_Access; Family : C.int) is - begin - Sin.Sin_Family := C.unsigned_short (Family); - end Set_Family; - - ---------------- - -- Set_Length -- - ---------------- - - procedure Set_Length (Sin : Sockaddr_In_Access; Len : C.int) is - pragma Unreferenced (Sin); - pragma Unreferenced (Len); - begin - null; - end Set_Length; - - ----------------------------- - -- Set_Non_Blocking_Socket -- - ----------------------------- - - procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is - begin - Task_Lock.Lock; - - if V then - Insert_Socket_In_Set (Non_Blocking_Sockets, S); - else - Remove_Socket_From_Set (Non_Blocking_Sockets, S); - end if; - - Task_Lock.Unlock; - end Set_Non_Blocking_Socket; - - -------------- - -- Set_Port -- - -------------- - - procedure Set_Port (Sin : Sockaddr_In_Access; Port : C.unsigned_short) is - begin - Sin.Sin_Port := Port; - end Set_Port; - - -------------------------- - -- Socket_Error_Message -- - -------------------------- - - function Socket_Error_Message - (Errno : Integer) return C.Strings.chars_ptr - is - use type Interfaces.C.Strings.chars_ptr; - - C_Msg : C.Strings.chars_ptr; - - begin - C_Msg := C_Strerror (C.int (Errno)); - - if C_Msg = C.Strings.Null_Ptr then - return Unknown_System_Error; - else - return C_Msg; - end if; - end Socket_Error_Message; - - ------------- - -- C_Readv -- - ------------- - - function C_Readv - (Fd : C.int; - Iov : System.Address; - Iovcnt : C.int) return C.int - is - Res : C.int; - Count : C.int := 0; - - Iovec : array (0 .. Iovcnt - 1) of Vector_Element; - for Iovec'Address use Iov; - pragma Import (Ada, Iovec); - - begin - for J in Iovec'Range loop - Res := C_Read - (Fd, - Iovec (J).Base.all'Address, - Interfaces.C.int (Iovec (J).Length)); - - if Res < 0 then - return Res; - else - Count := Count + Res; - end if; - end loop; - return Count; - end C_Readv; - - -------------- - -- C_Writev -- - -------------- - - function C_Writev - (Fd : C.int; - Iov : System.Address; - Iovcnt : C.int) return C.int - is - Res : C.int; - Count : C.int := 0; - - Iovec : array (0 .. Iovcnt - 1) of Vector_Element; - for Iovec'Address use Iov; - pragma Import (Ada, Iovec); - - begin - for J in Iovec'Range loop - Res := C_Write - (Fd, - Iovec (J).Base.all'Address, - Interfaces.C.int (Iovec (J).Length)); - - if Res < 0 then - return Res; - else - Count := Count + Res; - end if; - end loop; - return Count; - end C_Writev; - -end GNAT.Sockets.Thin; diff --git a/gcc/ada/3vsocthi.ads b/gcc/ada/3vsocthi.ads deleted file mode 100644 index a3985525f7c..00000000000 --- a/gcc/ada/3vsocthi.ads +++ /dev/null @@ -1,445 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2004 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 package provides a target dependent thin interface to the sockets --- layer for use by the GNAT.Sockets package (g-socket.ads). This package --- should not be directly with'ed by an applications program. - --- This is the Alpha/VMS version. - -with Interfaces.C.Pointers; - -with Interfaces.C.Strings; -with GNAT.Sockets.Constants; -with GNAT.OS_Lib; - -with System; - -package GNAT.Sockets.Thin is - - -- ??? more comments needed ??? - - package C renames Interfaces.C; - - use type C.int; - -- This is so we can declare the Failure constant below - - Success : constant C.int := 0; - Failure : constant C.int := -1; - - function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; - -- Returns last socket error number. - - function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr; - -- Returns the error message string for the error number Errno. If - -- Errno is not known it returns "Unknown system error". - - subtype Fd_Set_Access is System.Address; - No_Fd_Set : constant Fd_Set_Access := System.Null_Address; - - type Timeval_Unit is new C.int; - pragma Convention (C, Timeval_Unit); - - type Timeval is record - Tv_Sec : Timeval_Unit; - Tv_Usec : Timeval_Unit; - end record; - pragma Convention (C, Timeval); - - type Timeval_Access is access all Timeval; - pragma Convention (C, Timeval_Access); - - Immediat : constant Timeval := (0, 0); - - type Int_Access is access all C.int; - pragma Convention (C, Int_Access); - -- Access to C integers - - type Chars_Ptr_Array is array (C.size_t range <>) of - aliased C.Strings.chars_ptr; - - package Chars_Ptr_Pointers is - new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, - C.Strings.Null_Ptr); - -- Arrays of C (char *) - - type In_Addr is record - S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; - end record; - pragma Convention (C, In_Addr); - -- Internet address - - type In_Addr_Access is access all In_Addr; - pragma Convention (C, In_Addr_Access); - -- Access to internet address - - Inaddr_Any : aliased constant In_Addr := (others => 0); - -- Any internet address (all the interfaces) - - type In_Addr_Access_Array is array (C.size_t range <>) - of aliased In_Addr_Access; - pragma Convention (C, In_Addr_Access_Array); - - package In_Addr_Access_Pointers is - new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); - -- Array of internet addresses - - type Sockaddr is record - Sa_Family : C.unsigned_short; - Sa_Data : C.char_array (1 .. 14); - end record; - pragma Convention (C, Sockaddr); - -- Socket address - - type Sockaddr_Access is access all Sockaddr; - pragma Convention (C, Sockaddr_Access); - -- Access to socket address - - type Sockaddr_In is record - Sin_Family : C.unsigned_short := Constants.AF_INET; - Sin_Port : C.unsigned_short := 0; - Sin_Addr : In_Addr := Inaddr_Any; - Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0)); - end record; - pragma Convention (C, Sockaddr_In); - -- Internet socket address - - type Sockaddr_In_Access is access all Sockaddr_In; - pragma Convention (C, Sockaddr_In_Access); - -- Access to internet socket address - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int); - pragma Inline (Set_Length); - -- Set Sin.Sin_Length to Len. - -- On this platform, nothing is done as there is no such field. - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int); - pragma Inline (Set_Family); - -- Set Sin.Sin_Family to Family - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short); - pragma Inline (Set_Port); - -- Set Sin.Sin_Port to Port - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr); - pragma Inline (Set_Address); - -- Set Sin.Sin_Addr to Address - - type Hostent is record - H_Name : C.Strings.chars_ptr; - H_Aliases : Chars_Ptr_Pointers.Pointer; - H_Addrtype : C.int; - H_Length : C.int; - H_Addr_List : In_Addr_Access_Pointers.Pointer; - end record; - pragma Convention (C, Hostent); - -- Host entry - - type Hostent_Access is access all Hostent; - pragma Convention (C, Hostent_Access); - -- Access to host entry - - type Servent is record - S_Name : C.Strings.chars_ptr; - S_Aliases : Chars_Ptr_Pointers.Pointer; - S_Port : C.int; - S_Proto : C.Strings.chars_ptr; - end record; - pragma Convention (C, Servent); - -- Service entry - - type Servent_Access is access all Servent; - pragma Convention (C, Servent_Access); - -- Access to service entry - - type Two_Int is array (0 .. 1) of C.int; - pragma Convention (C, Two_Int); - -- Used with pipe() - - function C_Accept - (S : C.int; - Addr : System.Address; - Addrlen : access C.int) - return C.int; - - function C_Bind - (S : C.int; - Name : System.Address; - Namelen : C.int) - return C.int; - - function C_Close - (Fd : C.int) - return C.int; - - function C_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) - return C.int; - - function C_Gethostbyaddr - (Addr : System.Address; - Len : C.int; - Typ : C.int) - return Hostent_Access; - - function C_Gethostbyname - (Name : C.char_array) - return Hostent_Access; - - function C_Gethostname - (Name : System.Address; - Namelen : C.int) - return C.int; - - function C_Getpeername - (S : C.int; - Name : System.Address; - Namelen : access C.int) - return C.int; - - function C_Getservbyname - (Name : C.char_array; - Proto : C.char_array) - return Servent_Access; - - function C_Getservbyport - (Port : C.int; - Proto : C.char_array) - return Servent_Access; - - function C_Getsockname - (S : C.int; - Name : System.Address; - Namelen : access C.int) - return C.int; - - function C_Getsockopt - (S : C.int; - Level : C.int; - Optname : C.int; - Optval : System.Address; - Optlen : access C.int) - return C.int; - - function C_Inet_Addr - (Cp : C.Strings.chars_ptr) - return C.int; - - function C_Ioctl - (S : C.int; - Req : C.int; - Arg : Int_Access) - return C.int; - - function C_Listen (S, Backlog : C.int) return C.int; - - function C_Read - (Fd : C.int; - Buf : System.Address; - Count : C.int) - return C.int; - - function C_Readv - (Fd : C.int; - Iov : System.Address; - Iovcnt : C.int) - return C.int; - - function C_Recv - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) - return C.int; - - function C_Recvfrom - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - From : Sockaddr_In_Access; - Fromlen : access C.int) - return C.int; - - function C_Select - (Nfds : C.int; - Readfds : Fd_Set_Access; - Writefds : Fd_Set_Access; - Exceptfds : Fd_Set_Access; - Timeout : Timeval_Access) - return C.int; - - function C_Send - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) - return C.int; - - function C_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : Sockaddr_In_Access; - Tolen : C.int) - return C.int; - - function C_Setsockopt - (S : C.int; - Level : C.int; - Optname : C.int; - Optval : System.Address; - Optlen : C.int) - return C.int; - - function C_Shutdown - (S : C.int; - How : C.int) - return C.int; - - function C_Socket - (Domain : C.int; - Typ : C.int; - Protocol : C.int) - return C.int; - - function C_Strerror - (Errnum : C.int) - return C.Strings.chars_ptr; - - function C_System - (Command : System.Address) - return C.int; - - function C_Write - (Fd : C.int; - Buf : System.Address; - Count : C.int) - return C.int; - - function C_Writev - (Fd : C.int; - Iov : System.Address; - Iovcnt : C.int) - return C.int; - - procedure Free_Socket_Set - (Set : Fd_Set_Access); - -- Free system-dependent socket set. - - procedure Get_Socket_From_Set - (Set : Fd_Set_Access; - Socket : Int_Access; - Last : Int_Access); - -- Get last socket in Socket and remove it from the socket - -- set. The parameter Last is a maximum value of the largest - -- socket. This hint is used to avoid scanning very large socket - -- sets. After a call to Get_Socket_From_Set, Last is set back to - -- the real largest socket in the socket set. - - procedure Insert_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Insert socket in the socket set. - - function Is_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int) - return Boolean; - -- Check whether Socket is in the socket set. - - procedure Last_Socket_In_Set - (Set : Fd_Set_Access; - Last : Int_Access); - -- Find the largest socket in the socket set. This is needed for - -- select(). When Last_Socket_In_Set is called, parameter Last is - -- a maximum value of the largest socket. This hint is used to - -- avoid scanning very large socket sets. After the call, Last is - -- set back to the real largest socket in the socket set. - - function New_Socket_Set - (Set : Fd_Set_Access) - return Fd_Set_Access; - -- Allocate a new socket set which is a system-dependent structure - -- and initialize by copying Set if it is non-null, by making it - -- empty otherwise. - - procedure Remove_Socket_From_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Remove socket from the socket set. - - procedure Finalize; - procedure Initialize (Process_Blocking_IO : Boolean); - -private - - pragma Import (C, C_Bind, "DECC$BIND"); - pragma Import (C, C_Close, "DECC$CLOSE"); - pragma Import (C, C_Gethostbyaddr, "DECC$GETHOSTBYADDR"); - pragma Import (C, C_Gethostbyname, "DECC$GETHOSTBYNAME"); - pragma Import (C, C_Gethostname, "DECC$GETHOSTNAME"); - pragma Import (C, C_Getpeername, "DECC$GETPEERNAME"); - pragma Import (C, C_Getservbyname, "DECC$GETSERVBYNAME"); - pragma Import (C, C_Getservbyport, "DECC$GETSERVBYPORT"); - pragma Import (C, C_Getsockname, "DECC$GETSOCKNAME"); - pragma Import (C, C_Getsockopt, "DECC$GETSOCKOPT"); - pragma Import (C, C_Inet_Addr, "DECC$INET_ADDR"); - pragma Import (C, C_Listen, "DECC$LISTEN"); - pragma Import (C, C_Read, "DECC$READ"); - pragma Import (C, C_Select, "DECC$SELECT"); - pragma Import (C, C_Setsockopt, "DECC$SETSOCKOPT"); - pragma Import (C, C_Shutdown, "DECC$SHUTDOWN"); - pragma Import (C, C_Strerror, "DECC$STRERROR"); - pragma Import (C, C_System, "DECC$SYSTEM"); - pragma Import (C, C_Write, "DECC$WRITE"); - - pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); - pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); - pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); - pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); - pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); - pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); - pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); -end GNAT.Sockets.Thin; diff --git a/gcc/ada/3vtrasym.adb b/gcc/ada/3vtrasym.adb deleted file mode 100644 index 85f541d018b..00000000000 --- a/gcc/ada/3vtrasym.adb +++ /dev/null @@ -1,282 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . T R A C E B A C K . S Y M B O L I C -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2003 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. -- --- -- ------------------------------------------------------------------------------- - --- Run-time symbolic traceback support for VMS - -with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; -with Interfaces.C; -with System; -with System.Aux_DEC; -with System.Soft_Links; -with System.Traceback_Entries; - -package body GNAT.Traceback.Symbolic is - - pragma Warnings (Off); - pragma Linker_Options ("--for-linker=sys$library:trace.exe"); - - use Interfaces.C; - use System; - use System.Aux_DEC; - use System.Traceback_Entries; - - subtype User_Arg_Type is Unsigned_Longword; - subtype Cond_Value_Type is Unsigned_Longword; - - type ASCIC is record - Count : unsigned_char; - Data : char_array (1 .. 255); - end record; - pragma Convention (C, ASCIC); - - for ASCIC use record - Count at 0 range 0 .. 7; - Data at 1 range 0 .. 8 * 255 - 1; - end record; - for ASCIC'Size use 8 * 256; - - function Fetch_ASCIC is new Fetch_From_Address (ASCIC); - - procedure Symbolize - (Status : out Cond_Value_Type; - Current_PC : in Address; - Adjusted_PC : in Address; - Current_FP : in Address; - Current_R26 : in Address; - Image_Name : out Address; - Module_Name : out Address; - Routine_Name : out Address; - Line_Number : out Integer; - Relative_PC : out Address; - Absolute_PC : out Address; - PC_Is_Valid : out Long_Integer; - User_Act_Proc : Address := Address'Null_Parameter; - User_Arg_Value : User_Arg_Type := User_Arg_Type'Null_Parameter); - - pragma Interface (External, Symbolize); - - pragma Import_Valued_Procedure - (Symbolize, "TBK$SYMBOLIZE", - (Cond_Value_Type, Address, Address, Address, Address, - Address, Address, Address, Integer, - Address, Address, Long_Integer, - Address, User_Arg_Type), - (Value, Value, Value, Value, Value, - Reference, Reference, Reference, Reference, - Reference, Reference, Reference, - Value, Value), - User_Act_Proc); - - function Decode_Ada_Name (Encoded_Name : String) return String; - -- Decodes an Ada identifier name. Removes leading "_ada_" and trailing - -- __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.' - - --------------------- - -- Decode_Ada_Name -- - --------------------- - - function Decode_Ada_Name (Encoded_Name : String) return String is - Decoded_Name : String (1 .. Encoded_Name'Length); - Pos : Integer := Encoded_Name'First; - Last : Integer := Encoded_Name'Last; - DPos : Integer := 1; - - begin - if Pos > Last then - return ""; - end if; - - -- Skip leading _ada_ - - if Encoded_Name'Length > 4 - and then Encoded_Name (Pos .. Pos + 4) = "_ada_" - then - Pos := Pos + 5; - end if; - - -- Skip trailing __{DIGIT}+ or ${DIGIT}+ - - if Encoded_Name (Last) in '0' .. '9' then - for J in reverse Pos + 2 .. Last - 1 loop - case Encoded_Name (J) is - when '0' .. '9' => - null; - when '$' => - Last := J - 1; - exit; - when '_' => - if Encoded_Name (J - 1) = '_' then - Last := J - 2; - end if; - exit; - when others => - exit; - end case; - end loop; - end if; - - -- Now just copy encoded name to decoded name, converting "__" to '.' - - while Pos <= Last loop - if Encoded_Name (Pos) = '_' and then Encoded_Name (Pos + 1) = '_' - and then Pos /= Encoded_Name'First - then - Decoded_Name (DPos) := '.'; - Pos := Pos + 2; - - else - Decoded_Name (DPos) := Encoded_Name (Pos); - Pos := Pos + 1; - end if; - - DPos := DPos + 1; - end loop; - - return Decoded_Name (1 .. DPos - 1); - end Decode_Ada_Name; - - ------------------------ - -- Symbolic_Traceback -- - ------------------------ - - function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is - Status : Cond_Value_Type; - Image_Name : ASCIC; - Image_Name_Addr : Address; - Module_Name : ASCIC; - Module_Name_Addr : Address; - Routine_Name : ASCIC; - Routine_Name_Addr : Address; - Line_Number : Integer; - Relative_PC : Address; - Absolute_PC : Address; - PC_Is_Valid : Long_Integer; - Return_Address : Address; - Res : String (1 .. 256 * Traceback'Length); - Len : Integer; - - begin - if Traceback'Length > 0 then - Len := 0; - - -- Since image computation is not thread-safe we need task lockout - - System.Soft_Links.Lock_Task.all; - - for J in Traceback'Range loop - if J = Traceback'Last then - Return_Address := Address_Zero; - else - Return_Address := PC_For (Traceback (J + 1)); - end if; - - Symbolize - (Status, - PC_For (Traceback (J)), - PC_For (Traceback (J)), - PV_For (Traceback (J)), - Return_Address, - Image_Name_Addr, - Module_Name_Addr, - Routine_Name_Addr, - Line_Number, - Relative_PC, - Absolute_PC, - PC_Is_Valid); - - Image_Name := Fetch_ASCIC (Image_Name_Addr); - Module_Name := Fetch_ASCIC (Module_Name_Addr); - Routine_Name := Fetch_ASCIC (Routine_Name_Addr); - - declare - First : Integer := Len + 1; - Last : Integer := First + 80 - 1; - Pos : Integer; - Routine_Name_D : String := Decode_Ada_Name - (To_Ada - (Routine_Name.Data (1 .. size_t (Routine_Name.Count)), - False)); - - begin - Res (First .. Last) := (others => ' '); - - Res (First .. First + Integer (Image_Name.Count) - 1) := - To_Ada - (Image_Name.Data (1 .. size_t (Image_Name.Count)), - False); - - Res (First + 10 .. - First + 10 + Integer (Module_Name.Count) - 1) := - To_Ada - (Module_Name.Data (1 .. size_t (Module_Name.Count)), - False); - - Res (First + 30 .. - First + 30 + Routine_Name_D'Length - 1) := - Routine_Name_D; - - -- If routine name doesn't fit 20 characters, output - -- the line number on next line at 50th position - - if Routine_Name_D'Length > 20 then - Pos := First + 30 + Routine_Name_D'Length; - Res (Pos) := ASCII.LF; - Last := Pos + 80; - Res (Pos + 1 .. Last) := (others => ' '); - Pos := Pos + 51; - else - Pos := First + 50; - end if; - - Res (Pos .. Pos + Integer'Image (Line_Number)'Length - 1) := - Integer'Image (Line_Number); - - Res (Last) := ASCII.LF; - Len := Last; - end; - end loop; - - System.Soft_Links.Unlock_Task.all; - return Res (1 .. Len); - - else - return ""; - end if; - end Symbolic_Traceback; - - function Symbolic_Traceback (E : Exception_Occurrence) return String is - begin - return Symbolic_Traceback (Tracebacks (E)); - end Symbolic_Traceback; - -end GNAT.Traceback.Symbolic; diff --git a/gcc/ada/3wsoccon.ads b/gcc/ada/3wsoccon.ads deleted file mode 100644 index b4bb31564dc..00000000000 --- a/gcc/ada/3wsoccon.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . C O N S T A N T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2003 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 target dependent definitions of constant for use --- by the GNAT.Sockets package (g-socket.ads). This package should not be --- directly with'ed by an applications program. - --- This is the version for MINGW32 NT - -package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := 3; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 10013; -- Permission denied - EADDRINUSE : constant := 10048; -- Address already in use - EADDRNOTAVAIL : constant := 10049; -- Cannot assign address - EAFNOSUPPORT : constant := 10047; -- Addr family not supported - EALREADY : constant := 10037; -- Operation in progress - EBADF : constant := 10009; -- Bad file descriptor - ECONNABORTED : constant := 10053; -- Connection aborted - ECONNREFUSED : constant := 10061; -- Connection refused - ECONNRESET : constant := 10054; -- Connection reset by peer - EDESTADDRREQ : constant := 10039; -- Destination addr required - EFAULT : constant := 10014; -- Bad address - EHOSTDOWN : constant := 10064; -- Host is down - EHOSTUNREACH : constant := 10065; -- No route to host - EINPROGRESS : constant := 10036; -- Operation now in progress - EINTR : constant := 10004; -- Interrupted system call - EINVAL : constant := 10022; -- Invalid argument - EIO : constant := 10101; -- Input output error - EISCONN : constant := 10056; -- Socket already connected - ELOOP : constant := 10062; -- Too many symbolic lynks - EMFILE : constant := 10024; -- Too many open files - EMSGSIZE : constant := 10040; -- Message too long - ENAMETOOLONG : constant := 10063; -- Name too long - ENETDOWN : constant := 10050; -- Network is down - ENETRESET : constant := 10052; -- Disconn. on network reset - ENETUNREACH : constant := 10051; -- Network is unreachable - ENOBUFS : constant := 10055; -- No buffer space available - ENOPROTOOPT : constant := 10042; -- Protocol not available - ENOTCONN : constant := 10057; -- Socket not connected - ENOTSOCK : constant := 10038; -- Operation on non socket - EOPNOTSUPP : constant := 10045; -- Operation not supported - EPFNOSUPPORT : constant := 10046; -- Unknown protocol family - EPROTONOSUPPORT : constant := 10043; -- Unknown protocol - EPROTOTYPE : constant := 10041; -- Unknown protocol type - ESHUTDOWN : constant := 10058; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 10044; -- Socket type not supported - ETIMEDOUT : constant := 10060; -- Connection timed out - ETOOMANYREFS : constant := 10059; -- Too many references - EWOULDBLOCK : constant := 10035; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 11001; -- Unknown host - TRY_AGAIN : constant := 11002; -- Host name lookup failure - NO_DATA : constant := 11004; -- No data record for name - NO_RECOVERY : constant := 11003; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := -2147195266; -- Set/clear non-blocking io - FIONREAD : constant := 1074030207; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := -1; -- Send end of record - MSG_WAITALL : constant := -1; -- Wait for full reception - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_ERROR : constant := 4103; -- Get/clear error status - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group - IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback - -end GNAT.Sockets.Constants; diff --git a/gcc/ada/3wsocthi.adb b/gcc/ada/3wsocthi.adb deleted file mode 100644 index a948bdeedfa..00000000000 --- a/gcc/ada/3wsocthi.adb +++ /dev/null @@ -1,587 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2004 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 package provides a target dependent thin interface to the sockets --- layer for use by the GNAT.Sockets package (g-socket.ads). This package --- should not be directly with'ed by an applications program. - --- This version is for NT. - -with GNAT.Sockets.Constants; use GNAT.Sockets.Constants; -with Interfaces.C.Strings; use Interfaces.C.Strings; - -with System; use System; - -package body GNAT.Sockets.Thin is - - use type C.unsigned; - - WSAData_Dummy : array (1 .. 512) of C.int; - - WS_Version : constant := 16#0101#; - Initialized : Boolean := False; - - SYSNOTREADY : constant := 10091; - VERNOTSUPPORTED : constant := 10092; - NOTINITIALISED : constant := 10093; - EDISCON : constant := 10101; - - function Standard_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) - return C.int; - pragma Import (Stdcall, Standard_Connect, "connect"); - - function Standard_Select - (Nfds : C.int; - Readfds : Fd_Set_Access; - Writefds : Fd_Set_Access; - Exceptfds : Fd_Set_Access; - Timeout : Timeval_Access) - return C.int; - pragma Import (Stdcall, Standard_Select, "select"); - - type Error_Type is - (N_EINTR, - N_EBADF, - N_EACCES, - N_EFAULT, - N_EINVAL, - N_EMFILE, - N_EWOULDBLOCK, - N_EINPROGRESS, - N_EALREADY, - N_ENOTSOCK, - N_EDESTADDRREQ, - N_EMSGSIZE, - N_EPROTOTYPE, - N_ENOPROTOOPT, - N_EPROTONOSUPPORT, - N_ESOCKTNOSUPPORT, - N_EOPNOTSUPP, - N_EPFNOSUPPORT, - N_EAFNOSUPPORT, - N_EADDRINUSE, - N_EADDRNOTAVAIL, - N_ENETDOWN, - N_ENETUNREACH, - N_ENETRESET, - N_ECONNABORTED, - N_ECONNRESET, - N_ENOBUFS, - N_EISCONN, - N_ENOTCONN, - N_ESHUTDOWN, - N_ETOOMANYREFS, - N_ETIMEDOUT, - N_ECONNREFUSED, - N_ELOOP, - N_ENAMETOOLONG, - N_EHOSTDOWN, - N_EHOSTUNREACH, - N_SYSNOTREADY, - N_VERNOTSUPPORTED, - N_NOTINITIALISED, - N_EDISCON, - N_HOST_NOT_FOUND, - N_TRY_AGAIN, - N_NO_RECOVERY, - N_NO_DATA, - N_OTHERS); - - Error_Messages : constant array (Error_Type) of chars_ptr := - (N_EINTR => - New_String ("Interrupted system call"), - N_EBADF => - New_String ("Bad file number"), - N_EACCES => - New_String ("Permission denied"), - N_EFAULT => - New_String ("Bad address"), - N_EINVAL => - New_String ("Invalid argument"), - N_EMFILE => - New_String ("Too many open files"), - N_EWOULDBLOCK => - New_String ("Operation would block"), - N_EINPROGRESS => - New_String ("Operation now in progress. This error is " - & "returned if any Windows Sockets API " - & "function is called while a blocking " - & "function is in progress"), - N_EALREADY => - New_String ("Operation already in progress"), - N_ENOTSOCK => - New_String ("Socket operation on nonsocket"), - N_EDESTADDRREQ => - New_String ("Destination address required"), - N_EMSGSIZE => - New_String ("Message too long"), - N_EPROTOTYPE => - New_String ("Protocol wrong type for socket"), - N_ENOPROTOOPT => - New_String ("Protocol not available"), - N_EPROTONOSUPPORT => - New_String ("Protocol not supported"), - N_ESOCKTNOSUPPORT => - New_String ("Socket type not supported"), - N_EOPNOTSUPP => - New_String ("Operation not supported on socket"), - N_EPFNOSUPPORT => - New_String ("Protocol family not supported"), - N_EAFNOSUPPORT => - New_String ("Address family not supported by protocol family"), - N_EADDRINUSE => - New_String ("Address already in use"), - N_EADDRNOTAVAIL => - New_String ("Cannot assign requested address"), - N_ENETDOWN => - New_String ("Network is down. This error may be " - & "reported at any time if the Windows " - & "Sockets implementation detects an " - & "underlying failure"), - N_ENETUNREACH => - New_String ("Network is unreachable"), - N_ENETRESET => - New_String ("Network dropped connection on reset"), - N_ECONNABORTED => - New_String ("Software caused connection abort"), - N_ECONNRESET => - New_String ("Connection reset by peer"), - N_ENOBUFS => - New_String ("No buffer space available"), - N_EISCONN => - New_String ("Socket is already connected"), - N_ENOTCONN => - New_String ("Socket is not connected"), - N_ESHUTDOWN => - New_String ("Cannot send after socket shutdown"), - N_ETOOMANYREFS => - New_String ("Too many references: cannot splice"), - N_ETIMEDOUT => - New_String ("Connection timed out"), - N_ECONNREFUSED => - New_String ("Connection refused"), - N_ELOOP => - New_String ("Too many levels of symbolic links"), - N_ENAMETOOLONG => - New_String ("File name too long"), - N_EHOSTDOWN => - New_String ("Host is down"), - N_EHOSTUNREACH => - New_String ("No route to host"), - N_SYSNOTREADY => - New_String ("Returned by WSAStartup(), indicating that " - & "the network subsystem is unusable"), - N_VERNOTSUPPORTED => - New_String ("Returned by WSAStartup(), indicating that " - & "the Windows Sockets DLL cannot support " - & "this application"), - N_NOTINITIALISED => - New_String ("Winsock not initialized. This message is " - & "returned by any function except WSAStartup(), " - & "indicating that a successful WSAStartup() has " - & "not yet been performed"), - N_EDISCON => - New_String ("Disconnect"), - N_HOST_NOT_FOUND => - New_String ("Host not found. This message indicates " - & "that the key (name, address, and so on) was not found"), - N_TRY_AGAIN => - New_String ("Nonauthoritative host not found. This error may " - & "suggest that the name service itself is not " - & "functioning"), - N_NO_RECOVERY => - New_String ("Nonrecoverable error. This error may suggest that the " - & "name service itself is not functioning"), - N_NO_DATA => - New_String ("Valid name, no data record of requested type. " - & "This error indicates that the key (name, address, " - & "and so on) was not found."), - N_OTHERS => - New_String ("Unknown system error")); - - --------------- - -- C_Connect -- - --------------- - - function C_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) - return C.int - is - Res : C.int; - - begin - Res := Standard_Connect (S, Name, Namelen); - - if Res = -1 then - if Socket_Errno = EWOULDBLOCK then - Set_Socket_Errno (EINPROGRESS); - end if; - end if; - - return Res; - end C_Connect; - - ------------- - -- C_Readv -- - ------------- - - function C_Readv - (Socket : C.int; - Iov : System.Address; - Iovcnt : C.int) - return C.int - is - Res : C.int; - Count : C.int := 0; - - Iovec : array (0 .. Iovcnt - 1) of Vector_Element; - for Iovec'Address use Iov; - pragma Import (Ada, Iovec); - - begin - for J in Iovec'Range loop - Res := C_Recv - (Socket, - Iovec (J).Base.all'Address, - C.int (Iovec (J).Length), - 0); - - if Res < 0 then - return Res; - else - Count := Count + Res; - end if; - end loop; - return Count; - end C_Readv; - - -------------- - -- C_Select -- - -------------- - - function C_Select - (Nfds : C.int; - Readfds : Fd_Set_Access; - Writefds : Fd_Set_Access; - Exceptfds : Fd_Set_Access; - Timeout : Timeval_Access) - return C.int - is - pragma Warnings (Off, Exceptfds); - - RFS : constant Fd_Set_Access := Readfds; - WFS : constant Fd_Set_Access := Writefds; - WFSC : Fd_Set_Access := No_Fd_Set; - EFS : Fd_Set_Access := Exceptfds; - Res : C.int; - S : aliased C.int; - Last : aliased C.int; - - begin - -- Asynchronous connection failures are notified in the - -- exception fd set instead of the write fd set. To ensure - -- POSIX compatitibility, copy write fd set into exception fd - -- set. Once select() returns, check any socket present in the - -- exception fd set and peek at incoming out-of-band data. If - -- the test is not successfull and if the socket is present in - -- the initial write fd set, then move the socket from the - -- exception fd set to the write fd set. - - if WFS /= No_Fd_Set then - -- Add any socket present in write fd set into exception fd set - - if EFS = No_Fd_Set then - EFS := New_Socket_Set (WFS); - - else - WFSC := New_Socket_Set (WFS); - - Last := Nfds - 1; - loop - Get_Socket_From_Set - (WFSC, S'Unchecked_Access, Last'Unchecked_Access); - exit when S = -1; - Insert_Socket_In_Set (EFS, S); - end loop; - - Free_Socket_Set (WFSC); - end if; - - -- Keep a copy of write fd set - - WFSC := New_Socket_Set (WFS); - end if; - - Res := Standard_Select (Nfds, RFS, WFS, EFS, Timeout); - - if EFS /= No_Fd_Set then - declare - EFSC : constant Fd_Set_Access := New_Socket_Set (EFS); - Flag : constant C.int := MSG_PEEK + MSG_OOB; - Buffer : Character; - Length : C.int; - Fromlen : aliased C.int; - - begin - Last := Nfds - 1; - loop - Get_Socket_From_Set - (EFSC, S'Unchecked_Access, Last'Unchecked_Access); - - -- No more sockets in EFSC - - exit when S = -1; - - -- Check out-of-band data - - Length := C_Recvfrom - (S, Buffer'Address, 1, Flag, - null, Fromlen'Unchecked_Access); - - -- If the signal is not an out-of-band data, then it - -- is a connection failure notification. - - if Length = -1 then - Remove_Socket_From_Set (EFS, S); - - -- If S is present in the initial write fd set, - -- move it from exception fd set back to write fd - -- set. Otherwise, ignore this event since the user - -- is not watching for it. - - if WFSC /= No_Fd_Set - and then Is_Socket_In_Set (WFSC, S) - then - Insert_Socket_In_Set (WFS, S); - end if; - end if; - end loop; - - Free_Socket_Set (EFSC); - end; - - if Exceptfds = No_Fd_Set then - Free_Socket_Set (EFS); - end if; - end if; - - -- Free any copy of write fd set - - if WFSC /= No_Fd_Set then - Free_Socket_Set (WFSC); - end if; - - return Res; - end C_Select; - - -------------- - -- C_Writev -- - -------------- - - function C_Writev - (Socket : C.int; - Iov : System.Address; - Iovcnt : C.int) - return C.int - is - Res : C.int; - Count : C.int := 0; - - Iovec : array (0 .. Iovcnt - 1) of Vector_Element; - for Iovec'Address use Iov; - pragma Import (Ada, Iovec); - - begin - for J in Iovec'Range loop - Res := C_Send - (Socket, - Iovec (J).Base.all'Address, - C.int (Iovec (J).Length), - 0); - - if Res < 0 then - return Res; - else - Count := Count + Res; - end if; - end loop; - return Count; - end C_Writev; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize is - begin - if Initialized then - WSACleanup; - Initialized := False; - end if; - end Finalize; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Process_Blocking_IO : Boolean := False) is - pragma Unreferenced (Process_Blocking_IO); - - Return_Value : Interfaces.C.int; - - begin - if not Initialized then - Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address); - pragma Assert (Interfaces.C."=" (Return_Value, 0)); - Initialized := True; - end if; - end Initialize; - - ----------------- - -- Set_Address -- - ----------------- - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr) - is - begin - Sin.Sin_Addr := Address; - end Set_Address; - - ---------------- - -- Set_Family -- - ---------------- - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int) - is - begin - Sin.Sin_Family := C.unsigned_short (Family); - end Set_Family; - - ---------------- - -- Set_Length -- - ---------------- - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int) - is - pragma Unreferenced (Sin); - pragma Unreferenced (Len); - - begin - null; - end Set_Length; - - -------------- - -- Set_Port -- - -------------- - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short) - is - begin - Sin.Sin_Port := Port; - end Set_Port; - - -------------------------- - -- Socket_Error_Message -- - -------------------------- - - function Socket_Error_Message - (Errno : Integer) - return C.Strings.chars_ptr - is - use GNAT.Sockets.Constants; - - begin - case Errno is - when EINTR => return Error_Messages (N_EINTR); - when EBADF => return Error_Messages (N_EBADF); - when EACCES => return Error_Messages (N_EACCES); - when EFAULT => return Error_Messages (N_EFAULT); - when EINVAL => return Error_Messages (N_EINVAL); - when EMFILE => return Error_Messages (N_EMFILE); - when EWOULDBLOCK => return Error_Messages (N_EWOULDBLOCK); - when EINPROGRESS => return Error_Messages (N_EINPROGRESS); - when EALREADY => return Error_Messages (N_EALREADY); - when ENOTSOCK => return Error_Messages (N_ENOTSOCK); - when EDESTADDRREQ => return Error_Messages (N_EDESTADDRREQ); - when EMSGSIZE => return Error_Messages (N_EMSGSIZE); - when EPROTOTYPE => return Error_Messages (N_EPROTOTYPE); - when ENOPROTOOPT => return Error_Messages (N_ENOPROTOOPT); - when EPROTONOSUPPORT => return Error_Messages (N_EPROTONOSUPPORT); - when ESOCKTNOSUPPORT => return Error_Messages (N_ESOCKTNOSUPPORT); - when EOPNOTSUPP => return Error_Messages (N_EOPNOTSUPP); - when EPFNOSUPPORT => return Error_Messages (N_EPFNOSUPPORT); - when EAFNOSUPPORT => return Error_Messages (N_EAFNOSUPPORT); - when EADDRINUSE => return Error_Messages (N_EADDRINUSE); - when EADDRNOTAVAIL => return Error_Messages (N_EADDRNOTAVAIL); - when ENETDOWN => return Error_Messages (N_ENETDOWN); - when ENETUNREACH => return Error_Messages (N_ENETUNREACH); - when ENETRESET => return Error_Messages (N_ENETRESET); - when ECONNABORTED => return Error_Messages (N_ECONNABORTED); - when ECONNRESET => return Error_Messages (N_ECONNRESET); - when ENOBUFS => return Error_Messages (N_ENOBUFS); - when EISCONN => return Error_Messages (N_EISCONN); - when ENOTCONN => return Error_Messages (N_ENOTCONN); - when ESHUTDOWN => return Error_Messages (N_ESHUTDOWN); - when ETOOMANYREFS => return Error_Messages (N_ETOOMANYREFS); - when ETIMEDOUT => return Error_Messages (N_ETIMEDOUT); - when ECONNREFUSED => return Error_Messages (N_ECONNREFUSED); - when ELOOP => return Error_Messages (N_ELOOP); - when ENAMETOOLONG => return Error_Messages (N_ENAMETOOLONG); - when EHOSTDOWN => return Error_Messages (N_EHOSTDOWN); - when EHOSTUNREACH => return Error_Messages (N_EHOSTUNREACH); - when SYSNOTREADY => return Error_Messages (N_SYSNOTREADY); - when VERNOTSUPPORTED => return Error_Messages (N_VERNOTSUPPORTED); - when NOTINITIALISED => return Error_Messages (N_NOTINITIALISED); - when EDISCON => return Error_Messages (N_EDISCON); - when HOST_NOT_FOUND => return Error_Messages (N_HOST_NOT_FOUND); - when TRY_AGAIN => return Error_Messages (N_TRY_AGAIN); - when NO_RECOVERY => return Error_Messages (N_NO_RECOVERY); - when NO_DATA => return Error_Messages (N_NO_DATA); - when others => return Error_Messages (N_OTHERS); - end case; - end Socket_Error_Message; - -end GNAT.Sockets.Thin; diff --git a/gcc/ada/3wsocthi.ads b/gcc/ada/3wsocthi.ads deleted file mode 100644 index 5ee990e8628..00000000000 --- a/gcc/ada/3wsocthi.ads +++ /dev/null @@ -1,433 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2004 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 package provides a target dependent thin interface to the sockets --- layer for use by the GNAT.Sockets package (g-socket.ads). This package --- should not be directly with'ed by an applications program. - --- This version is for NT - -with Interfaces.C.Pointers; -with Interfaces.C.Strings; - -with GNAT.Sockets.Constants; - -with System; - -package GNAT.Sockets.Thin is - - package C renames Interfaces.C; - - use type C.int; - -- So that we can declare the Failure constant below. - - Success : constant C.int := 0; - Failure : constant C.int := -1; - - function Socket_Errno return Integer; - -- Returns last socket error number. - - procedure Set_Socket_Errno (Errno : Integer); - -- Set last socket error number. - - function Socket_Error_Message - (Errno : Integer) - return C.Strings.chars_ptr; - -- Returns the error message string for the error number Errno. If - -- Errno is not known it returns "Unknown system error". - - subtype Fd_Set_Access is System.Address; - No_Fd_Set : constant Fd_Set_Access := System.Null_Address; - - type Timeval_Unit is new C.long; - pragma Convention (C, Timeval_Unit); - - type Timeval is record - Tv_Sec : Timeval_Unit; - Tv_Usec : Timeval_Unit; - end record; - pragma Convention (C, Timeval); - - type Timeval_Access is access all Timeval; - pragma Convention (C, Timeval_Access); - - Immediat : constant Timeval := (0, 0); - - type Int_Access is access all C.int; - pragma Convention (C, Int_Access); - -- Access to C integers - - type Chars_Ptr_Array is array (C.size_t range <>) of - aliased C.Strings.chars_ptr; - - package Chars_Ptr_Pointers is - new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, - C.Strings.Null_Ptr); - -- Arrays of C (char *) - - type In_Addr is record - S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; - end record; - pragma Convention (C, In_Addr); - -- Internet address - - type In_Addr_Access is access all In_Addr; - pragma Convention (C, In_Addr_Access); - -- Access to internet address - - Inaddr_Any : aliased constant In_Addr := (others => 0); - -- Any internet address (all the interfaces) - - type In_Addr_Access_Array is array (C.size_t range <>) - of aliased In_Addr_Access; - pragma Convention (C, In_Addr_Access_Array); - package In_Addr_Access_Pointers is - new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); - -- Array of internet addresses - - type Sockaddr is record - Sa_Family : C.unsigned_short; - Sa_Data : C.char_array (1 .. 14); - end record; - pragma Convention (C, Sockaddr); - -- Socket address - - type Sockaddr_Access is access all Sockaddr; - pragma Convention (C, Sockaddr_Access); - -- Access to socket address - - type Sockaddr_In is record - Sin_Family : C.unsigned_short := Constants.AF_INET; - Sin_Port : C.unsigned_short := 0; - Sin_Addr : In_Addr := Inaddr_Any; - Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0)); - end record; - pragma Convention (C, Sockaddr_In); - -- Internet socket address - - type Sockaddr_In_Access is access all Sockaddr_In; - pragma Convention (C, Sockaddr_In_Access); - -- Access to internet socket address - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int); - pragma Inline (Set_Length); - -- Set Sin.Sin_Length to Len. - -- On this platform, nothing is done as there is no such field. - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int); - pragma Inline (Set_Family); - -- Set Sin.Sin_Family to Family - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short); - pragma Inline (Set_Port); - -- Set Sin.Sin_Port to Port - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr); - pragma Inline (Set_Address); - -- Set Sin.Sin_Addr to Address - - type Hostent is record - H_Name : C.Strings.chars_ptr; - H_Aliases : Chars_Ptr_Pointers.Pointer; - H_Addrtype : C.short; - H_Length : C.short; - H_Addr_List : In_Addr_Access_Pointers.Pointer; - end record; - pragma Convention (C, Hostent); - -- Host entry - - type Hostent_Access is access all Hostent; - pragma Convention (C, Hostent_Access); - -- Access to host entry - - type Servent is record - S_Name : C.Strings.chars_ptr; - S_Aliases : Chars_Ptr_Pointers.Pointer; - S_Port : C.int; - S_Proto : C.Strings.chars_ptr; - end record; - pragma Convention (C, Servent); - -- Service entry - - type Servent_Access is access all Servent; - pragma Convention (C, Servent_Access); - -- Access to service entry - - type Two_Int is array (0 .. 1) of C.int; - pragma Convention (C, Two_Int); - -- Used with pipe() - - function C_Accept - (S : C.int; - Addr : System.Address; - Addrlen : access C.int) return C.int; - - function C_Bind - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int; - - function C_Close - (Fd : C.int) return C.int; - - function C_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int; - - function C_Gethostbyaddr - (Addr : System.Address; - Length : C.int; - Typ : C.int) return Hostent_Access; - - function C_Gethostbyname - (Name : C.char_array) return Hostent_Access; - - function C_Gethostname - (Name : System.Address; - Namelen : C.int) return C.int; - - function C_Getpeername - (S : C.int; - Name : System.Address; - Namelen : access C.int) return C.int; - - function C_Getservbyname - (Name : C.char_array; - Proto : C.char_array) return Servent_Access; - - function C_Getservbyport - (Port : C.int; - Proto : C.char_array) return Servent_Access; - - function C_Getsockname - (S : C.int; - Name : System.Address; - Namelen : access C.int) return C.int; - - function C_Getsockopt - (S : C.int; - Level : C.int; - Optname : C.int; - Optval : System.Address; - Optlen : access C.int) return C.int; - - function C_Inet_Addr - (Cp : C.Strings.chars_ptr) return C.int; - - function C_Ioctl - (S : C.int; - Req : C.int; - Arg : Int_Access) return C.int; - - function C_Listen - (S : C.int; - Backlog : C.int) return C.int; - - function C_Read - (Fildes : C.int; - Buf : System.Address; - Nbyte : C.int) return C.int; - - function C_Readv - (Socket : C.int; - Iov : System.Address; - Iovcnt : C.int) return C.int; - - function C_Recv - (S : C.int; - Buf : System.Address; - Len : C.int; - Flags : C.int) return C.int; - - function C_Recvfrom - (S : C.int; - Buf : System.Address; - Len : C.int; - Flags : C.int; - From : Sockaddr_In_Access; - Fromlen : access C.int) return C.int; - - function C_Select - (Nfds : C.int; - Readfds : Fd_Set_Access; - Writefds : Fd_Set_Access; - Exceptfds : Fd_Set_Access; - Timeout : Timeval_Access) return C.int; - - function C_Send - (S : C.int; - Buf : System.Address; - Len : C.int; - Flags : C.int) return C.int; - - function C_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : Sockaddr_In_Access; - Tolen : C.int) return C.int; - - function C_Setsockopt - (S : C.int; - Level : C.int; - Optname : C.int; - Optval : System.Address; - Optlen : C.int) return C.int; - - function C_Shutdown - (S : C.int; - How : C.int) return C.int; - - function C_Socket - (Domain : C.int; - Typ : C.int; - Protocol : C.int) return C.int; - - function C_Strerror - (Errnum : C.int) return C.Strings.chars_ptr; - - function C_System - (Command : System.Address) return C.int; - - function C_Write - (Fildes : C.int; - Buf : System.Address; - Nbyte : C.int) return C.int; - - function C_Writev - (Socket : C.int; - Iov : System.Address; - Iovcnt : C.int) return C.int; - - function WSAStartup - (WS_Version : Interfaces.C.int; - WSADataAddress : System.Address) return Interfaces.C.int; - - procedure Free_Socket_Set - (Set : Fd_Set_Access); - -- Free system-dependent socket set. - - procedure Get_Socket_From_Set - (Set : Fd_Set_Access; - Socket : Int_Access; - Last : Int_Access); - -- Get last socket in Socket and remove it from the socket - -- set. The parameter Last is a maximum value of the largest - -- socket. This hint is used to avoid scanning very large socket - -- sets. After a call to Get_Socket_From_Set, Last is set back to - -- the real largest socket in the socket set. - - procedure Insert_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Insert socket in the socket set - - function Is_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int) return Boolean; - -- Check whether Socket is in the socket set - - procedure Last_Socket_In_Set - (Set : Fd_Set_Access; - Last : Int_Access); - -- Find the largest socket in the socket set. This is needed for - -- select(). When Last_Socket_In_Set is called, parameter Last is - -- a maximum value of the largest socket. This hint is used to - -- avoid scanning very large socket sets. After the call, Last is - -- set back to the real largest socket in the socket set. - - function New_Socket_Set - (Set : Fd_Set_Access) return Fd_Set_Access; - -- Allocate a new socket set which is a system-dependent structure - -- and initialize by copying Set if it is non-null, by making it - -- empty otherwise. - - procedure Remove_Socket_From_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Remove socket from the socket set - - procedure WSACleanup; - - procedure Finalize; - procedure Initialize (Process_Blocking_IO : Boolean := False); - -private - pragma Import (Stdcall, C_Accept, "accept"); - pragma Import (Stdcall, C_Bind, "bind"); - pragma Import (Stdcall, C_Close, "closesocket"); - pragma Import (Stdcall, C_Gethostbyaddr, "gethostbyaddr"); - pragma Import (Stdcall, C_Gethostbyname, "gethostbyname"); - pragma Import (Stdcall, C_Gethostname, "gethostname"); - pragma Import (Stdcall, C_Getpeername, "getpeername"); - pragma Import (Stdcall, C_Getservbyname, "getservbyname"); - pragma Import (Stdcall, C_Getservbyport, "getservbyport"); - pragma Import (Stdcall, C_Getsockname, "getsockname"); - pragma Import (Stdcall, C_Getsockopt, "getsockopt"); - pragma Import (Stdcall, C_Inet_Addr, "inet_addr"); - pragma Import (Stdcall, C_Ioctl, "ioctlsocket"); - pragma Import (Stdcall, C_Listen, "listen"); - pragma Import (C, C_Read, "_read"); - pragma Import (Stdcall, C_Recv, "recv"); - pragma Import (Stdcall, C_Recvfrom, "recvfrom"); - pragma Import (Stdcall, C_Send, "send"); - pragma Import (Stdcall, C_Sendto, "sendto"); - pragma Import (Stdcall, C_Setsockopt, "setsockopt"); - pragma Import (Stdcall, C_Shutdown, "shutdown"); - pragma Import (Stdcall, C_Socket, "socket"); - pragma Import (C, C_Strerror, "strerror"); - pragma Import (C, C_System, "_system"); - pragma Import (C, C_Write, "_write"); - pragma Import (Stdcall, Socket_Errno, "WSAGetLastError"); - pragma Import (Stdcall, Set_Socket_Errno, "WSASetLastError"); - pragma Import (Stdcall, WSAStartup, "WSAStartup"); - pragma Import (Stdcall, WSACleanup, "WSACleanup"); - - pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); - pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); - pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); - pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); - pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); - pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); - pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); -end GNAT.Sockets.Thin; diff --git a/gcc/ada/3wsoliop.ads b/gcc/ada/3wsoliop.ads deleted file mode 100644 index e930da934d5..00000000000 --- a/gcc/ada/3wsoliop.ads +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-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 package is used to provide target specific linker_options for the --- support of scokets as required by the package GNAT.Sockets. - --- This is the Windows/NT version of this package - - -package GNAT.Sockets.Linker_Options is -private - pragma Linker_Options ("-lwsock32"); -end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/3zsoccon.ads b/gcc/ada/3zsoccon.ads deleted file mode 100644 index 27dcb0c7a9e..00000000000 --- a/gcc/ada/3zsoccon.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . C O N S T A N T S -- --- -- --- S p e c -- --- -- --- 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 package provides target dependent definitions of constant for use --- by the GNAT.Sockets package (g-socket.ads). This package should not be --- directly with'ed by an applications program. - --- This is the version for VxWorks - -package GNAT.Sockets.Constants is - - -------------- - -- Families -- - -------------- - - AF_INET : constant := 2; -- IPv4 address family - AF_INET6 : constant := -1; -- IPv6 address family - - ----------- - -- Modes -- - ----------- - - SOCK_STREAM : constant := 1; -- Stream socket - SOCK_DGRAM : constant := 2; -- Datagram socket - - ------------------- - -- Socket errors -- - ------------------- - - EACCES : constant := 13; -- Permission denied - EADDRINUSE : constant := 48; -- Address already in use - EADDRNOTAVAIL : constant := 49; -- Cannot assign address - EAFNOSUPPORT : constant := 47; -- Addr family not supported - EALREADY : constant := 69; -- Operation in progress - EBADF : constant := 9; -- Bad file descriptor - ECONNABORTED : constant := 53; -- Connection aborted - ECONNREFUSED : constant := 61; -- Connection refused - ECONNRESET : constant := 54; -- Connection reset by peer - EDESTADDRREQ : constant := 40; -- Destination addr required - EFAULT : constant := 14; -- Bad address - EHOSTDOWN : constant := 67; -- Host is down - EHOSTUNREACH : constant := 65; -- No route to host - EINPROGRESS : constant := 68; -- Operation now in progress - EINTR : constant := 4; -- Interrupted system call - EINVAL : constant := 22; -- Invalid argument - EIO : constant := 5; -- Input output error - EISCONN : constant := 56; -- Socket already connected - ELOOP : constant := 64; -- Too many symbolic lynks - EMFILE : constant := 24; -- Too many open files - EMSGSIZE : constant := 36; -- Message too long - ENAMETOOLONG : constant := 26; -- Name too long - ENETDOWN : constant := 62; -- Network is down - ENETRESET : constant := 52; -- Disconn. on network reset - ENETUNREACH : constant := 51; -- Network is unreachable - ENOBUFS : constant := 55; -- No buffer space available - ENOPROTOOPT : constant := 42; -- Protocol not available - ENOTCONN : constant := 57; -- Socket not connected - ENOTSOCK : constant := 50; -- Operation on non socket - EOPNOTSUPP : constant := 45; -- Operation not supported - EPFNOSUPPORT : constant := 46; -- Unknown protocol family - EPROTONOSUPPORT : constant := 43; -- Unknown protocol - EPROTOTYPE : constant := 41; -- Unknown protocol type - ESHUTDOWN : constant := 58; -- Cannot send once shutdown - ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported - ETIMEDOUT : constant := 60; -- Connection timed out - ETOOMANYREFS : constant := 59; -- Too many references - EWOULDBLOCK : constant := 70; -- Operation would block - - ----------------- - -- Host errors -- - ----------------- - - HOST_NOT_FOUND : constant := 1; -- Unknown host - TRY_AGAIN : constant := 2; -- Host name lookup failure - NO_DATA : constant := 4; -- No data record for name - NO_RECOVERY : constant := 3; -- Non recoverable errors - - ------------------- - -- Control flags -- - ------------------- - - FIONBIO : constant := 16; -- Set/clear non-blocking io - FIONREAD : constant := 1; -- How many bytes to read - - -------------------- - -- Shutdown modes -- - -------------------- - - SHUT_RD : constant := 0; -- No more recv - SHUT_WR : constant := 1; -- No more send - SHUT_RDWR : constant := 2; -- No more recv/send - - --------------------- - -- Protocol levels -- - --------------------- - - SOL_SOCKET : constant := 65535; -- Options for socket level - IPPROTO_IP : constant := 0; -- Dummy protocol for IP - IPPROTO_UDP : constant := 17; -- UDP - IPPROTO_TCP : constant := 6; -- TCP - - ------------------- - -- Request flags -- - ------------------- - - MSG_OOB : constant := 1; -- Process out-of-band data - MSG_PEEK : constant := 2; -- Peek at incoming data - MSG_EOR : constant := 8; -- Send end of record - MSG_WAITALL : constant := 64; -- Wait for full reception - - -------------------- - -- Socket options -- - -------------------- - - TCP_NODELAY : constant := 1; -- Do not coalesce packets - SO_SNDBUF : constant := 4097; -- Set/get send buffer size - SO_RCVBUF : constant := 4098; -- Set/get recv buffer size - SO_REUSEADDR : constant := 4; -- Bind reuse local address - SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs - SO_LINGER : constant := 128; -- Defer close to flush data - SO_ERROR : constant := 4103; -- Get/clear error status - SO_BROADCAST : constant := 32; -- Can send broadcast msgs - IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group - IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group - IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL - IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback - -end GNAT.Sockets.Constants; diff --git a/gcc/ada/3zsocthi.adb b/gcc/ada/3zsocthi.adb deleted file mode 100644 index 28e22418847..00000000000 --- a/gcc/ada/3zsocthi.adb +++ /dev/null @@ -1,624 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2004 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 package provides a target dependent thin interface to the sockets --- layer for use by the GNAT.Sockets package (g-socket.ads). This package --- should not be directly with'ed by an applications program. - --- This version is for VxWorks - -with GNAT.OS_Lib; use GNAT.OS_Lib; -with GNAT.Task_Lock; - -with Interfaces.C; use Interfaces.C; -with Unchecked_Conversion; - -package body GNAT.Sockets.Thin is - - Non_Blocking_Sockets : constant Fd_Set_Access := - New_Socket_Set (No_Socket_Set); - -- When this package is initialized with Process_Blocking_IO set - -- to True, sockets are set in non-blocking mode to avoid blocking - -- the whole process when a thread wants to perform a blocking IO - -- operation. But the user can also set a socket in non-blocking - -- mode by purpose. In order to make a difference between these - -- two situations, we track the origin of non-blocking mode in - -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has - -- been set in non-blocking mode by the user. - - Quantum : constant Duration := 0.2; - -- When Thread_Blocking_IO is False, we set sockets in - -- non-blocking mode and we spend a period of time Quantum between - -- two attempts on a blocking operation. - - Thread_Blocking_IO : Boolean := True; - - Unknown_System_Error : constant C.Strings.chars_ptr := - C.Strings.New_String ("Unknown system error"); - - -- The following types and variables are required to create a Hostent - -- record "by hand". - - type In_Addr_Access_Array_Access is access In_Addr_Access_Array; - - Alias_Access : constant Chars_Ptr_Pointers.Pointer := - new C.Strings.chars_ptr'(C.Strings.Null_Ptr); - - In_Addr_Access_Array_A : constant In_Addr_Access_Array_Access := - new In_Addr_Access_Array'(new In_Addr, null); - - In_Addr_Access_Ptr : constant In_Addr_Access_Pointers.Pointer := - In_Addr_Access_Array_A - (In_Addr_Access_Array_A'First)'Access; - - Local_Hostent : constant Hostent_Access := new Hostent; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- All these require comments ??? - - function Syscall_Accept - (S : C.int; - Addr : System.Address; - Addrlen : access C.int) return C.int; - pragma Import (C, Syscall_Accept, "accept"); - - function Syscall_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int; - pragma Import (C, Syscall_Connect, "connect"); - - function Syscall_Ioctl - (S : C.int; - Req : C.int; - Arg : Int_Access) return C.int; - pragma Import (C, Syscall_Ioctl, "ioctl"); - - function Syscall_Recv - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int; - pragma Import (C, Syscall_Recv, "recv"); - - function Syscall_Recvfrom - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - From : Sockaddr_In_Access; - Fromlen : access C.int) return C.int; - pragma Import (C, Syscall_Recvfrom, "recvfrom"); - - function Syscall_Send - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int; - pragma Import (C, Syscall_Send, "send"); - - function Syscall_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : Sockaddr_In_Access; - Tolen : C.int) return C.int; - pragma Import (C, Syscall_Sendto, "sendto"); - - function Syscall_Socket - (Domain : C.int; - Typ : C.int; - Protocol : C.int) return C.int; - pragma Import (C, Syscall_Socket, "socket"); - - function Non_Blocking_Socket (S : C.int) return Boolean; - procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean); - - -------------- - -- C_Accept -- - -------------- - - function C_Accept - (S : C.int; - Addr : System.Address; - Addrlen : access C.int) return C.int - is - R : C.int; - Val : aliased C.int := 1; - - Res : C.int; - pragma Unreferenced (Res); - - begin - loop - R := Syscall_Accept (S, Addr, Addrlen); - exit when Thread_Blocking_IO - or else R /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= Constants.EWOULDBLOCK; - delay Quantum; - end loop; - - if not Thread_Blocking_IO - and then R /= Failure - then - -- A socket inherits the properties ot its server especially - -- the FIONBIO flag. Do not use C_Ioctl as this subprogram - -- tracks sockets set in non-blocking mode by user. - - Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); - Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); - -- Is it OK to ignore result ??? - end if; - - return R; - end C_Accept; - - --------------- - -- C_Connect -- - --------------- - - function C_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int - is - Res : C.int; - - begin - Res := Syscall_Connect (S, Name, Namelen); - - if Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= Constants.EINPROGRESS - then - return Res; - end if; - - declare - WSet : Fd_Set_Access; - Now : aliased Timeval; - - begin - WSet := New_Socket_Set (No_Socket_Set); - - loop - Insert_Socket_In_Set (WSet, S); - Now := Immediat; - Res := C_Select - (S + 1, - No_Fd_Set, - WSet, - No_Fd_Set, - Now'Unchecked_Access); - - exit when Res > 0; - - if Res = Failure then - Free_Socket_Set (WSet); - return Res; - end if; - - delay Quantum; - end loop; - - Free_Socket_Set (WSet); - end; - - Res := Syscall_Connect (S, Name, Namelen); - - if Res = Failure - and then Errno = Constants.EISCONN - then - return Thin.Success; - else - return Res; - end if; - end C_Connect; - - --------------------- - -- C_Gethostbyaddr -- - --------------------- - - function C_Gethostbyaddr - (Addr : System.Address; - Len : C.int; - Typ : C.int) return Hostent_Access - is - pragma Warnings (Off, Len); - pragma Warnings (Off, Typ); - - type int_Access is access int; - function To_Pointer is - new Unchecked_Conversion (System.Address, int_Access); - - procedure VxWorks_Gethostbyaddr - (Addr : C.int; Buf : out C.char_array); - pragma Import (C, VxWorks_Gethostbyaddr, "hostGetByAddr"); - - Host_Name : C.char_array (1 .. Max_Name_Length); - - begin - VxWorks_Gethostbyaddr (To_Pointer (Addr).all, Host_Name); - - In_Addr_Access_Ptr.all.all := To_In_Addr (To_Pointer (Addr).all); - Local_Hostent.all.H_Name := C.Strings.New_Char_Array (Host_Name); - - return Local_Hostent; - end C_Gethostbyaddr; - - --------------------- - -- C_Gethostbyname -- - --------------------- - - function C_Gethostbyname - (Name : C.char_array) return Hostent_Access - is - function VxWorks_Gethostbyname - (Name : C.char_array) return C.int; - pragma Import (C, VxWorks_Gethostbyname, "hostGetByName"); - - Addr : C.int; - - begin - Addr := VxWorks_Gethostbyname (Name); - - In_Addr_Access_Ptr.all.all := To_In_Addr (Addr); - Local_Hostent.all.H_Name := C.Strings.New_Char_Array (To_C (Host_Name)); - - return Local_Hostent; - end C_Gethostbyname; - - --------------------- - -- C_Getservbyname -- - --------------------- - - function C_Getservbyname - (Name : C.char_array; - Proto : C.char_array) return Servent_Access - is - pragma Warnings (Off, Name); - pragma Warnings (Off, Proto); - - begin - return null; - end C_Getservbyname; - - --------------------- - -- C_Getservbyport -- - --------------------- - - function C_Getservbyport - (Port : C.int; - Proto : C.char_array) return Servent_Access - is - pragma Warnings (Off, Port); - pragma Warnings (Off, Proto); - - begin - return null; - end C_Getservbyport; - - ------------- - -- C_Ioctl -- - ------------- - - function C_Ioctl - (S : C.int; - Req : C.int; - Arg : Int_Access) return C.int - is - begin - if not Thread_Blocking_IO - and then Req = Constants.FIONBIO - then - if Arg.all /= 0 then - Set_Non_Blocking_Socket (S, True); - end if; - end if; - - return Syscall_Ioctl (S, Req, Arg); - end C_Ioctl; - - ------------ - -- C_Recv -- - ------------ - - function C_Recv - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Recv (S, Msg, Len, Flags); - exit when Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= Constants.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Recv; - - ---------------- - -- C_Recvfrom -- - ---------------- - - function C_Recvfrom - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - From : Sockaddr_In_Access; - Fromlen : access C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); - exit when Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= Constants.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Recvfrom; - - ------------ - -- C_Send -- - ------------ - - function C_Send - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Send (S, Msg, Len, Flags); - exit when Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= Constants.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Send; - - -------------- - -- C_Sendto -- - -------------- - - function C_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : Sockaddr_In_Access; - Tolen : C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); - exit when Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= Constants.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Sendto; - - -------------- - -- C_Socket -- - -------------- - - function C_Socket - (Domain : C.int; - Typ : C.int; - Protocol : C.int) return C.int - is - R : C.int; - Val : aliased C.int := 1; - - Res : C.int; - pragma Unreferenced (Res); - - begin - R := Syscall_Socket (Domain, Typ, Protocol); - - if not Thread_Blocking_IO - and then R /= Failure - then - -- Do not use C_Ioctl as this subprogram tracks sockets set - -- in non-blocking mode by user. - - Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); - -- Is it OK to ignore result ??? - Set_Non_Blocking_Socket (R, False); - end if; - - return R; - end C_Socket; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize is - begin - null; - end Finalize; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Process_Blocking_IO : Boolean) is - begin - Thread_Blocking_IO := not Process_Blocking_IO; - end Initialize; - - ------------------------- - -- Non_Blocking_Socket -- - ------------------------- - - function Non_Blocking_Socket (S : C.int) return Boolean is - R : Boolean; - - begin - Task_Lock.Lock; - R := Is_Socket_In_Set (Non_Blocking_Sockets, S); - Task_Lock.Unlock; - return R; - end Non_Blocking_Socket; - - ----------------- - -- Set_Address -- - ----------------- - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr) - is - begin - Sin.Sin_Addr := Address; - end Set_Address; - - ---------------- - -- Set_Family -- - ---------------- - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int) - is - begin - Sin.Sin_Family := C.unsigned_char (Family); - end Set_Family; - - ---------------- - -- Set_Length -- - ---------------- - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int) - is - begin - Sin.Sin_Length := C.unsigned_char (Len); - end Set_Length; - - ----------------------------- - -- Set_Non_Blocking_Socket -- - ----------------------------- - - procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is - begin - Task_Lock.Lock; - if V then - Insert_Socket_In_Set (Non_Blocking_Sockets, S); - else - Remove_Socket_From_Set (Non_Blocking_Sockets, S); - end if; - - Task_Lock.Unlock; - end Set_Non_Blocking_Socket; - - -------------- - -- Set_Port -- - -------------- - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short) - is - begin - Sin.Sin_Port := Port; - end Set_Port; - - -------------------------- - -- Socket_Error_Message -- - -------------------------- - - function Socket_Error_Message - (Errno : Integer) return C.Strings.chars_ptr - is - use type Interfaces.C.Strings.chars_ptr; - - C_Msg : C.Strings.chars_ptr; - - begin - C_Msg := C_Strerror (C.int (Errno)); - - if C_Msg = C.Strings.Null_Ptr then - return Unknown_System_Error; - - else - return C_Msg; - end if; - end Socket_Error_Message; - --- Package elaboration - -begin - Local_Hostent.all.H_Aliases := Alias_Access; - - -- VxWorks currently only supports AF_INET - - Local_Hostent.all.H_Addrtype := Constants.AF_INET; - - Local_Hostent.all.H_Length := 1; - Local_Hostent.all.H_Addr_List := In_Addr_Access_Ptr; - -end GNAT.Sockets.Thin; diff --git a/gcc/ada/3zsocthi.ads b/gcc/ada/3zsocthi.ads deleted file mode 100644 index 3642a038bec..00000000000 --- a/gcc/ada/3zsocthi.ads +++ /dev/null @@ -1,446 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2004 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 package provides a target dependent thin interface to the sockets --- layer for use by the GNAT.Sockets package (g-socket.ads). This package --- should not be directly with'ed by an applications program. - --- This is the version for VxWorks - -with Interfaces.C.Pointers; - -with Ada.Unchecked_Conversion; -with Interfaces.C.Strings; -with GNAT.Sockets.Constants; -with GNAT.OS_Lib; - -with System; - -package GNAT.Sockets.Thin is - - package C renames Interfaces.C; - - use type C.int; - -- This is so we can declare the Failure constant below - - Success : constant C.int := 0; - Failure : constant C.int := -1; - - function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; - -- Returns last socket error number. - - function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr; - -- Returns the error message string for the error number Errno. If - -- Errno is not known it returns "Unknown system error". - - subtype Fd_Set_Access is System.Address; - No_Fd_Set : constant Fd_Set_Access := System.Null_Address; - - type Timeval_Unit is new C.int; - pragma Convention (C, Timeval_Unit); - - type Timeval is record - Tv_Sec : Timeval_Unit; - Tv_Usec : Timeval_Unit; - end record; - pragma Convention (C, Timeval); - - type Timeval_Access is access all Timeval; - pragma Convention (C, Timeval_Access); - - Immediat : constant Timeval := (0, 0); - - type Int_Access is access all C.int; - pragma Convention (C, Int_Access); - -- Access to C integers - - type Chars_Ptr_Array is array (C.size_t range <>) of - aliased C.Strings.chars_ptr; - - package Chars_Ptr_Pointers is - new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, - C.Strings.Null_Ptr); - -- Arrays of C (char *) - - type In_Addr is record - S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; - end record; - pragma Convention (C, In_Addr); - -- Internet address - - function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr); - - type In_Addr_Access is access all In_Addr; - pragma Convention (C, In_Addr_Access); - -- Access to internet address - - Inaddr_Any : aliased constant In_Addr := (others => 0); - -- Any internet address (all the interfaces) - - type In_Addr_Access_Array is array (C.size_t range <>) - of aliased In_Addr_Access; - pragma Convention (C, In_Addr_Access_Array); - - package In_Addr_Access_Pointers is - new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); - -- Array of internet addresses - - type Sockaddr is record - Sa_Length : C.unsigned_char; - Sa_Family : C.unsigned_char; - Sa_Data : C.char_array (1 .. 14); - end record; - pragma Convention (C, Sockaddr); - -- Socket address - - type Sockaddr_Access is access all Sockaddr; - pragma Convention (C, Sockaddr_Access); - -- Access to socket address - - type Sockaddr_In is record - Sin_Length : C.unsigned_char := 0; - Sin_Family : C.unsigned_char := Constants.AF_INET; - Sin_Port : C.unsigned_short := 0; - Sin_Addr : In_Addr := Inaddr_Any; - Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0)); - end record; - pragma Convention (C, Sockaddr_In); - -- Internet socket address - - type Sockaddr_In_Access is access all Sockaddr_In; - pragma Convention (C, Sockaddr_In_Access); - -- Access to internet socket address - - procedure Set_Length - (Sin : Sockaddr_In_Access; - Len : C.int); - pragma Inline (Set_Length); - -- Set Sin.Sin_Length to Len. - - procedure Set_Family - (Sin : Sockaddr_In_Access; - Family : C.int); - pragma Inline (Set_Family); - -- Set Sin.Sin_Family to Family. - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short); - pragma Inline (Set_Port); - -- Set Sin.Sin_Port to Port. - - procedure Set_Address - (Sin : Sockaddr_In_Access; - Address : In_Addr); - pragma Inline (Set_Address); - -- Set Sin.Sin_Addr to Address. - - type Hostent is record - H_Name : C.Strings.chars_ptr; - H_Aliases : Chars_Ptr_Pointers.Pointer; - H_Addrtype : C.int; - H_Length : C.int; - H_Addr_List : In_Addr_Access_Pointers.Pointer; - end record; - pragma Convention (C, Hostent); - -- Host entry - - type Hostent_Access is access all Hostent; - pragma Convention (C, Hostent_Access); - -- Access to host entry - - type Servent is record - S_Name : C.Strings.chars_ptr; - S_Aliases : Chars_Ptr_Pointers.Pointer; - S_Port : C.int; - S_Proto : C.Strings.chars_ptr; - end record; - pragma Convention (C, Servent); - -- Service entry - - type Servent_Access is access all Servent; - pragma Convention (C, Servent_Access); - -- Access to service entry - - type Two_Int is array (0 .. 1) of C.int; - pragma Convention (C, Two_Int); - -- Used with pipe() - - function C_Accept - (S : C.int; - Addr : System.Address; - Addrlen : access C.int) - return C.int; - - function C_Bind - (S : C.int; - Name : System.Address; - Namelen : C.int) - return C.int; - - function C_Close - (Fd : C.int) - return C.int; - - function C_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) - return C.int; - - function C_Gethostbyaddr - (Addr : System.Address; - Len : C.int; - Typ : C.int) - return Hostent_Access; - - function C_Gethostbyname - (Name : C.char_array) - return Hostent_Access; - - function C_Gethostname - (Name : System.Address; - Namelen : C.int) - return C.int; - - function C_Getpeername - (S : C.int; - Name : System.Address; - Namelen : access C.int) - return C.int; - - function C_Getservbyname - (Name : C.char_array; - Proto : C.char_array) - return Servent_Access; - - function C_Getservbyport - (Port : C.int; - Proto : C.char_array) - return Servent_Access; - - function C_Getsockname - (S : C.int; - Name : System.Address; - Namelen : access C.int) - return C.int; - - function C_Getsockopt - (S : C.int; - Level : C.int; - Optname : C.int; - Optval : System.Address; - Optlen : access C.int) - return C.int; - - function C_Inet_Addr - (Cp : C.Strings.chars_ptr) - return C.int; - - function C_Ioctl - (S : C.int; - Req : C.int; - Arg : Int_Access) - return C.int; - - function C_Listen (S, Backlog : C.int) return C.int; - - function C_Read - (Fd : C.int; - Buf : System.Address; - Count : C.int) - return C.int; - - function C_Readv - (Fd : C.int; - Iov : System.Address; - Iovcnt : C.int) - return C.int; - - function C_Recv - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) - return C.int; - - function C_Recvfrom - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - From : Sockaddr_In_Access; - Fromlen : access C.int) - return C.int; - - function C_Select - (Nfds : C.int; - Readfds : Fd_Set_Access; - Writefds : Fd_Set_Access; - Exceptfds : Fd_Set_Access; - Timeout : Timeval_Access) - return C.int; - - function C_Send - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) - return C.int; - - function C_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : Sockaddr_In_Access; - Tolen : C.int) - return C.int; - - function C_Setsockopt - (S : C.int; - Level : C.int; - Optname : C.int; - Optval : System.Address; - Optlen : C.int) - return C.int; - - function C_Shutdown - (S : C.int; - How : C.int) - return C.int; - - function C_Socket - (Domain : C.int; - Typ : C.int; - Protocol : C.int) - return C.int; - - function C_Strerror - (Errnum : C.int) - return C.Strings.chars_ptr; - - function C_System - (Command : System.Address) - return C.int; - - function C_Write - (Fd : C.int; - Buf : System.Address; - Count : C.int) - return C.int; - - function C_Writev - (Fd : C.int; - Iov : System.Address; - Iovcnt : C.int) - return C.int; - - procedure Free_Socket_Set - (Set : Fd_Set_Access); - -- Free system-dependent socket set - - procedure Get_Socket_From_Set - (Set : Fd_Set_Access; - Socket : Int_Access; - Last : Int_Access); - -- Get last socket in Socket and remove it from the socket - -- set. The parameter Last is a maximum value of the largest - -- socket. This hint is used to avoid scanning very large socket - -- sets. After a call to Get_Socket_From_Set, Last is set back to - -- the real largest socket in the socket set. - - procedure Insert_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Insert socket in the socket set - - function Is_Socket_In_Set - (Set : Fd_Set_Access; - Socket : C.int) - return Boolean; - -- Check whether Socket is in the socket set - - procedure Last_Socket_In_Set - (Set : Fd_Set_Access; - Last : Int_Access); - -- Find the largest socket in the socket set. This is needed for - -- select(). When Last_Socket_In_Set is called, parameter Last is - -- a maximum value of the largest socket. This hint is used to - -- avoid scanning very large socket sets. After the call, Last is - -- set back to the real largest socket in the socket set. - - function New_Socket_Set - (Set : Fd_Set_Access) - return Fd_Set_Access; - -- Allocate a new socket set which is a system-dependent structure - -- and initialize by copying Set if it is non-null, by making it - -- empty otherwise. - - procedure Remove_Socket_From_Set - (Set : Fd_Set_Access; - Socket : C.int); - -- Remove socket from the socket set - - procedure Finalize; - procedure Initialize (Process_Blocking_IO : Boolean); - -private - - pragma Import (C, C_Bind, "bind"); - pragma Import (C, C_Close, "close"); - pragma Import (C, C_Gethostname, "gethostname"); - pragma Import (C, C_Getpeername, "getpeername"); - pragma Import (C, C_Getsockname, "getsockname"); - pragma Import (C, C_Getsockopt, "getsockopt"); - pragma Import (C, C_Inet_Addr, "inet_addr"); - pragma Import (C, C_Listen, "listen"); - pragma Import (C, C_Read, "read"); - pragma Import (C, C_Readv, "readv"); - pragma Import (C, C_Select, "select"); - pragma Import (C, C_Setsockopt, "setsockopt"); - pragma Import (C, C_Shutdown, "shutdown"); - pragma Import (C, C_Strerror, "strerror"); - pragma Import (C, C_System, "system"); - pragma Import (C, C_Write, "write"); - pragma Import (C, C_Writev, "writev"); - - pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); - pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); - pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); - pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); - pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); - pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); - pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); - -end GNAT.Sockets.Thin; diff --git a/gcc/ada/41intnam.ads b/gcc/ada/41intnam.ads deleted file mode 100644 index b7009ab569e..00000000000 --- a/gcc/ada/41intnam.ads +++ /dev/null @@ -1,164 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-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 SCO UnixWare version of this package. --- --- The following signals are reserved by the run time: --- --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, --- SIGWAITING, SIGLWP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGSTOP, SIGKILL --- --- The pragma Unreserve_All_Interrupts affects the following signal(s): --- --- SIGINT: made available for Ada handler - -with System.OS_Interface; --- used for names of interrupts - -package Ada.Interrupts.Names is - - -- Beware that the mapping of names to signals may be - -- many-to-one. There may be aliases. - - SIGHUP : constant Interrupt_ID := - System.OS_Interface.SIGHUP; -- hangup - - SIGINT : constant Interrupt_ID := - System.OS_Interface.SIGINT; -- interrupt (rubout) - - SIGQUIT : constant Interrupt_ID := - System.OS_Interface.SIGQUIT; -- quit (ASCD FS) - - SIGILL : constant Interrupt_ID := - System.OS_Interface.SIGILL; -- illegal instruction (not reset) - - SIGTRAP : constant Interrupt_ID := - System.OS_Interface.SIGTRAP; -- trace trap (not reset) - - SIGIOT : constant Interrupt_ID := - System.OS_Interface.SIGIOT; -- IOT instruction - - SIGABRT : constant Interrupt_ID := -- used by abort, - System.OS_Interface.SIGABRT; -- replace SIGIOT in the future - - SIGEMT : constant Interrupt_ID := - System.OS_Interface.SIGEMT; -- EMT instruction - - SIGFPE : constant Interrupt_ID := - System.OS_Interface.SIGFPE; -- floating point exception - - SIGKILL : constant Interrupt_ID := - System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) - - SIGBUS : constant Interrupt_ID := - System.OS_Interface.SIGBUS; -- bus error - - SIGSEGV : constant Interrupt_ID := - System.OS_Interface.SIGSEGV; -- segmentation violation - - SIGSYS : constant Interrupt_ID := - System.OS_Interface.SIGSYS; -- bad argument to system call - - SIGPIPE : constant Interrupt_ID := -- write on a pipe with - System.OS_Interface.SIGPIPE; -- no one to read it - - SIGALRM : constant Interrupt_ID := - System.OS_Interface.SIGALRM; -- alarm clock - - SIGTERM : constant Interrupt_ID := - System.OS_Interface.SIGTERM; -- software termination signal from kill - - SIGUSR1 : constant Interrupt_ID := - System.OS_Interface.SIGUSR1; -- user defined signal 1 - - SIGUSR2 : constant Interrupt_ID := - System.OS_Interface.SIGUSR2; -- user defined signal 2 - - SIGCLD : constant Interrupt_ID := - System.OS_Interface.SIGCLD; -- child status change - - SIGCHLD : constant Interrupt_ID := - System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD - - SIGPWR : constant Interrupt_ID := - System.OS_Interface.SIGPWR; -- power-fail restart - - SIGWINCH : constant Interrupt_ID := - System.OS_Interface.SIGWINCH; -- window size change - - SIGURG : constant Interrupt_ID := - System.OS_Interface.SIGURG; -- urgent condition on IO channel - - SIGPOLL : constant Interrupt_ID := - System.OS_Interface.SIGPOLL; -- pollable event occurred - - SIGIO : constant Interrupt_ID := -- input/output possible, - System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) - - SIGSTOP : constant Interrupt_ID := - System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) - - SIGTSTP : constant Interrupt_ID := - System.OS_Interface.SIGTSTP; -- user stop requested from tty - - SIGCONT : constant Interrupt_ID := - System.OS_Interface.SIGCONT; -- stopped process has been continued - - SIGTTIN : constant Interrupt_ID := - System.OS_Interface.SIGTTIN; -- background tty read attempted - - SIGTTOU : constant Interrupt_ID := - System.OS_Interface.SIGTTOU; -- background tty write attempted - - SIGVTALRM : constant Interrupt_ID := - System.OS_Interface.SIGVTALRM; -- virtual timer expired - - SIGPROF : constant Interrupt_ID := - System.OS_Interface.SIGPROF; -- profiling timer expired - - SIGXCPU : constant Interrupt_ID := - System.OS_Interface.SIGXCPU; -- CPU time limit exceeded - - SIGXFSZ : constant Interrupt_ID := - System.OS_Interface.SIGXFSZ; -- filesize limit exceeded - - SIGWAITING : constant Interrupt_ID := - System.OS_Interface.SIGWAITING; -- process's lwps blocked (Solaris) - - SIGLWP : constant Interrupt_ID := - System.OS_Interface.SIGLWP; -- used by thread library (Solaris) - - SIGAIO : constant Interrupt_ID := - System.OS_Interface.SIGAIO; -- Asynchronous I/O signal - -end Ada.Interrupts.Names; diff --git a/gcc/ada/42intnam.ads b/gcc/ada/42intnam.ads deleted file mode 100644 index edc91159690..00000000000 --- a/gcc/ada/42intnam.ads +++ /dev/null @@ -1,165 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-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 LynxOS version of this package. --- --- The following signals are reserved by the run time: --- --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, --- SIGWAITING, SIGLWP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGSTOP, SIGKILL --- --- The pragma Unreserve_All_Interrupts affects the following signal(s): --- --- SIGINT: made available for Ada handler - -with System.OS_Interface; --- used for names of interrupts - -package Ada.Interrupts.Names is - - -- Beware that the mapping of names to signals may be - -- many-to-one. There may be aliases. - - SIGHUP : constant Interrupt_ID := - System.OS_Interface.SIGHUP; -- hangup - - SIGINT : constant Interrupt_ID := - System.OS_Interface.SIGINT; -- interrupt (rubout) - - SIGQUIT : constant Interrupt_ID := - System.OS_Interface.SIGQUIT; -- quit (ASCD FS) - - SIGILL : constant Interrupt_ID := - System.OS_Interface.SIGILL; -- illegal instruction (not reset) - - SIGTRAP : constant Interrupt_ID := - System.OS_Interface.SIGTRAP; -- trace trap (not reset) - - SIGBRK : constant Interrupt_ID := - System.OS_Interface.SIGBRK; -- break - - SIGIOT : constant Interrupt_ID := - System.OS_Interface.SIGIOT; -- IOT instruction - - SIGABRT : constant Interrupt_ID := -- used by abort, - System.OS_Interface.SIGABRT; -- replace SIGIOT in the future - - SIGCORE : constant Interrupt_ID := - System.OS_Interface.SIGCORE; -- kill with core dump - - SIGEMT : constant Interrupt_ID := - System.OS_Interface.SIGEMT; -- EMT instruction - - SIGFPE : constant Interrupt_ID := - System.OS_Interface.SIGFPE; -- floating point exception - - SIGKILL : constant Interrupt_ID := - System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) - - SIGBUS : constant Interrupt_ID := - System.OS_Interface.SIGBUS; -- bus error - - SIGSEGV : constant Interrupt_ID := - System.OS_Interface.SIGSEGV; -- segmentation violation - - SIGSYS : constant Interrupt_ID := - System.OS_Interface.SIGSYS; -- bad argument to system call - - SIGPIPE : constant Interrupt_ID := -- write on a pipe with - System.OS_Interface.SIGPIPE; -- no one to read it - - SIGALRM : constant Interrupt_ID := - System.OS_Interface.SIGALRM; -- alarm clock - - SIGTERM : constant Interrupt_ID := - System.OS_Interface.SIGTERM; -- software termination signal from kill - - SIGURG : constant Interrupt_ID := - System.OS_Interface.SIGURG; -- urgent condition on IO channel - - SIGSTOP : constant Interrupt_ID := - System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) - - SIGTSTP : constant Interrupt_ID := - System.OS_Interface.SIGTSTP; -- user stop requested from tty - - SIGCONT : constant Interrupt_ID := - System.OS_Interface.SIGCONT; -- stopped process has been continued - - SIGCLD : constant Interrupt_ID := - System.OS_Interface.SIGCLD; -- child status change - - SIGCHLD : constant Interrupt_ID := - System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD - - SIGTTIN : constant Interrupt_ID := - System.OS_Interface.SIGTTIN; -- background tty read attempted - - SIGTTOU : constant Interrupt_ID := - System.OS_Interface.SIGTTOU; -- background tty write attempted - - SIGPOLL : constant Interrupt_ID := - System.OS_Interface.SIGPOLL; -- pollable event occurred - - SIGIO : constant Interrupt_ID := -- input/output possible, - System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) - - SIGXCPU : constant Interrupt_ID := - System.OS_Interface.SIGXCPU; -- CPU time limit exceeded - - SIGXFSZ : constant Interrupt_ID := - System.OS_Interface.SIGXFSZ; -- filesize limit exceeded - - SIGVTALRM : constant Interrupt_ID := - System.OS_Interface.SIGVTALRM; -- virtual timer expired - - SIGPROF : constant Interrupt_ID := - System.OS_Interface.SIGPROF; -- profiling timer expired - - SIGWINCH : constant Interrupt_ID := - System.OS_Interface.SIGWINCH; -- window size change - - SIGLOST : constant Interrupt_ID := - System.OS_Interface.SIGLOST; -- SUN 4.1 compatibility - - SIGUSR1 : constant Interrupt_ID := - System.OS_Interface.SIGUSR1; -- user defined signal 1 - - SIGUSR2 : constant Interrupt_ID := - System.OS_Interface.SIGUSR2; -- user defined signal 2 - - SIGPRIO : constant Interrupt_ID := - System.OS_Interface.SIGPRIO; - -- sent to a process with its priority - -- or group is changed -end Ada.Interrupts.Names; diff --git a/gcc/ada/45intnam.ads b/gcc/ada/45intnam.ads deleted file mode 100644 index eb05daaa912..00000000000 --- a/gcc/ada/45intnam.ads +++ /dev/null @@ -1,136 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-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 FreeBSD THREADS version of this package - -with System.OS_Interface; --- used for names of interrupts - -package Ada.Interrupts.Names is - - SIGHUP : constant Interrupt_ID := - System.OS_Interface.SIGHUP; -- hangup - - SIGINT : constant Interrupt_ID := - System.OS_Interface.SIGINT; -- interrupt (rubout) - - SIGQUIT : constant Interrupt_ID := - System.OS_Interface.SIGQUIT; -- quit (ASCD FS) - - SIGILL : constant Interrupt_ID := - System.OS_Interface.SIGILL; -- illegal instruction (not reset) - - SIGTRAP : constant Interrupt_ID := - System.OS_Interface.SIGTRAP; -- trace trap (not reset) - - SIGIOT : constant Interrupt_ID := - System.OS_Interface.SIGIOT; -- IOT instruction - - SIGABRT : constant Interrupt_ID := -- used by abort, - System.OS_Interface.SIGABRT; -- replace SIGIOT in the future - - SIGFPE : constant Interrupt_ID := - System.OS_Interface.SIGFPE; -- floating point exception - - SIGKILL : constant Interrupt_ID := - System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) - - SIGBUS : constant Interrupt_ID := - System.OS_Interface.SIGBUS; -- bus error - - SIGSEGV : constant Interrupt_ID := - System.OS_Interface.SIGSEGV; -- segmentation violation - - SIGPIPE : constant Interrupt_ID := -- write on a pipe with - System.OS_Interface.SIGPIPE; -- no one to read it - - SIGALRM : constant Interrupt_ID := - System.OS_Interface.SIGALRM; -- alarm clock - - SIGTERM : constant Interrupt_ID := - System.OS_Interface.SIGTERM; -- software termination signal from kill - - SIGURG : constant Interrupt_ID := - System.OS_Interface.SIGURG; -- urgent condition on IO channel - - SIGSTOP : constant Interrupt_ID := - System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) - - SIGTSTP : constant Interrupt_ID := - System.OS_Interface.SIGTSTP; -- user stop requested from tty - - SIGCONT : constant Interrupt_ID := - System.OS_Interface.SIGCONT; -- stopped process has been continued - - SIGCHLD : constant Interrupt_ID := - System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD - - SIGCLD : constant Interrupt_ID := - System.OS_Interface.SIGCLD; -- child status change - - SIGTTIN : constant Interrupt_ID := - System.OS_Interface.SIGTTIN; -- background tty read attempted - - SIGTTOU : constant Interrupt_ID := - System.OS_Interface.SIGTTOU; -- background tty write attempted - - SIGIO : constant Interrupt_ID := -- input/output possible, - System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) - - SIGXCPU : constant Interrupt_ID := - System.OS_Interface.SIGXCPU; -- CPU time limit exceeded - - SIGXFSZ : constant Interrupt_ID := - System.OS_Interface.SIGXFSZ; -- filesize limit exceeded - - SIGVTALRM : constant Interrupt_ID := - System.OS_Interface.SIGVTALRM; -- virtual timer expired - - SIGPROF : constant Interrupt_ID := - System.OS_Interface.SIGPROF; -- profiling timer expired - - SIGWINCH : constant Interrupt_ID := - System.OS_Interface.SIGWINCH; -- window size change - - SIGUSR1 : constant Interrupt_ID := - System.OS_Interface.SIGUSR1; -- user defined signal 1 - - SIGUSR2 : constant Interrupt_ID := - System.OS_Interface.SIGUSR2; -- user defined signal 2 - - -- Beware that the mapping of names to signals may be - -- many-to-one. There may be aliases. Also, for all - -- signal names that are not supported on the current system - -- the value of the corresponding constant will be zero. - -end Ada.Interrupts.Names; diff --git a/gcc/ada/4aintnam.ads b/gcc/ada/4aintnam.ads deleted file mode 100644 index 95509a89d94..00000000000 --- a/gcc/ada/4aintnam.ads +++ /dev/null @@ -1,151 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-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 the DEC Unix 4.0 version of this package. --- --- The following signals are reserved by the run time: --- --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGALRM, --- SIGSTOP, SIGKILL --- --- The pragma Unreserve_All_Interrupts affects the following signal(s): --- --- SIGINT: made available for Ada handler - -with System.OS_Interface; --- used for names of interrupts - -package Ada.Interrupts.Names is - - -- Beware that the mapping of names to signals may be - -- many-to-one. There may be aliases. Also, for all - -- signal names that are not supported on the current system - -- the value of the corresponding constant will be zero. - - SIGHUP : constant Interrupt_ID := - System.OS_Interface.SIGHUP; -- hangup - - SIGINT : constant Interrupt_ID := - System.OS_Interface.SIGINT; -- interrupt (rubout) - - SIGQUIT : constant Interrupt_ID := - System.OS_Interface.SIGQUIT; -- quit (ASCD FS) - - SIGILL : constant Interrupt_ID := - System.OS_Interface.SIGILL; -- illegal instruction (not reset) - - SIGTRAP : constant Interrupt_ID := - System.OS_Interface.SIGTRAP; -- trace trap (not reset) - - SIGIOT : constant Interrupt_ID := - System.OS_Interface.SIGIOT; -- IOT instruction - - SIGABRT : constant Interrupt_ID := -- used by abort, - System.OS_Interface.SIGABRT; -- replace SIGIOT in the future - - SIGEMT : constant Interrupt_ID := - System.OS_Interface.SIGEMT; -- EMT instruction - - SIGFPE : constant Interrupt_ID := - System.OS_Interface.SIGFPE; -- floating point exception - - SIGKILL : constant Interrupt_ID := - System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) - - SIGBUS : constant Interrupt_ID := - System.OS_Interface.SIGBUS; -- bus error - - SIGSEGV : constant Interrupt_ID := - System.OS_Interface.SIGSEGV; -- segmentation violation - - SIGSYS : constant Interrupt_ID := - System.OS_Interface.SIGSYS; -- bad argument to system call - - SIGPIPE : constant Interrupt_ID := -- write on a pipe with - System.OS_Interface.SIGPIPE; -- no one to read it - - SIGALRM : constant Interrupt_ID := - System.OS_Interface.SIGALRM; -- alarm clock - - SIGTERM : constant Interrupt_ID := - System.OS_Interface.SIGTERM; -- software termination signal from kill - - SIGUSR1 : constant Interrupt_ID := - System.OS_Interface.SIGUSR1; -- user defined signal 1 - - SIGUSR2 : constant Interrupt_ID := - System.OS_Interface.SIGUSR2; -- user defined signal 2 - - SIGCHLD : constant Interrupt_ID := - System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD - - SIGWINCH : constant Interrupt_ID := - System.OS_Interface.SIGWINCH; -- window size change - - SIGURG : constant Interrupt_ID := - System.OS_Interface.SIGURG; -- urgent condition on IO channel - - SIGPOLL : constant Interrupt_ID := - System.OS_Interface.SIGPOLL; -- pollable event occurred - - SIGIO : constant Interrupt_ID := -- input/output possible, - System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) - - SIGSTOP : constant Interrupt_ID := - System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) - - SIGTSTP : constant Interrupt_ID := - System.OS_Interface.SIGTSTP; -- user stop requested from tty - - SIGCONT : constant Interrupt_ID := - System.OS_Interface.SIGCONT; -- stopped process has been continued - - SIGTTIN : constant Interrupt_ID := - System.OS_Interface.SIGTTIN; -- background tty read attempted - - SIGTTOU : constant Interrupt_ID := - System.OS_Interface.SIGTTOU; -- background tty write attempted - - SIGVTALRM : constant Interrupt_ID := - System.OS_Interface.SIGVTALRM; -- virtual timer expired - - SIGPROF : constant Interrupt_ID := - System.OS_Interface.SIGPROF; -- profiling timer expired - - SIGXCPU : constant Interrupt_ID := - System.OS_Interface.SIGXCPU; -- CPU time limit exceeded - - SIGXFSZ : constant Interrupt_ID := - System.OS_Interface.SIGXFSZ; -- filesize limit exceeded - -end Ada.Interrupts.Names; diff --git a/gcc/ada/4cintnam.ads b/gcc/ada/4cintnam.ads deleted file mode 100644 index fa56138b461..00000000000 --- a/gcc/ada/4cintnam.ads +++ /dev/null @@ -1,201 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-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 AIX version of this package. --- --- The following signals are reserved by the run time (native threads): --- --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGTERM, --- SIGSTOP, SIGKILL --- --- The following signals are reserved by the run time (FSU threads): --- --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGALRM, --- SIGWAITING, SIGSTOP, SIGKILL --- --- The pragma Unreserve_All_Interrupts affects the following signal(s): --- --- SIGINT: made available for Ada handler - --- This target-dependent package spec contains names of interrupts --- supported by the local system. - -with System.OS_Interface; --- used for names of interrupts - -package Ada.Interrupts.Names is - - -- Beware that the mapping of names to signals may be - -- many-to-one. There may be aliases. Also, for all - -- signal names that are not supported on the current system - -- the value of the corresponding constant will be zero. - - SIGHUP : constant Interrupt_ID := - System.OS_Interface.SIGHUP; -- hangup - - SIGINT : constant Interrupt_ID := - System.OS_Interface.SIGINT; -- interrupt (rubout) - - SIGQUIT : constant Interrupt_ID := - System.OS_Interface.SIGQUIT; -- quit (ASCD FS) - - SIGILL : constant Interrupt_ID := - System.OS_Interface.SIGILL; -- illegal instruction (not reset) - - SIGTRAP : constant Interrupt_ID := - System.OS_Interface.SIGTRAP; -- trace trap (not reset) - - SIGIOT : constant Interrupt_ID := - System.OS_Interface.SIGIOT; -- IOT instruction - - SIGABRT : constant Interrupt_ID := -- used by abort, - System.OS_Interface.SIGABRT; -- replace SIGIOT in the future - - SIGEMT : constant Interrupt_ID := - System.OS_Interface.SIGEMT; -- EMT instruction - - SIGFPE : constant Interrupt_ID := - System.OS_Interface.SIGFPE; -- floating point exception - - SIGKILL : constant Interrupt_ID := - System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) - - SIGBUS : constant Interrupt_ID := - System.OS_Interface.SIGBUS; -- bus error - - SIGSEGV : constant Interrupt_ID := - System.OS_Interface.SIGSEGV; -- segmentation violation - - SIGSYS : constant Interrupt_ID := - System.OS_Interface.SIGSYS; -- bad argument to system call - - SIGPIPE : constant Interrupt_ID := -- write on a pipe with - System.OS_Interface.SIGPIPE; -- no one to read it - - SIGALRM : constant Interrupt_ID := - System.OS_Interface.SIGALRM; -- alarm clock - - SIGTERM : constant Interrupt_ID := - System.OS_Interface.SIGTERM; -- software termination signal from kill - - SIGUSR1 : constant Interrupt_ID := - System.OS_Interface.SIGUSR1; -- user defined signal 1 - - SIGUSR2 : constant Interrupt_ID := - System.OS_Interface.SIGUSR2; -- user defined signal 2 - - SIGCLD : constant Interrupt_ID := - System.OS_Interface.SIGCLD; -- child status change - - SIGCHLD : constant Interrupt_ID := - System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD - - SIGPWR : constant Interrupt_ID := - System.OS_Interface.SIGPWR; -- power-fail restart - - SIGWINCH : constant Interrupt_ID := - System.OS_Interface.SIGWINCH; -- window size change - - SIGURG : constant Interrupt_ID := - System.OS_Interface.SIGURG; -- urgent condition on IO channel - - SIGPOLL : constant Interrupt_ID := - System.OS_Interface.SIGPOLL; -- pollable event occurred - - SIGIO : constant Interrupt_ID := -- input/output possible, - System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) - - SIGSTOP : constant Interrupt_ID := - System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) - - SIGTSTP : constant Interrupt_ID := - System.OS_Interface.SIGTSTP; -- user stop requested from tty - - SIGCONT : constant Interrupt_ID := - System.OS_Interface.SIGCONT; -- stopped process has been continued - - SIGTTIN : constant Interrupt_ID := - System.OS_Interface.SIGTTIN; -- background tty read attempted - - SIGTTOU : constant Interrupt_ID := - System.OS_Interface.SIGTTOU; -- background tty write attempted - - SIGVTALRM : constant Interrupt_ID := - System.OS_Interface.SIGVTALRM; -- virtual timer expired - - SIGPROF : constant Interrupt_ID := - System.OS_Interface.SIGPROF; -- profiling timer expired - - SIGXCPU : constant Interrupt_ID := - System.OS_Interface.SIGXCPU; -- CPU time limit exceeded - - SIGXFSZ : constant Interrupt_ID := - System.OS_Interface.SIGXFSZ; -- filesize limit exceeded - - SIGMSG : constant Interrupt_ID := - System.OS_Interface.SIGMSG; -- input data is in the ring buffer - - SIGDANGER : constant Interrupt_ID := - System.OS_Interface.SIGDANGER; -- system crash imminent; - - SIGMIGRATE : constant Interrupt_ID := - System.OS_Interface.SIGMIGRATE; -- migrate process - - SIGPRE : constant Interrupt_ID := - System.OS_Interface.SIGPRE; -- programming exception - - SIGVIRT : constant Interrupt_ID := - System.OS_Interface.SIGVIRT; -- AIX virtual time alarm - - SIGALRM1 : constant Interrupt_ID := - System.OS_Interface.SIGALRM1; -- m:n condition variables - - SIGWAITING : constant Interrupt_ID := - System.OS_Interface.SIGWAITING; -- m:n scheduling - - SIGKAP : constant Interrupt_ID := - System.OS_Interface.SIGKAP; -- keep alive poll from native keyboard - - SIGGRANT : constant Interrupt_ID := - System.OS_Interface.SIGGRANT; -- monitor mode granted - - SIGRETRACT : constant Interrupt_ID := - System.OS_Interface.SIGRETRACT; -- monitor mode should be relinguished - - SIGSOUND : constant Interrupt_ID := - System.OS_Interface.SIGSOUND; -- sound control has completed - - SIGSAK : constant Interrupt_ID := - System.OS_Interface.SIGSAK; -- secure attention key - -end Ada.Interrupts.Names; diff --git a/gcc/ada/4gintnam.ads b/gcc/ada/4gintnam.ads deleted file mode 100644 index afd82f2bb6c..00000000000 --- a/gcc/ada/4gintnam.ads +++ /dev/null @@ -1,196 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-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 Library General Public License as published by the -- --- Free Software Foundation; either version 2, or (at your option) any -- --- later version. GNARL is distributed in the hope that it will be use- -- --- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of -- --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Gen- -- --- eral Library Public License for more details. You should have received -- --- a copy of the GNU Library General Public License along with GNARL; see -- --- file COPYING.LIB. 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 Irix version of this package - --- The following signals are reserved by the run time (Athread library): - --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGSTOP, SIGKILL - --- The following signals are reserved by the run time (Pthread library): - --- SIGTSTP, SIGILL, SIGTRAP, SIGEMT, SIGFPE, SIGBUS, SIGSTOP, SIGKILL, --- SIGSEGV, SIGSYS, SIGXCPU, SIGXFSZ, SIGPROF, SIGPTINTR, SIGPTRESCHED, --- SIGABRT, SIGINT - --- The pragma Unreserve_All_Interrupts affects the following signal --- (Pthread library): - --- SIGINT: made available for Ada handler - --- This target-dependent package spec contains names of interrupts --- supported by the local system. - -with System.OS_Interface; --- used for names of interrupts - -package Ada.Interrupts.Names is - - -- Beware that the mapping of names to signals may be - -- many-to-one. There may be aliases. Also, for all - -- signal names that are not supported on the current system - -- the value of the corresponding constant will be zero. - - SIGHUP : constant Interrupt_ID := - System.OS_Interface.SIGHUP; -- hangup - - SIGINT : constant Interrupt_ID := - System.OS_Interface.SIGINT; -- interrupt (rubout) - - SIGQUIT : constant Interrupt_ID := - System.OS_Interface.SIGQUIT; -- quit (ASCD FS) - - SIGILL : constant Interrupt_ID := - System.OS_Interface.SIGILL; -- illegal instruction (not reset) - - SIGTRAP : constant Interrupt_ID := - System.OS_Interface.SIGTRAP; -- trace trap (not reset) - - SIGIOT : constant Interrupt_ID := - System.OS_Interface.SIGIOT; -- IOT instruction - - SIGABRT : constant Interrupt_ID := - System.OS_Interface.SIGABRT; -- used by abort, replace SIGIOT in the - -- future - - SIGEMT : constant Interrupt_ID := - System.OS_Interface.SIGEMT; -- EMT instruction - - SIGFPE : constant Interrupt_ID := - System.OS_Interface.SIGFPE; -- floating point exception - - SIGKILL : constant Interrupt_ID := - System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) - - SIGBUS : constant Interrupt_ID := - System.OS_Interface.SIGBUS; -- bus error - - SIGSEGV : constant Interrupt_ID := - System.OS_Interface.SIGSEGV; -- segmentation violation - - SIGSYS : constant Interrupt_ID := - System.OS_Interface.SIGSYS; -- bad argument to system call - - SIGPIPE : constant Interrupt_ID := - System.OS_Interface.SIGPIPE; -- write on pipe with no one to read it - - SIGALRM : constant Interrupt_ID := - System.OS_Interface.SIGALRM; -- alarm clock - - SIGTERM : constant Interrupt_ID := - System.OS_Interface.SIGTERM; -- software termination signal from kill - - SIGUSR1 : constant Interrupt_ID := - System.OS_Interface.SIGUSR1; -- user defined signal 1 - - SIGUSR2 : constant Interrupt_ID := - System.OS_Interface.SIGUSR2; -- user defined signal 2 - - SIGCLD : constant Interrupt_ID := - System.OS_Interface.SIGCLD; -- alias for SIGCHLD - - SIGCHLD : constant Interrupt_ID := - System.OS_Interface.SIGCHLD; -- child status change - - SIGPWR : constant Interrupt_ID := - System.OS_Interface.SIGPWR; -- power-fail restart - - SIGWINCH : constant Interrupt_ID := - System.OS_Interface.SIGWINCH; -- window size change - - SIGURG : constant Interrupt_ID := - System.OS_Interface.SIGURG; -- urgent condition on IO channel - - SIGPOLL : constant Interrupt_ID := - System.OS_Interface.SIGPOLL; -- pollable event occurred - - SIGIO : constant Interrupt_ID := - System.OS_Interface.SIGIO; -- I/O possible (Solaris SIGPOLL alias) - - SIGSTOP : constant Interrupt_ID := - System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) - - SIGTSTP : constant Interrupt_ID := - System.OS_Interface.SIGTSTP; -- user stop requested from tty - - SIGCONT : constant Interrupt_ID := - System.OS_Interface.SIGCONT; -- stopped process has been continued - - SIGTTIN : constant Interrupt_ID := - System.OS_Interface.SIGTTIN; -- background tty read attempted - - SIGTTOU : constant Interrupt_ID := - System.OS_Interface.SIGTTOU; -- background tty write attempted - - SIGVTALRM : constant Interrupt_ID := - System.OS_Interface.SIGVTALRM; -- virtual timer expired - - SIGPROF : constant Interrupt_ID := - System.OS_Interface.SIGPROF; -- profiling timer expired - - SIGXCPU : constant Interrupt_ID := - System.OS_Interface.SIGXCPU; -- CPU time limit exceeded - - SIGXFSZ : constant Interrupt_ID := - System.OS_Interface.SIGXFSZ; -- filesize limit exceeded - - SIGK32 : constant Interrupt_ID := - System.OS_Interface.SIGK32; -- reserved for kernel (IRIX) - - SIGCKPT : constant Interrupt_ID := - System.OS_Interface.SIGCKPT; -- Checkpoint warning - - SIGRESTART : constant Interrupt_ID := - System.OS_Interface.SIGRESTART; -- Restart warning - - SIGUME : constant Interrupt_ID := - System.OS_Interface.SIGUME; -- Uncorrectable memory error - - -- Signals defined for Posix 1003.1c. - - SIGPTINTR : constant Interrupt_ID := - System.OS_Interface.SIGPTINTR; -- Pthread Interrupt Signal - - SIGPTRESCHED : constant Interrupt_ID := - System.OS_Interface.SIGPTRESCHED; -- Pthread Rescheduling Signal - - -- Posix 1003.1b signals - - SIGRTMIN : constant Interrupt_ID := - System.OS_Interface.SIGRTMIN; -- Posix 1003.1b signals - - SIGRTMAX : constant Interrupt_ID := - System.OS_Interface.SIGRTMAX; -- Posix 1003.1b signals - -end Ada.Interrupts.Names; diff --git a/gcc/ada/4hexcpol.adb b/gcc/ada/4hexcpol.adb deleted file mode 100644 index 7deb26a8603..00000000000 --- a/gcc/ada/4hexcpol.adb +++ /dev/null @@ -1,66 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . E X C E P T I O N S . P O L L -- --- (version supporting asynchronous abort test and time slicing) -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2000, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for targets that do not support per-thread asynchronous --- signals or that do not handle async timers properly. On such targets, we --- require compilation with the -gnatP switch that activates periodic polling. --- Then in the body of the polling routine we test for asynchronous abort and --- yield periodically. - --- HP-UX and SCO currently use this file - -with System.Soft_Links; --- used for Check_Abort_Status - -separate (Ada.Exceptions) - ----------- --- Poll -- ----------- - -procedure Poll is -begin - if Counter = 10000 then - Counter := 0; - delay 0.0; - else - Counter := Counter + 1; - end if; - - -- Test for asynchronous abort on each poll - - if System.Soft_Links.Check_Abort_Status.all /= 0 then - raise Standard'Abort_Signal; - end if; -end Poll; diff --git a/gcc/ada/4hintnam.ads b/gcc/ada/4hintnam.ads deleted file mode 100644 index 0e01a0fa74e..00000000000 --- a/gcc/ada/4hintnam.ads +++ /dev/null @@ -1,155 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-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 HP-UX version of this package. - --- The following signals are reserved by the run time: - --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT, --- SIGALRM, SIGSTOP, SIGKILL - --- The pragma Unreserve_All_Interrupts affects the following signal(s): - --- SIGINT: made available for Ada handler - --- This target-dependent package spec contains names of interrupts --- supported by the local system. - -with System.OS_Interface; --- used for names of interrupts - -package Ada.Interrupts.Names is - - -- Beware that the mapping of names to signals may be - -- many-to-one. There may be aliases. Also, for all - -- signal names that are not supported on the current system - -- the value of the corresponding constant will be zero. - - SIGHUP : constant Interrupt_ID := - System.OS_Interface.SIGHUP; -- hangup - - SIGINT : constant Interrupt_ID := - System.OS_Interface.SIGINT; -- interrupt (rubout) - - SIGQUIT : constant Interrupt_ID := - System.OS_Interface.SIGQUIT; -- quit (ASCD FS) - - SIGILL : constant Interrupt_ID := - System.OS_Interface.SIGILL; -- illegal instruction (not reset) - - SIGTRAP : constant Interrupt_ID := - System.OS_Interface.SIGTRAP; -- trace trap (not reset) - - SIGIOT : constant Interrupt_ID := - System.OS_Interface.SIGIOT; -- IOT instruction - - SIGABRT : constant Interrupt_ID := -- used by abort, - System.OS_Interface.SIGABRT; -- replace SIGIOT in the future - - SIGEMT : constant Interrupt_ID := - System.OS_Interface.SIGEMT; -- EMT instruction - - SIGFPE : constant Interrupt_ID := - System.OS_Interface.SIGFPE; -- floating point exception - - SIGKILL : constant Interrupt_ID := - System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) - - SIGBUS : constant Interrupt_ID := - System.OS_Interface.SIGBUS; -- bus error - - SIGSEGV : constant Interrupt_ID := - System.OS_Interface.SIGSEGV; -- segmentation violation - - SIGSYS : constant Interrupt_ID := - System.OS_Interface.SIGSYS; -- bad argument to system call - - SIGPIPE : constant Interrupt_ID := -- write on a pipe with - System.OS_Interface.SIGPIPE; -- no one to read it - - SIGALRM : constant Interrupt_ID := - System.OS_Interface.SIGALRM; -- alarm clock - - SIGTERM : constant Interrupt_ID := - System.OS_Interface.SIGTERM; -- software termination signal from kill - - SIGUSR1 : constant Interrupt_ID := - System.OS_Interface.SIGUSR1; -- user defined signal 1 - - SIGUSR2 : constant Interrupt_ID := - System.OS_Interface.SIGUSR2; -- user defined signal 2 - - SIGCLD : constant Interrupt_ID := - System.OS_Interface.SIGCLD; -- child status change - - SIGCHLD : constant Interrupt_ID := - System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD - - SIGWINCH : constant Interrupt_ID := - System.OS_Interface.SIGWINCH; -- window size change - - SIGURG : constant Interrupt_ID := - System.OS_Interface.SIGURG; -- urgent condition on IO channel - - SIGPOLL : constant Interrupt_ID := - System.OS_Interface.SIGPOLL; -- pollable event occurred - - SIGIO : constant Interrupt_ID := -- input/output possible, - System.OS_Interface.SIGIO; -- SIGPOLL alias - - SIGSTOP : constant Interrupt_ID := - System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) - - SIGTSTP : constant Interrupt_ID := - System.OS_Interface.SIGTSTP; -- user stop requested from tty - - SIGCONT : constant Interrupt_ID := - System.OS_Interface.SIGCONT; -- stopped process has been continued - - SIGTTIN : constant Interrupt_ID := - System.OS_Interface.SIGTTIN; -- background tty read attempted - - SIGTTOU : constant Interrupt_ID := - System.OS_Interface.SIGTTOU; -- background tty write attempted - - SIGVTALRM : constant Interrupt_ID := - System.OS_Interface.SIGVTALRM; -- virtual timer expired - - SIGPROF : constant Interrupt_ID := - System.OS_Interface.SIGPROF; -- profiling timer expired - - SIGPWR : constant Interrupt_ID := - System.OS_Interface.SIGPWR; -- power-fail restart - -end Ada.Interrupts.Names; diff --git a/gcc/ada/4lintnam.ads b/gcc/ada/4lintnam.ads deleted file mode 100644 index ce9ccc774db..00000000000 --- a/gcc/ada/4lintnam.ads +++ /dev/null @@ -1,168 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-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 GNU/Linux version of this package. --- --- The following signals are reserved by the run time (FSU threads): --- --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, --- SIGALRM, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL --- --- The following signals are reserved by the run time (LinuxThreads): --- --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, --- SIGUSR1, SIGUSR2, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL --- --- The pragma Unreserve_All_Interrupts affects the following signal(s): --- --- SIGINT: made available for Ada handler - --- This target-dependent package spec contains names of interrupts --- supported by the local system. - -with System.OS_Interface; --- used for names of interrupts - -package Ada.Interrupts.Names is - - -- Beware that the mapping of names to signals may be - -- many-to-one. There may be aliases. Also, for all - -- signal names that are not supported on the current system - -- the value of the corresponding constant will be zero. - - SIGHUP : constant Interrupt_ID := - System.OS_Interface.SIGHUP; -- hangup - - SIGINT : constant Interrupt_ID := - System.OS_Interface.SIGINT; -- interrupt (rubout) - - SIGQUIT : constant Interrupt_ID := - System.OS_Interface.SIGQUIT; -- quit (ASCD FS) - - SIGILL : constant Interrupt_ID := - System.OS_Interface.SIGILL; -- illegal instruction (not reset) - - SIGTRAP : constant Interrupt_ID := - System.OS_Interface.SIGTRAP; -- trace trap (not reset) - - SIGIOT : constant Interrupt_ID := - System.OS_Interface.SIGIOT; -- IOT instruction - - SIGABRT : constant Interrupt_ID := -- used by abort, - System.OS_Interface.SIGABRT; -- replace SIGIOT in the future - - SIGFPE : constant Interrupt_ID := - System.OS_Interface.SIGFPE; -- floating point exception - - SIGKILL : constant Interrupt_ID := - System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) - - SIGBUS : constant Interrupt_ID := - System.OS_Interface.SIGBUS; -- bus error - - SIGSEGV : constant Interrupt_ID := - System.OS_Interface.SIGSEGV; -- segmentation violation - - SIGPIPE : constant Interrupt_ID := -- write on a pipe with - System.OS_Interface.SIGPIPE; -- no one to read it - - SIGALRM : constant Interrupt_ID := - System.OS_Interface.SIGALRM; -- alarm clock - - SIGTERM : constant Interrupt_ID := - System.OS_Interface.SIGTERM; -- software termination signal from kill - - SIGUSR1 : constant Interrupt_ID := - System.OS_Interface.SIGUSR1; -- user defined signal 1 - - SIGUSR2 : constant Interrupt_ID := - System.OS_Interface.SIGUSR2; -- user defined signal 2 - - SIGCLD : constant Interrupt_ID := - System.OS_Interface.SIGCLD; -- child status change - - SIGCHLD : constant Interrupt_ID := - System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD - - SIGWINCH : constant Interrupt_ID := - System.OS_Interface.SIGWINCH; -- window size change - - SIGURG : constant Interrupt_ID := - System.OS_Interface.SIGURG; -- urgent condition on IO channel - - SIGPOLL : constant Interrupt_ID := - System.OS_Interface.SIGPOLL; -- pollable event occurred - - SIGIO : constant Interrupt_ID := -- input/output possible, - System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) - - SIGSTOP : constant Interrupt_ID := - System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) - - SIGTSTP : constant Interrupt_ID := - System.OS_Interface.SIGTSTP; -- user stop requested from tty - - SIGCONT : constant Interrupt_ID := - System.OS_Interface.SIGCONT; -- stopped process has been continued - - SIGTTIN : constant Interrupt_ID := - System.OS_Interface.SIGTTIN; -- background tty read attempted - - SIGTTOU : constant Interrupt_ID := - System.OS_Interface.SIGTTOU; -- background tty write attempted - - SIGVTALRM : constant Interrupt_ID := - System.OS_Interface.SIGVTALRM; -- virtual timer expired - - SIGPROF : constant Interrupt_ID := - System.OS_Interface.SIGPROF; -- profiling timer expired - - SIGXCPU : constant Interrupt_ID := - System.OS_Interface.SIGXCPU; -- CPU time limit exceeded - - SIGXFSZ : constant Interrupt_ID := - System.OS_Interface.SIGXFSZ; -- filesize limit exceeded - - SIGUNUSED : constant Interrupt_ID := - System.OS_Interface.SIGUNUSED; -- unused signal - - SIGSTKFLT : constant Interrupt_ID := - System.OS_Interface.SIGSTKFLT; -- stack fault on coprocessor - - SIGLOST : constant Interrupt_ID := - System.OS_Interface.SIGLOST; -- Linux alias for SIGIO - - SIGPWR : constant Interrupt_ID := - System.OS_Interface.SIGPWR; -- Power failure - -end Ada.Interrupts.Names; diff --git a/gcc/ada/4nintnam.ads b/gcc/ada/4nintnam.ads deleted file mode 100644 index 427ba5cc18a..00000000000 --- a/gcc/ada/4nintnam.ads +++ /dev/null @@ -1,48 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- (No Tasking Version) -- --- -- --- Copyright (C) 1991-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. -- --- -- ------------------------------------------------------------------------------- - --- The standard implementation of this spec contains only dummy interrupt --- names. These dummy entries permit checking out code for correctness of --- semantics, even if interrupts are not supported. - --- For specific implementations that fully support interrupts, this package --- spec is replaced by an implementation dependent version that defines the --- interrupts available on the system. - -package Ada.Interrupts.Names is - - DUMMY_INTERRUPT_1 : constant Interrupt_ID := 1; - DUMMY_INTERRUPT_2 : constant Interrupt_ID := 2; - -end Ada.Interrupts.Names; diff --git a/gcc/ada/4ointnam.ads b/gcc/ada/4ointnam.ads deleted file mode 100644 index 6733730b372..00000000000 --- a/gcc/ada/4ointnam.ads +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-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 an OS/2 version of this package. - --- This target-dependent package spec contains names of interrupts --- supported by the local system. - --- This is a stub, for systems that do not support interrupts (or signals) - -package Ada.Interrupts.Names is -end Ada.Interrupts.Names; diff --git a/gcc/ada/4onumaux.ads b/gcc/ada/4onumaux.ads deleted file mode 100644 index 0f84a9fe053..00000000000 --- a/gcc/ada/4onumaux.ads +++ /dev/null @@ -1,108 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUNTIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- S p e c -- --- (C Library Version for x86) -- --- -- --- Copyright (C) 1992-2003 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. The C library version interfaces with the routines --- in the C mathematical library, and is thus quite portable, although it may --- not necessarily meet the requirements for accuracy in the numerics annex. --- One advantage of using this package is that it will interface directly to --- hardware instructions, such as the those provided on the Intel x86. - --- 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). - -package Ada.Numerics.Aux is -pragma Pure (Aux); - - pragma Linker_Options ("-lm"); - - type Double is digits 18; - - -- We import these functions directly from C. Note that we label them - -- all as pure functions, because indeed all of them are in fact pure! - - function Sin (X : Double) return Double; - pragma Import (C, Sin, "sinl"); - pragma Pure_Function (Sin); - - function Cos (X : Double) return Double; - pragma Import (C, Cos, "cosl"); - pragma Pure_Function (Cos); - - function Tan (X : Double) return Double; - pragma Import (C, Tan, "tanl"); - pragma Pure_Function (Tan); - - function Exp (X : Double) return Double; - pragma Import (C, Exp, "expl"); - pragma Pure_Function (Exp); - - function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "sqrtl"); - pragma Pure_Function (Sqrt); - - function Log (X : Double) return Double; - pragma Import (C, Log, "logl"); - pragma Pure_Function (Log); - - function Acos (X : Double) return Double; - pragma Import (C, Acos, "acosl"); - pragma Pure_Function (Acos); - - function Asin (X : Double) return Double; - pragma Import (C, Asin, "asinl"); - pragma Pure_Function (Asin); - - function Atan (X : Double) return Double; - pragma Import (C, Atan, "atanl"); - pragma Pure_Function (Atan); - - function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "sinhl"); - pragma Pure_Function (Sinh); - - function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "coshl"); - pragma Pure_Function (Cosh); - - function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "tanhl"); - pragma Pure_Function (Tanh); - - function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "powl"); - pragma Pure_Function (Pow); - -end Ada.Numerics.Aux; diff --git a/gcc/ada/4pintnam.ads b/gcc/ada/4pintnam.ads deleted file mode 100644 index f9cac69dc99..00000000000 --- a/gcc/ada/4pintnam.ads +++ /dev/null @@ -1,154 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-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 OpenNT (FSU THREAD) version of this package. --- --- The following signals are reserved by the run time: --- --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, --- SIGALRM, SIGVTALRM, SIGSTOP, SIGKILL --- --- The pragma Unreserve_All_Interrupts affects the following signal(s): --- --- SIGINT: made available for Ada handlers - --- This target-dependent package spec contains names of interrupts --- supported by the local system. - -with System.OS_Interface; --- used for names of interrupts - -package Ada.Interrupts.Names is - - -- Beware that the mapping of names to signals may be - -- many-to-one. There may be aliases. Also, for all - -- signal names that are not supported on the current system - -- the value of the corresponding constant will be zero. - - SIGHUP : constant Interrupt_ID := - System.OS_Interface.SIGHUP; -- hangup - - SIGINT : constant Interrupt_ID := - System.OS_Interface.SIGINT; -- interrupt (rubout) - - SIGQUIT : constant Interrupt_ID := - System.OS_Interface.SIGQUIT; -- quit (ASCD FS) - - SIGILL : constant Interrupt_ID := - System.OS_Interface.SIGILL; -- illegal instruction (not reset) - - SIGTRAP : constant Interrupt_ID := - System.OS_Interface.SIGTRAP; -- trace trap (not reset) - - SIGIOT : constant Interrupt_ID := - System.OS_Interface.SIGIOT; -- IOT instruction - - SIGABRT : constant Interrupt_ID := -- used by abort, - System.OS_Interface.SIGABRT; -- replace SIGIOT in the future - - SIGFPE : constant Interrupt_ID := - System.OS_Interface.SIGFPE; -- floating point exception - - SIGKILL : constant Interrupt_ID := - System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) - - SIGBUS : constant Interrupt_ID := - System.OS_Interface.SIGBUS; -- bus error - - SIGSEGV : constant Interrupt_ID := - System.OS_Interface.SIGSEGV; -- segmentation violation - - SIGSYS : constant Interrupt_ID := - System.OS_Interface.SIGSYS; -- bad argument to system call - - SIGPIPE : constant Interrupt_ID := -- write on a pipe with - System.OS_Interface.SIGPIPE; -- no one to read it - - SIGALRM : constant Interrupt_ID := - System.OS_Interface.SIGALRM; -- alarm clock - - SIGTERM : constant Interrupt_ID := - System.OS_Interface.SIGTERM; -- software termination signal from kill - - SIGUSR1 : constant Interrupt_ID := - System.OS_Interface.SIGUSR1; -- user defined signal 1 - - SIGUSR2 : constant Interrupt_ID := - System.OS_Interface.SIGUSR2; -- user defined signal 2 - - SIGCLD : constant Interrupt_ID := - System.OS_Interface.SIGCLD; -- child status change - - SIGCHLD : constant Interrupt_ID := - System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD - - SIGWINCH : constant Interrupt_ID := - System.OS_Interface.SIGWINCH; -- window size change - - SIGURG : constant Interrupt_ID := - System.OS_Interface.SIGURG; -- urgent condition on IO channel - - SIGPOLL : constant Interrupt_ID := - System.OS_Interface.SIGPOLL; -- pollable event occurred - - SIGIO : constant Interrupt_ID := -- input/output possible, - System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) - - SIGSTOP : constant Interrupt_ID := - System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) - - SIGTSTP : constant Interrupt_ID := - System.OS_Interface.SIGTSTP; -- user stop requested from tty - - SIGCONT : constant Interrupt_ID := - System.OS_Interface.SIGCONT; -- stopped process has been continued - - SIGTTIN : constant Interrupt_ID := - System.OS_Interface.SIGTTIN; -- background tty read attempted - - SIGTTOU : constant Interrupt_ID := - System.OS_Interface.SIGTTOU; -- background tty write attempted - - SIGVTALRM : constant Interrupt_ID := - System.OS_Interface.SIGVTALRM; -- virtual timer expired - - SIGPROF : constant Interrupt_ID := - System.OS_Interface.SIGPROF; -- profiling timer expired - - SIGXCPU : constant Interrupt_ID := - System.OS_Interface.SIGXCPU; -- CPU time limit exceeded - - SIGXFSZ : constant Interrupt_ID := - System.OS_Interface.SIGXFSZ; -- filesize limit exceeded - -end Ada.Interrupts.Names; diff --git a/gcc/ada/4sintnam.ads b/gcc/ada/4sintnam.ads deleted file mode 100644 index d6fc181ea9e..00000000000 --- a/gcc/ada/4sintnam.ads +++ /dev/null @@ -1,179 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-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 Solaris version of this package. --- --- The following signals are reserved by the run time (native threads): --- --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, --- SIGLWP, SIGWAITING, SIGCANCEL, SIGSTOP, SIGKILL --- --- The following signals are reserved by the run time (FSU threads): --- --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT, --- SIGLWP, SIGALRM, SIGVTALRM, SIGAITING, SIGSTOP, SIGKILL --- --- The pragma Unreserve_All_Interrupts affects the following signal(s): --- --- SIGINT: made available for Ada handlers - -with System.OS_Interface; --- used for names of interrupts - -package Ada.Interrupts.Names is - - -- Beware that the mapping of names to signals may be - -- many-to-one. There may be aliases. Also, for all - -- signal names that are not supported on the current system - -- the value of the corresponding constant will be zero. - - SIGHUP : constant Interrupt_ID := - System.OS_Interface.SIGHUP; -- hangup - - SIGINT : constant Interrupt_ID := - System.OS_Interface.SIGINT; -- interrupt (rubout) - - SIGQUIT : constant Interrupt_ID := - System.OS_Interface.SIGQUIT; -- quit (ASCD FS) - - SIGILL : constant Interrupt_ID := - System.OS_Interface.SIGILL; -- illegal instruction (not reset) - - SIGTRAP : constant Interrupt_ID := - System.OS_Interface.SIGTRAP; -- trace trap (not reset) - - SIGIOT : constant Interrupt_ID := - System.OS_Interface.SIGIOT; -- IOT instruction - - SIGABRT : constant Interrupt_ID := -- used by abort, - System.OS_Interface.SIGABRT; -- replace SIGIOT in the future - - SIGEMT : constant Interrupt_ID := - System.OS_Interface.SIGEMT; -- EMT instruction - - SIGFPE : constant Interrupt_ID := - System.OS_Interface.SIGFPE; -- floating point exception - - SIGKILL : constant Interrupt_ID := - System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) - - SIGBUS : constant Interrupt_ID := - System.OS_Interface.SIGBUS; -- bus error - - SIGSEGV : constant Interrupt_ID := - System.OS_Interface.SIGSEGV; -- segmentation violation - - SIGSYS : constant Interrupt_ID := - System.OS_Interface.SIGSYS; -- bad argument to system call - - SIGPIPE : constant Interrupt_ID := -- write on a pipe with - System.OS_Interface.SIGPIPE; -- no one to read it - - SIGALRM : constant Interrupt_ID := - System.OS_Interface.SIGALRM; -- alarm clock - - SIGTERM : constant Interrupt_ID := - System.OS_Interface.SIGTERM; -- software termination signal from kill - - SIGUSR1 : constant Interrupt_ID := - System.OS_Interface.SIGUSR1; -- user defined signal 1 - - SIGUSR2 : constant Interrupt_ID := - System.OS_Interface.SIGUSR2; -- user defined signal 2 - - SIGCLD : constant Interrupt_ID := - System.OS_Interface.SIGCLD; -- child status change - - SIGCHLD : constant Interrupt_ID := - System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD - - SIGWINCH : constant Interrupt_ID := - System.OS_Interface.SIGWINCH; -- window size change - - SIGURG : constant Interrupt_ID := - System.OS_Interface.SIGURG; -- urgent condition on IO channel - - SIGPOLL : constant Interrupt_ID := - System.OS_Interface.SIGPOLL; -- pollable event occurred - - SIGIO : constant Interrupt_ID := -- input/output possible, - System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) - - SIGSTOP : constant Interrupt_ID := - System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) - - SIGTSTP : constant Interrupt_ID := - System.OS_Interface.SIGTSTP; -- user stop requested from tty - - SIGCONT : constant Interrupt_ID := - System.OS_Interface.SIGCONT; -- stopped process has been continued - - SIGTTIN : constant Interrupt_ID := - System.OS_Interface.SIGTTIN; -- background tty read attempted - - SIGTTOU : constant Interrupt_ID := - System.OS_Interface.SIGTTOU; -- background tty write attempted - - SIGVTALRM : constant Interrupt_ID := - System.OS_Interface.SIGVTALRM; -- virtual timer expired - - SIGPROF : constant Interrupt_ID := - System.OS_Interface.SIGPROF; -- profiling timer expired - - SIGXCPU : constant Interrupt_ID := - System.OS_Interface.SIGXCPU; -- CPU time limit exceeded - - SIGXFSZ : constant Interrupt_ID := - System.OS_Interface.SIGXFSZ; -- filesize limit exceeded - - SIGPWR : constant Interrupt_ID := - System.OS_Interface.SIGPWR; -- power-fail restart - - SIGWAITING : constant Interrupt_ID := - System.OS_Interface.SIGWAITING; -- process's lwps blocked (Solaris) - - SIGLWP : constant Interrupt_ID := - System.OS_Interface.SIGLWP; -- used by thread library (Solaris) - - SIGFREEZE : constant Interrupt_ID := - System.OS_Interface.SIGFREEZE; -- used by CPR (Solaris) - --- what is CPR???? - - SIGTHAW : constant Interrupt_ID := - System.OS_Interface.SIGTHAW; -- used by CPR (Solaris) - - SIGCANCEL : constant Interrupt_ID := - System.OS_Interface.SIGCANCEL; -- used for thread cancel (Solaris) - -end Ada.Interrupts.Names; diff --git a/gcc/ada/4vcaldel.adb b/gcc/ada/4vcaldel.adb deleted file mode 100644 index a95eae657b8..00000000000 --- a/gcc/ada/4vcaldel.adb +++ /dev/null @@ -1,99 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . C A L E N D A R . D E L A Y S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 the Alpha/VMS version. - -with System.OS_Primitives; --- Used for Max_Sensible_Delay - -with System.Soft_Links; --- Used for Timed_Delay - -package body Ada.Calendar.Delays is - - package OSP renames System.OS_Primitives; - package TSL renames System.Soft_Links; - - use type TSL.Timed_Delay_Call; - - --------------- - -- Delay_For -- - --------------- - - procedure Delay_For (D : Duration) is - begin - TSL.Timed_Delay.all - (Duration'Min (D, OSP.Max_Sensible_Delay), OSP.Relative); - end Delay_For; - - ----------------- - -- Delay_Until -- - ----------------- - - procedure Delay_Until (T : Time) is - begin - TSL.Timed_Delay.all (To_Duration (T), OSP.Absolute_Calendar); - end Delay_Until; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (T : Time) return Duration is - begin - return OSP.To_Duration (OSP.OS_Time (T), OSP.Absolute_Calendar); - end To_Duration; - - -------------------- - -- Timed_Delay_NT -- - -------------------- - - procedure Timed_Delay_NT (Time : Duration; Mode : Integer); - - procedure Timed_Delay_NT (Time : Duration; Mode : Integer) is - begin - OSP.Timed_Delay (Time, Mode); - end Timed_Delay_NT; - -begin - -- Set up the Timed_Delay soft link to the non tasking version if it has - -- not been already set. - -- If tasking is present, Timed_Delay has already set this soft link, or - -- this will be overriden during the elaboration of - -- System.Tasking.Initialization - - if TSL.Timed_Delay = null then - TSL.Timed_Delay := Timed_Delay_NT'Access; - end if; -end Ada.Calendar.Delays; diff --git a/gcc/ada/4vcalend.adb b/gcc/ada/4vcalend.adb deleted file mode 100644 index 74c2923cbf2..00000000000 --- a/gcc/ada/4vcalend.adb +++ /dev/null @@ -1,361 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C A L E N D A R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2003 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 System.Aux_DEC; use System.Aux_DEC; - -package body Ada.Calendar is - - ------------------------------ - -- Use of Pragma Unsuppress -- - ------------------------------ - - -- This implementation of Calendar takes advantage of the permission in - -- Ada 95 of using arithmetic overflow checks to check for out of bounds - -- time values. This means that we must catch the constraint error that - -- results from arithmetic overflow, so we use pragma Unsuppress to make - -- sure that overflow is enabled, using software overflow checking if - -- necessary. That way, compiling Calendar with options to suppress this - -- checking will not affect its correctness. - - ------------------------ - -- Local Declarations -- - ------------------------ - - Ada_Year_Min : constant := 1901; - Ada_Year_Max : constant := 2099; - - -- Some basic constants used throughout - - function To_Relative_Time (D : Duration) return Time; - - function To_Relative_Time (D : Duration) return Time is - begin - return Time (Long_Integer'Integer_Value (D) / 100); - end To_Relative_Time; - - --------- - -- "+" -- - --------- - - function "+" (Left : Time; Right : Duration) return Time is - pragma Unsuppress (Overflow_Check); - begin - return (Left + To_Relative_Time (Right)); - - exception - when Constraint_Error => - raise Time_Error; - end "+"; - - function "+" (Left : Duration; Right : Time) return Time is - pragma Unsuppress (Overflow_Check); - begin - return (To_Relative_Time (Left) + Right); - - exception - when Constraint_Error => - raise Time_Error; - end "+"; - - --------- - -- "-" -- - --------- - - function "-" (Left : Time; Right : Duration) return Time is - pragma Unsuppress (Overflow_Check); - begin - return Left - To_Relative_Time (Right); - - exception - when Constraint_Error => - raise Time_Error; - end "-"; - - function "-" (Left : Time; Right : Time) return Duration is - pragma Unsuppress (Overflow_Check); - begin - return Duration'Fixed_Value - ((Long_Integer (Left) - Long_Integer (Right)) * 100); - - exception - when Constraint_Error => - raise Time_Error; - end "-"; - - --------- - -- "<" -- - --------- - - function "<" (Left, Right : Time) return Boolean is - begin - return Long_Integer (Left) < Long_Integer (Right); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" (Left, Right : Time) return Boolean is - begin - return Long_Integer (Left) <= Long_Integer (Right); - end "<="; - - --------- - -- ">" -- - --------- - - function ">" (Left, Right : Time) return Boolean is - begin - return Long_Integer (Left) > Long_Integer (Right); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" (Left, Right : Time) return Boolean is - begin - return Long_Integer (Left) >= Long_Integer (Right); - end ">="; - - ----------- - -- Clock -- - ----------- - - -- The Ada.Calendar.Clock function gets the time. - -- Note that on other targets a soft-link is used to get a different clock - -- depending whether tasking is used or not. On VMS this isn't needed - -- since all clock calls end up using SYS$GETTIM, so call the - -- OS_Primitives version for efficiency. - - function Clock return Time is - begin - return Time (OSP.OS_Clock); - end Clock; - - --------- - -- Day -- - --------- - - function Day (Date : Time) return Day_Number is - DY : Year_Number; - DM : Month_Number; - DD : Day_Number; - DS : Day_Duration; - - begin - Split (Date, DY, DM, DD, DS); - return DD; - end Day; - - ----------- - -- Month -- - ----------- - - function Month (Date : Time) return Month_Number is - DY : Year_Number; - DM : Month_Number; - DD : Day_Number; - DS : Day_Duration; - - begin - Split (Date, DY, DM, DD, DS); - return DM; - end Month; - - ------------- - -- Seconds -- - ------------- - - function Seconds (Date : Time) return Day_Duration is - DY : Year_Number; - DM : Month_Number; - DD : Day_Number; - DS : Day_Duration; - - begin - Split (Date, DY, DM, DD, DS); - return DS; - end Seconds; - - ----------- - -- Split -- - ----------- - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Seconds : out Day_Duration) - is - procedure Numtim ( - Status : out Unsigned_Longword; - Timbuf : out Unsigned_Word_Array; - Timadr : in Time); - - pragma Interface (External, Numtim); - - pragma Import_Valued_Procedure (Numtim, "SYS$NUMTIM", - (Unsigned_Longword, Unsigned_Word_Array, Time), - (Value, Reference, Reference)); - - Status : Unsigned_Longword; - Timbuf : Unsigned_Word_Array (1 .. 7); - - Subsecs : constant Time := Date mod 10_000_000; - Date_Secs : constant Time := Date - Subsecs; - - begin - Numtim (Status, Timbuf, Date_Secs); - - if Status mod 2 /= 1 - or else Timbuf (1) not in Ada_Year_Min .. Ada_Year_Max - then - raise Time_Error; - end if; - - Seconds := Day_Duration (Timbuf (6) - + 60 * (Timbuf (5) + 60 * Timbuf (4))) - + Duration (Subsecs) / 10_000_000.0; - - Day := Integer (Timbuf (3)); - Month := Integer (Timbuf (2)); - Year := Integer (Timbuf (1)); - end Split; - - ------------- - -- Time_Of -- - ------------- - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Seconds : Day_Duration := 0.0) - return Time - is - - procedure Cvt_Vectim ( - Status : out Unsigned_Longword; - Input_Time : in Unsigned_Word_Array; - Resultant_Time : out Time); - - pragma Interface (External, Cvt_Vectim); - - pragma Import_Valued_Procedure (Cvt_Vectim, "LIB$CVT_VECTIM", - (Unsigned_Longword, Unsigned_Word_Array, Time), - (Value, Reference, Reference)); - - Status : Unsigned_Longword; - Timbuf : Unsigned_Word_Array (1 .. 7); - Date : Time; - Int_Secs : Integer; - Day_Hack : Boolean := False; - Subsecs : Day_Duration; - - begin - -- The following checks are redundant with respect to the constraint - -- error checks that should normally be made on parameters, but we - -- decide to raise Constraint_Error in any case if bad values come - -- in (as a result of checks being off in the caller, or for other - -- erroneous or bounded error cases). - - if not Year 'Valid - or else not Month 'Valid - or else not Day 'Valid - or else not Seconds'Valid - then - raise Constraint_Error; - end if; - - -- Truncate seconds value by subtracting 0.5 and rounding, - -- but be careful with 0.0 since that will give -1.0 unless - -- it is treated specially. - - if Seconds > 0.0 then - Int_Secs := Integer (Seconds - 0.5); - else - Int_Secs := Integer (Seconds); - end if; - - Subsecs := Seconds - Day_Duration (Int_Secs); - - -- Cvt_Vectim barfs on the largest Day_Duration, so trick it by - -- setting it to zero and then adding the difference after conversion. - - if Int_Secs = 86_400 then - Int_Secs := 0; - Day_Hack := True; - end if; - - Timbuf (7) := 0; - Timbuf (6) := Unsigned_Word (Int_Secs mod 60); - Timbuf (5) := Unsigned_Word ((Int_Secs / 60) mod 60); - Timbuf (4) := Unsigned_Word (Int_Secs / 3600); - Timbuf (3) := Unsigned_Word (Day); - Timbuf (2) := Unsigned_Word (Month); - Timbuf (1) := Unsigned_Word (Year); - - Cvt_Vectim (Status, Timbuf, Date); - - if Status mod 2 /= 1 then - raise Time_Error; - end if; - - if Day_Hack then - Date := Date + 10_000_000 * 86_400; - end if; - - Date := Date + Time (10_000_000.0 * Subsecs); - return Date; - end Time_Of; - - ---------- - -- Year -- - ---------- - - function Year (Date : Time) return Year_Number is - DY : Year_Number; - DM : Month_Number; - DD : Day_Number; - DS : Day_Duration; - - begin - Split (Date, DY, DM, DD, DS); - return DY; - end Year; - -end Ada.Calendar; diff --git a/gcc/ada/4vcalend.ads b/gcc/ada/4vcalend.ads deleted file mode 100644 index 6704346cf70..00000000000 --- a/gcc/ada/4vcalend.ads +++ /dev/null @@ -1,121 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUNTIME COMPONENTS -- --- -- --- A D A . C A L E N D A R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2002 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. -- --- -- ------------------------------------------------------------------------------- - --- This is the Alpha/VMS version. - -with System.OS_Primitives; -package Ada.Calendar is - - package OSP renames System.OS_Primitives; - - type Time is private; - - -- Declarations representing limits of allowed local time values. Note that - -- these do NOT constrain the possible stored values of time which may well - -- permit a larger range of times (this is explicitly allowed in Ada 95). - - subtype Year_Number is Integer range 1901 .. 2099; - subtype Month_Number is Integer range 1 .. 12; - subtype Day_Number is Integer range 1 .. 31; - - subtype Day_Duration is Duration range 0.0 .. 86_400.0; - - function Clock return Time; - - function Year (Date : Time) return Year_Number; - function Month (Date : Time) return Month_Number; - function Day (Date : Time) return Day_Number; - function Seconds (Date : Time) return Day_Duration; - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Seconds : out Day_Duration); - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Seconds : Day_Duration := 0.0) - return Time; - - function "+" (Left : Time; Right : Duration) return Time; - function "+" (Left : Duration; Right : Time) return Time; - function "-" (Left : Time; Right : Duration) return Time; - function "-" (Left : Time; Right : Time) return Duration; - - function "<" (Left, Right : Time) return Boolean; - function "<=" (Left, Right : Time) return Boolean; - function ">" (Left, Right : Time) return Boolean; - function ">=" (Left, Right : Time) return Boolean; - - Time_Error : exception; - -private - - pragma Inline (Clock); - - pragma Inline (Year); - pragma Inline (Month); - pragma Inline (Day); - - pragma Inline ("+"); - pragma Inline ("-"); - - pragma Inline ("<"); - pragma Inline ("<="); - pragma Inline (">"); - pragma Inline (">="); - - -- Time is represented as the number of 100-nanosecond (ns) units offset - -- from the system base date and time, which is 00:00 o'clock, - -- November 17, 1858 (the Smithsonian base date and time for the - -- astronomic calendar). - - -- The time value stored is typically a GMT value, as provided in standard - -- Unix environments. If this is the case then Split and Time_Of perform - -- required conversions to and from local times. - - type Time is new OSP.OS_Time; - - -- Notwithstanding this definition, Time is not quite the same as OS_Time. - -- Relative Time is positive, whereas relative OS_Time is negative, - -- but this declaration makes for easier conversion. - -end Ada.Calendar; diff --git a/gcc/ada/4vintnam.ads b/gcc/ada/4vintnam.ads deleted file mode 100644 index 7eec58fbeb7..00000000000 --- a/gcc/ada/4vintnam.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-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 OpenVMS/Alpha version of this package. --- --- This target-dependent package spec contains names of interrupts --- supported by the local system. - -with System.OS_Interface; -package Ada.Interrupts.Names is - - package OS renames System.OS_Interface; - - Interrupt_ID_0 : constant Interrupt_ID := OS.Interrupt_ID_0; - Interrupt_ID_1 : constant Interrupt_ID := OS.Interrupt_ID_1; - Interrupt_ID_2 : constant Interrupt_ID := OS.Interrupt_ID_2; - Interrupt_ID_3 : constant Interrupt_ID := OS.Interrupt_ID_3; - Interrupt_ID_4 : constant Interrupt_ID := OS.Interrupt_ID_4; - Interrupt_ID_5 : constant Interrupt_ID := OS.Interrupt_ID_5; - Interrupt_ID_6 : constant Interrupt_ID := OS.Interrupt_ID_6; - Interrupt_ID_7 : constant Interrupt_ID := OS.Interrupt_ID_7; - Interrupt_ID_8 : constant Interrupt_ID := OS.Interrupt_ID_8; - Interrupt_ID_9 : constant Interrupt_ID := OS.Interrupt_ID_9; - Interrupt_ID_10 : constant Interrupt_ID := OS.Interrupt_ID_10; - Interrupt_ID_11 : constant Interrupt_ID := OS.Interrupt_ID_11; - Interrupt_ID_12 : constant Interrupt_ID := OS.Interrupt_ID_12; - Interrupt_ID_13 : constant Interrupt_ID := OS.Interrupt_ID_13; - Interrupt_ID_14 : constant Interrupt_ID := OS.Interrupt_ID_14; - Interrupt_ID_15 : constant Interrupt_ID := OS.Interrupt_ID_15; - Interrupt_ID_16 : constant Interrupt_ID := OS.Interrupt_ID_16; - Interrupt_ID_17 : constant Interrupt_ID := OS.Interrupt_ID_17; - Interrupt_ID_18 : constant Interrupt_ID := OS.Interrupt_ID_18; - Interrupt_ID_19 : constant Interrupt_ID := OS.Interrupt_ID_19; - Interrupt_ID_20 : constant Interrupt_ID := OS.Interrupt_ID_20; - Interrupt_ID_21 : constant Interrupt_ID := OS.Interrupt_ID_21; - Interrupt_ID_22 : constant Interrupt_ID := OS.Interrupt_ID_22; - Interrupt_ID_23 : constant Interrupt_ID := OS.Interrupt_ID_23; - Interrupt_ID_24 : constant Interrupt_ID := OS.Interrupt_ID_24; - Interrupt_ID_25 : constant Interrupt_ID := OS.Interrupt_ID_25; - Interrupt_ID_26 : constant Interrupt_ID := OS.Interrupt_ID_26; - Interrupt_ID_27 : constant Interrupt_ID := OS.Interrupt_ID_27; - Interrupt_ID_28 : constant Interrupt_ID := OS.Interrupt_ID_28; - Interrupt_ID_29 : constant Interrupt_ID := OS.Interrupt_ID_29; - Interrupt_ID_30 : constant Interrupt_ID := OS.Interrupt_ID_30; - Interrupt_ID_31 : constant Interrupt_ID := OS.Interrupt_ID_31; - -end Ada.Interrupts.Names; diff --git a/gcc/ada/4wcalend.adb b/gcc/ada/4wcalend.adb deleted file mode 100644 index 25f8cc4720b..00000000000 --- a/gcc/ada/4wcalend.adb +++ /dev/null @@ -1,394 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C A L E N D A R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2002 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 Windows NT/95 version. - -with System.OS_Primitives; --- used for Clock - -with System.OS_Interface; - -package body Ada.Calendar is - - use System.OS_Interface; - - ------------------------------ - -- Use of Pragma Unsuppress -- - ------------------------------ - - -- This implementation of Calendar takes advantage of the permission in - -- Ada 95 of using arithmetic overflow checks to check for out of bounds - -- time values. This means that we must catch the constraint error that - -- results from arithmetic overflow, so we use pragma Unsuppress to make - -- sure that overflow is enabled, using software overflow checking if - -- necessary. That way, compiling Calendar with options to suppress this - -- checking will not affect its correctness. - - ------------------------ - -- Local Declarations -- - ------------------------ - - Ada_Year_Min : constant := 1901; - Ada_Year_Max : constant := 2099; - - -- Win32 time constants - - epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch - system_time_ns : constant := 100; -- 100 ns per tick - Sec_Unit : constant := 10#1#E9; - - --------- - -- "+" -- - --------- - - function "+" (Left : Time; Right : Duration) return Time is - pragma Unsuppress (Overflow_Check); - begin - return (Left + Time (Right)); - - exception - when Constraint_Error => - raise Time_Error; - end "+"; - - function "+" (Left : Duration; Right : Time) return Time is - pragma Unsuppress (Overflow_Check); - begin - return (Time (Left) + Right); - - exception - when Constraint_Error => - raise Time_Error; - end "+"; - - --------- - -- "-" -- - --------- - - function "-" (Left : Time; Right : Duration) return Time is - pragma Unsuppress (Overflow_Check); - begin - return Left - Time (Right); - - exception - when Constraint_Error => - raise Time_Error; - end "-"; - - function "-" (Left : Time; Right : Time) return Duration is - pragma Unsuppress (Overflow_Check); - begin - return Duration (Left) - Duration (Right); - - exception - when Constraint_Error => - raise Time_Error; - end "-"; - - --------- - -- "<" -- - --------- - - function "<" (Left, Right : Time) return Boolean is - begin - return Duration (Left) < Duration (Right); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" (Left, Right : Time) return Boolean is - begin - return Duration (Left) <= Duration (Right); - end "<="; - - --------- - -- ">" -- - --------- - - function ">" (Left, Right : Time) return Boolean is - begin - return Duration (Left) > Duration (Right); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" (Left, Right : Time) return Boolean is - begin - return Duration (Left) >= Duration (Right); - end ">="; - - ----------- - -- Clock -- - ----------- - - -- The Ada.Calendar.Clock function gets the time from the soft links - -- interface which will call the appropriate function depending wether - -- tasking is involved or not. - - function Clock return Time is - begin - return Time (System.OS_Primitives.Clock); - end Clock; - - --------- - -- Day -- - --------- - - function Day (Date : Time) return Day_Number is - DY : Year_Number; - DM : Month_Number; - DD : Day_Number; - DS : Day_Duration; - - begin - Split (Date, DY, DM, DD, DS); - return DD; - end Day; - - ----------- - -- Month -- - ----------- - - function Month (Date : Time) return Month_Number is - DY : Year_Number; - DM : Month_Number; - DD : Day_Number; - DS : Day_Duration; - - begin - Split (Date, DY, DM, DD, DS); - return DM; - end Month; - - ------------- - -- Seconds -- - ------------- - - function Seconds (Date : Time) return Day_Duration is - DY : Year_Number; - DM : Month_Number; - DD : Day_Number; - DS : Day_Duration; - - begin - Split (Date, DY, DM, DD, DS); - return DS; - end Seconds; - - ----------- - -- Split -- - ----------- - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Seconds : out Day_Duration) - is - - Date_Int : aliased Long_Long_Integer; - Date_Loc : aliased Long_Long_Integer; - Timbuf : aliased SYSTEMTIME; - Int_Date : Long_Long_Integer; - Sub_Seconds : Duration; - - begin - -- We take the sub-seconds (decimal part) of Date and this is added - -- to compute the Seconds. This way we keep the precision of the - -- high-precision clock that was lost with the Win32 API calls - -- below. - - if Date < 0.0 then - - -- this is a Date before Epoch (January 1st, 1970) - - Sub_Seconds := Duration (Date) - - Duration (Long_Long_Integer (Date + Duration'(0.5))); - - Int_Date := Long_Long_Integer (Date - Sub_Seconds); - - -- For Date = -86400.1 we are 2 days before Epoch at 0.1 seconds - -- from day 1 before Epoch. It means that it is 23h 59m 59.9s. - -- here we adjust for that. - - if Sub_Seconds < 0.0 then - Int_Date := Int_Date - 1; - Sub_Seconds := 1.0 + Sub_Seconds; - end if; - - else - - -- this is a Date after Epoch (January 1st, 1970) - - Sub_Seconds := Duration (Date) - - Duration (Long_Long_Integer (Date - Duration'(0.5))); - - Int_Date := Long_Long_Integer (Date - Sub_Seconds); - - end if; - - -- Date_Int is the number of seconds from Epoch. - - Date_Int := Long_Long_Integer - (Int_Date * Sec_Unit / system_time_ns) + epoch_1970; - - if not FileTimeToLocalFileTime (Date_Int'Access, Date_Loc'Access) then - raise Time_Error; - end if; - - if not FileTimeToSystemTime (Date_Loc'Access, Timbuf'Access) then - raise Time_Error; - end if; - - if Timbuf.wYear not in Ada_Year_Min .. Ada_Year_Max then - raise Time_Error; - end if; - - Seconds := - Duration (Timbuf.wHour) * 3_600.0 + - Duration (Timbuf.wMinute) * 60.0 + - Duration (Timbuf.wSecond) + - Sub_Seconds; - - Day := Integer (Timbuf.wDay); - Month := Integer (Timbuf.wMonth); - Year := Integer (Timbuf.wYear); - end Split; - - ------------- - -- Time_Of -- - ------------- - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Seconds : Day_Duration := 0.0) - return Time - is - - Timbuf : aliased SYSTEMTIME; - Now : aliased Long_Long_Integer; - Loc : aliased Long_Long_Integer; - Int_Secs : Integer; - Secs : Integer; - Add_One_Day : Boolean := False; - Date : Time; - - begin - -- The following checks are redundant with respect to the constraint - -- error checks that should normally be made on parameters, but we - -- decide to raise Constraint_Error in any case if bad values come - -- in (as a result of checks being off in the caller, or for other - -- erroneous or bounded error cases). - - if not Year 'Valid - or else not Month 'Valid - or else not Day 'Valid - or else not Seconds'Valid - then - raise Constraint_Error; - end if; - - if Seconds = 0.0 then - Int_Secs := 0; - else - Int_Secs := Integer (Seconds - 0.5); - end if; - - -- Timbuf.wMillisec is to keep the msec. We can't use that because the - -- high-resolution clock has a precision of 1 Microsecond. - -- Anyway the sub-seconds part is not needed to compute the number - -- of seconds in UTC. - - if Int_Secs = 86_400 then - Secs := 0; - Add_One_Day := True; - else - Secs := Int_Secs; - end if; - - Timbuf.wMilliseconds := 0; - Timbuf.wSecond := WORD (Secs mod 60); - Timbuf.wMinute := WORD ((Secs / 60) mod 60); - Timbuf.wHour := WORD (Secs / 3600); - Timbuf.wDay := WORD (Day); - Timbuf.wMonth := WORD (Month); - Timbuf.wYear := WORD (Year); - - if not SystemTimeToFileTime (Timbuf'Access, Loc'Access) then - raise Time_Error; - end if; - - if not LocalFileTimeToFileTime (Loc'Access, Now'Access) then - raise Time_Error; - end if; - - -- Here we have the UTC now translate UTC to Epoch time (UNIX style - -- time based on 1 january 1970) and add there the sub-seconds part. - - declare - Sub_Sec : constant Duration := Seconds - Duration (Int_Secs); - begin - Date := Time ((Now - epoch_1970) * system_time_ns / Sec_Unit) + - Sub_Sec; - end; - - if Add_One_Day then - Date := Date + Duration (86400.0); - end if; - - return Date; - end Time_Of; - - ---------- - -- Year -- - ---------- - - function Year (Date : Time) return Year_Number is - DY : Year_Number; - DM : Month_Number; - DD : Day_Number; - DS : Day_Duration; - - begin - Split (Date, DY, DM, DD, DS); - return DY; - end Year; - -end Ada.Calendar; diff --git a/gcc/ada/4wexcpol.adb b/gcc/ada/4wexcpol.adb deleted file mode 100644 index afa93c1d3f2..00000000000 --- a/gcc/ada/4wexcpol.adb +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . E X C E P T I O N S . P O L L -- --- (version supporting asynchronous abort test) -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2000, Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for targets that do not support per-thread asynchronous --- signals. On such targets, we require compilation with the -gnatP switch --- that activates periodic polling. Then in the body of the polling routine --- we test for asynchronous abort. - --- NT, OS/2, HPUX/DCE and SCO currently use this file - -with System.Soft_Links; --- used for Check_Abort_Status - -separate (Ada.Exceptions) - ----------- --- Poll -- ----------- - -procedure Poll is -begin - -- Test for asynchronous abort on each poll - - if System.Soft_Links.Check_Abort_Status.all /= 0 then - raise Standard'Abort_Signal; - end if; -end Poll; diff --git a/gcc/ada/4wintnam.ads b/gcc/ada/4wintnam.ads deleted file mode 100644 index 4d02e17bf60..00000000000 --- a/gcc/ada/4wintnam.ads +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1997-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 NT (native) version of this package. - --- This target-dependent package spec contains names of interrupts --- supported by the local system. - -with System.OS_Interface; --- used for names of interrupts - -package Ada.Interrupts.Names is - - -- Beware that the mapping of names to signals may be - -- many-to-one. There may be aliases. Also, for all - -- signal names that are not supported on the current system - -- the value of the corresponding constant will be zero. - - SIGINT : constant Interrupt_ID := - System.OS_Interface.SIGINT; -- interrupt (rubout) - - SIGILL : constant Interrupt_ID := - System.OS_Interface.SIGILL; -- illegal instruction (not reset) - - SIGABRT : constant Interrupt_ID := -- used by abort, - System.OS_Interface.SIGABRT; -- replace SIGIOT in the future - - SIGFPE : constant Interrupt_ID := - System.OS_Interface.SIGFPE; -- floating point exception - - SIGSEGV : constant Interrupt_ID := - System.OS_Interface.SIGSEGV; -- segmentation violation - - SIGTERM : constant Interrupt_ID := - System.OS_Interface.SIGTERM; -- software termination signal from kill - -end Ada.Interrupts.Names; diff --git a/gcc/ada/4zintnam.ads b/gcc/ada/4zintnam.ads deleted file mode 100644 index 757b15376fb..00000000000 --- a/gcc/ada/4zintnam.ads +++ /dev/null @@ -1,44 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VxWorks version of this package. - -with System.OS_Interface; - -package Ada.Interrupts.Names is - - subtype Hardware_Interrupts is Interrupt_ID - range Interrupt_ID'First .. System.OS_Interface.Max_HW_Interrupt; - -- Range of values that can be used for hardware interrupts. - -end Ada.Interrupts.Names; diff --git a/gcc/ada/4znumaux.ads b/gcc/ada/4znumaux.ads deleted file mode 100644 index 3a995a12bd1..00000000000 --- a/gcc/ada/4znumaux.ads +++ /dev/null @@ -1,110 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUNTIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- S p e c -- --- (C Library Version, VxWorks) -- --- -- --- Copyright (C) 1992-2003 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. The C library version interfaces with the routines --- in the C mathematical library, and is thus quite portable, although it may --- not necessarily meet the requirements for accuracy in the numerics annex. --- One advantage of using this package is that it will interface directly to --- hardware instructions, such as the those provided on the Intel x86. - --- Note: there are two versions of this package. One using the normal IEEE --- 64-bit double format (which is this version), and one using 80-bit x86 --- long double (see file 4onumaux.ads). - -package Ada.Numerics.Aux is -pragma Pure (Aux); - - -- This version omits the pragma linker_options ("-lm") since there is - -- no libm.a library for VxWorks. - - type Double is digits 15; - -- Type Double is the type used to call the C routines - - -- We import these functions directly from C. Note that we label them - -- all as pure functions, because indeed all of them are in fact pure! - - function Sin (X : Double) return Double; - pragma Import (C, Sin, "sin"); - pragma Pure_Function (Sin); - - function Cos (X : Double) return Double; - pragma Import (C, Cos, "cos"); - pragma Pure_Function (Cos); - - function Tan (X : Double) return Double; - pragma Import (C, Tan, "tan"); - pragma Pure_Function (Tan); - - function Exp (X : Double) return Double; - pragma Import (C, Exp, "exp"); - pragma Pure_Function (Exp); - - function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "sqrt"); - pragma Pure_Function (Sqrt); - - function Log (X : Double) return Double; - pragma Import (C, Log, "log"); - pragma Pure_Function (Log); - - function Acos (X : Double) return Double; - pragma Import (C, Acos, "acos"); - pragma Pure_Function (Acos); - - function Asin (X : Double) return Double; - pragma Import (C, Asin, "asin"); - pragma Pure_Function (Asin); - - function Atan (X : Double) return Double; - pragma Import (C, Atan, "atan"); - pragma Pure_Function (Atan); - - function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "sinh"); - pragma Pure_Function (Sinh); - - function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "cosh"); - pragma Pure_Function (Cosh); - - function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "tanh"); - pragma Pure_Function (Tanh); - - function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "pow"); - pragma Pure_Function (Pow); - -end Ada.Numerics.Aux; diff --git a/gcc/ada/4zsytaco.adb b/gcc/ada/4zsytaco.adb deleted file mode 100644 index fcb320a97ec..00000000000 --- a/gcc/ada/4zsytaco.adb +++ /dev/null @@ -1,147 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUNTIME COMPONENTS -- --- -- --- A D A . S Y N C H R O N O U S _ T A S K _ C O N T R O L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C; - -package body Ada.Synchronous_Task_Control is - use System.OS_Interface; - use type Interfaces.C.int; - - ------------------- - -- Current_State -- - ------------------- - - function Current_State (S : Suspension_Object) return Boolean is - St : STATUS; - Result : Boolean := False; - - begin - -- Determine state by attempting to take the semaphore with - -- a 0 timeout value. Status = OK indicates the semaphore was - -- full, so reset it to the full state. - - St := semTake (S.Sema, NO_WAIT); - - -- If we took the semaphore, reset semaphore state to FULL - - if St = OK then - Result := True; - St := semGive (S.Sema); - end if; - - return Result; - end Current_State; - - --------------- - -- Set_False -- - --------------- - - procedure Set_False (S : in out Suspension_Object) is - St : STATUS; - - begin - -- Need to get the semaphore into the "empty" state. - -- On return, this task will have made the semaphore - -- empty (St = OK) or have left it empty. - - St := semTake (S.Sema, NO_WAIT); - pragma Assert (St = OK); - end Set_False; - - -------------- - -- Set_True -- - -------------- - - procedure Set_True (S : in out Suspension_Object) is - St : STATUS; - pragma Unreferenced (St); - begin - St := semGive (S.Sema); - end Set_True; - - ------------------------ - -- Suspend_Until_True -- - ------------------------ - - procedure Suspend_Until_True (S : in out Suspension_Object) is - St : STATUS; - - begin - -- Determine whether another task is pending on the suspension - -- object. Should never be called from an ISR. Therefore semTake can - -- be called on the mutex - - St := semTake (S.Mutex, NO_WAIT); - - if St = OK then - - -- Wait for suspension object - - St := semTake (S.Sema, WAIT_FOREVER); - St := semGive (S.Mutex); - - else - -- Another task is pending on the suspension object - - raise Program_Error; - end if; - end Suspend_Until_True; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (S : in out Suspension_Object) is - begin - S.Sema := semBCreate (SEM_Q_FIFO, SEM_EMPTY); - - -- Use simpler binary semaphore instead of VxWorks - -- mutual exclusion semaphore, because we don't need - -- the fancier semantics and their overhead. - - S.Mutex := semBCreate (SEM_Q_FIFO, SEM_FULL); - end Initialize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Suspension_Object) is - St : STATUS; - pragma Unreferenced (St); - begin - St := semDelete (S.Sema); - St := semDelete (S.Mutex); - end Finalize; - -end Ada.Synchronous_Task_Control; diff --git a/gcc/ada/4zsytaco.ads b/gcc/ada/4zsytaco.ads deleted file mode 100644 index c3c54bee43c..00000000000 --- a/gcc/ada/4zsytaco.ads +++ /dev/null @@ -1,68 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S Y N C H R O N O U S _ T A S K _ C O N T R O L -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.OS_Interface; -with Ada.Finalization; -package Ada.Synchronous_Task_Control is - - type Suspension_Object is limited private; - - procedure Set_True (S : in out Suspension_Object); - - procedure Set_False (S : in out Suspension_Object); - - function Current_State (S : Suspension_Object) return Boolean; - - procedure Suspend_Until_True (S : in out Suspension_Object); - -private - - procedure Initialize (S : in out Suspension_Object); - - procedure Finalize (S : in out Suspension_Object); - - -- Implement with a VxWorks binary semaphore. A second semaphore - -- is used to avoid a race condition related to the implementation of - -- the STC requirement to raise Program_Error when Suspend_Until_True is - -- called with a task already pending on the suspension object - - type Suspension_Object is new Ada.Finalization.Controlled with record - Sema : System.OS_Interface.SEM_ID; - Mutex : System.OS_Interface.SEM_ID; - end record; - -end Ada.Synchronous_Task_Control; diff --git a/gcc/ada/51osinte.adb b/gcc/ada/51osinte.adb deleted file mode 100644 index 9916e8846f4..00000000000 --- a/gcc/ada/51osinte.adb +++ /dev/null @@ -1,182 +0,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) 1999-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 UnixWare (Native) version of this package - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with Interfaces.C; - -package body System.OS_Interface is - - use Interfaces.C; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (TS : timespec) return Duration is - begin - return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; - end To_Duration; - - function To_Duration (TV : struct_timeval) return Duration is - begin - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end To_Duration; - - ----------------- - -- To_Timespec -- - ----------------- - - function To_Timespec (D : Duration) return timespec is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return timespec'(tv_sec => S, - tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); - end To_Timespec; - - ---------------- - -- To_Timeval -- - ---------------- - - function To_Timeval (D : Duration) return struct_timeval is - S : long; - F : Duration; - - begin - S := long (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return - struct_timeval' - (tv_sec => S, - tv_usec => long (Long_Long_Integer (F * 10#1#E6))); - end To_Timeval; - - ------------------- - -- clock_gettime -- - ------------------- - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) - return int - is - pragma Warnings (Off, clock_id); - - Result : int; - tv : aliased struct_timeval; - - function gettimeofday - (tv : access struct_timeval; - tz : System.Address := System.Null_Address) - return int; - pragma Import (C, gettimeofday, "gettimeofday"); - - begin - Result := gettimeofday (tv'Unchecked_Access); - tp.all := To_Timespec (To_Duration (tv)); - return Result; - end clock_gettime; - - --------------------------- - -- POSIX.1c Section 3 -- - --------------------------- - - function sigwait (set : access sigset_t; sig : access Signal) return int is - Result : int; - - function sigwait (set : access sigset_t) return int; - pragma Import (C, sigwait, "sigwait"); - - begin - Result := sigwait (set); - - if Result < 0 then - sig.all := 0; - return errno; - end if; - - sig.all := Signal (Result); - return 0; - end sigwait; - - function pthread_kill (thread : pthread_t; sig : Signal) return int is - function pthread_kill_base - (thread : access pthread_t; sig : access Signal) return int; - pragma Import (C, pthread_kill_base, "pthread_kill"); - - thr : aliased pthread_t := thread; - signo : aliased Signal := sig; - - begin - return pthread_kill_base (thr'Unchecked_Access, signo'Unchecked_Access); - end pthread_kill; - - function Get_Stack_Base (thread : pthread_t) return Address is - pragma Warnings (Off, thread); - - begin - return Null_Address; - end Get_Stack_Base; - - procedure pthread_init is - begin - null; - end pthread_init; - -end System.OS_Interface; diff --git a/gcc/ada/51osinte.ads b/gcc/ada/51osinte.ads deleted file mode 100644 index efc55eb54d5..00000000000 --- a/gcc/ada/51osinte.ads +++ /dev/null @@ -1,600 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 a UnixWare (Native THREADS) version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-lthread"); - - subtype int is Interfaces.C.int; - subtype char is Interfaces.C.char; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 11; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIMEDOUT : constant := 145; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 34; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGUSR1 : constant := 16; -- user defined signal 1 - SIGUSR2 : constant := 17; -- user defined signal 2 - SIGCLD : constant := 18; -- alias for SIGCHLD - SIGCHLD : constant := 18; -- child status change - SIGPWR : constant := 19; -- power-fail restart - SIGWINCH : constant := 20; -- window size change - SIGURG : constant := 21; -- urgent condition on IO channel - SIGPOLL : constant := 22; -- pollable event occurred - SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias) - SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 24; -- user stop requested from tty - SIGCONT : constant := 25; -- stopped process has been continued - SIGTTIN : constant := 26; -- background tty read attempted - SIGTTOU : constant := 27; -- background tty write attempted - SIGVTALRM : constant := 28; -- virtual timer expired - SIGPROF : constant := 29; -- profiling timer expired - SIGXCPU : constant := 30; -- CPU time limit exceeded - SIGXFSZ : constant := 31; -- filesize limit exceeded - SIGWAITING : constant := 32; -- all LWPs blocked interruptibly notific. - SIGLWP : constant := 33; -- signal reserved for thread lib impl. - SIGAIO : constant := 34; -- Asynchronous I/O signal - - SIGADAABORT : constant := SIGABRT; - -- Change this if you want to use another signal for task abort. - -- SIGTERM might be a good one. - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := - (SIGTRAP, SIGLWP, SIGWAITING, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); - Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type struct_sigaction is record - sa_flags : int; - sa_handler : System.Address; - sa_mask : sigset_t; - sa_resv1 : int; - sa_resv2 : int; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - SIG_BLOCK : constant := 1; - SIG_UNBLOCK : constant := 2; - SIG_SETMASK : constant := 3; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - -- SIG_ERR : constant := -1; - -- not used - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - Time_Slice_Supported : constant Boolean := False; - -- Indicates wether time slicing is supported - - type timespec is private; - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; - -- UnixWare threads don't have clock_gettime - -- We instead use gettimeofday() - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timezone is record - tz_minuteswest : int; - tz_dsttime : int; - end record; - pragma Convention (C, struct_timezone); - type struct_timezone_ptr is access all struct_timezone; - - type struct_timeval is private; - -- This is needed on systems that do not have clock_gettime() - -- but do have gettimeofday(). - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 2; - SCHED_RR : constant := 3; - SCHED_OTHER : constant := 1; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - --------- - -- LWP -- - --------- - - function lwp_self return System.Address; - pragma Import (C, lwp_self, "_lwp_self"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 0; - - ----------- - -- Stack -- - ----------- - - Stack_Base_Available : constant Boolean := False; - -- Indicates wether the stack base is available on this target. - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- returns the stack base of the specified thread. - -- Only call this function when Stack_Base_Available is True. - - function Get_Page_Size return size_t; - function Get_Page_Size return Address; - pragma Import (C, Get_Page_Size, "getpagesize"); - -- returns the size of a page, or 0 if this is not relevant on this - -- target - - PROT_NONE : constant := 0; - PROT_READ : constant := 1; - PROT_WRITE : constant := 2; - PROT_EXEC : constant := 4; - PROT_USER : constant := 8; - PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC + PROT_USER; - - PROT_ON : constant := PROT_READ; - PROT_OFF : constant := PROT_ALL; - - function mprotect (addr : Address; len : size_t; prot : int) return int; - pragma Import (C, mprotect); - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait (set : access sigset_t; sig : access Signal) return int; - pragma Inline (sigwait); - -- UnixWare provides a non standard sigwait - - function pthread_kill (thread : pthread_t; sig : Signal) return int; - pragma Inline (pthread_kill); - -- UnixWare provides a non standard pthread_kill - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask, "pthread_sigmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "pthread_cond_init"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); - - Relative_Timed_Wait : constant Boolean := False; - -- pthread_cond_timedwait requires an absolute delay time - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - PTHREAD_PRIO_NONE : constant := 1; - PTHREAD_PRIO_INHERIT : constant := 2; - PTHREAD_PRIO_PROTECT : constant := 3; - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol); - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int; - pragma Import (C, pthread_mutexattr_setprioceiling); - - type sched_union is record - sched_fifo : int; - sched_fcfs : int; - sched_other : int; - sched_ts : int; - policy_params : long; - end record; - - type struct_sched_param is record - sched_priority : int; - sched_other_stuff : sched_union; - end record; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import (C, pthread_attr_setinheritsched); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; - policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy); - - function sched_yield return int; - pragma Import (C, sched_yield, "sched_yield"); - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "pthread_attr_init"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Import (C, pthread_attr_setdetachstate); - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "pthread_create"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "pthread_setspecific"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Import (C, pthread_getspecific, "pthread_getspecific"); - - type destructor_pointer is access procedure (arg : System.Address); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "pthread_key_create"); - - procedure pthread_init; - -- This is a dummy procedure to share some GNULLI files - -private - - type sigbit_array is array (1 .. 4) of unsigned; - type sigset_t is record - sa_sigbits : sigbit_array; - end record; - pragma Convention (C_Pass_By_Copy, sigset_t); - - type pid_t is new unsigned; - - type time_t is new long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 0; - - type struct_timeval is record - tv_sec : long; - tv_usec : long; - end record; - pragma Convention (C, struct_timeval); - - type pthread_attr_t is record - pt_attr_status : int; - pt_attr_stacksize : size_t; - pt_attr_stackaddr : System.Address; - pt_attr_detachstate : int; - pt_attr_contentionscope : int; - pt_attr_inheritsched : int; - pt_attr_schedpolicy : int; - pt_attr_sched_param : struct_sched_param; - pt_attr_tlflags : int; - end record; - pragma Convention (C, pthread_attr_t); - - type pthread_condattr_t is record - pt_condattr_status : int; - pt_condattr_pshared : int; - end record; - pragma Convention (C, pthread_condattr_t); - - type pthread_mutexattr_t is record - pt_mutexattr_status : int; - pt_mutexattr_pshared : int; - pt_mutexattr_type : int; - end record; - pragma Convention (C, pthread_mutexattr_t); - - type thread_t is new long; - type pthread_t is new thread_t; - - type thrq_elt_t; - type thrq_elt_t_ptr is access all thrq_elt_t; - - type thrq_elt_t is record - thrq_next : thrq_elt_t_ptr; - thrq_prev : thrq_elt_t_ptr; - end record; - pragma Convention (C, thrq_elt_t); - - type lwp_mutex_t is record - wanted : char; - lock : unsigned_char; - end record; - pragma Convention (C, lwp_mutex_t); - pragma Volatile (lwp_mutex_t); - - type mutex_t is record - m_lmutex : lwp_mutex_t; - m_sync_lock : lwp_mutex_t; - m_type : int; - m_sleepq : thrq_elt_t; - filler1 : int; - filler2 : int; - end record; - pragma Convention (C, mutex_t); - pragma Volatile (mutex_t); - - type pthread_mutex_t is record - pt_mutex_mutex : mutex_t; - pt_mutex_pid : pid_t; - pt_mutex_owner : thread_t; - pt_mutex_depth : int; - pt_mutex_attr : pthread_mutexattr_t; - end record; - pragma Convention (C, pthread_mutex_t); - - type lwp_cond_t is record - wanted : char; - end record; - pragma Convention (C, lwp_cond_t); - pragma Volatile (lwp_cond_t); - - type cond_t is record - c_lcond : lwp_cond_t; - c_sync_lock : lwp_mutex_t; - c_type : int; - c_syncq : thrq_elt_t; - end record; - pragma Convention (C, cond_t); - pragma Volatile (cond_t); - - type pthread_cond_t is record - pt_cond_cond : cond_t; - pt_cond_attr : pthread_condattr_t; - end record; - pragma Convention (C, pthread_cond_t); - - type pthread_key_t is new unsigned; - -end System.OS_Interface; diff --git a/gcc/ada/51system.ads b/gcc/ada/51system.ads deleted file mode 100644 index 01404ee32aa..00000000000 --- a/gcc/ada/51system.ads +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (SCO UnixWare Version) -- --- -- --- 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 := 0.01; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := False; - 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 := True; - -end System; diff --git a/gcc/ada/52osinte.adb b/gcc/ada/52osinte.adb deleted file mode 100644 index 156601442b3..00000000000 --- a/gcc/ada/52osinte.adb +++ /dev/null @@ -1,597 +0,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) 1999-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 a LynxOS (Native) version of this package - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with Interfaces.C; - -package body System.OS_Interface is - - use Interfaces.C; - - ------------------- - -- clock_gettime -- - ------------------- - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) - return int - is - function clock_gettime_base - (clock_id : clockid_t; - tp : access timespec) - return int; - pragma Import (C, clock_gettime_base, "clock_gettime"); - - begin - if clock_gettime_base (clock_id, tp) /= 0 then - return errno; - end if; - - return 0; - end clock_gettime; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (TS : timespec) return Duration is - begin - return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; - end To_Duration; - - function To_Duration (TV : struct_timeval) return Duration is - begin - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end To_Duration; - - ----------------- - -- To_Timespec -- - ----------------- - - function To_Timespec (D : Duration) return timespec is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return timespec'(tv_sec => S, - tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); - end To_Timespec; - - ---------------- - -- To_Timeval -- - ---------------- - - function To_Timeval (D : Duration) return struct_timeval is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return struct_timeval'(tv_sec => S, - tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); - end To_Timeval; - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) - return int - is - function sigwait_base - (set : access sigset_t; - value : System.Address) - return Signal; - pragma Import (C, sigwait_base, "sigwait"); - - begin - sig.all := sigwait_base (set, Null_Address); - - if sig.all = -1 then - return errno; - end if; - - return 0; - end sigwait; - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - -- For all the following functions, LynxOS threads has the POSIX Draft 4 - -- begavior; it sets errno but the standard Posix requires it to be - -- returned. - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) - return int - is - function pthread_mutexattr_create - (attr : access pthread_mutexattr_t) - return int; - pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create"); - - begin - if pthread_mutexattr_create (attr) /= 0 then - return errno; - end if; - - return 0; - end pthread_mutexattr_init; - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) - return int - is - function pthread_mutexattr_delete - (attr : access pthread_mutexattr_t) - return int; - pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete"); - - begin - if pthread_mutexattr_delete (attr) /= 0 then - return errno; - end if; - - return 0; - end pthread_mutexattr_destroy; - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) - return int - is - function pthread_mutex_init_base - (mutex : access pthread_mutex_t; - attr : pthread_mutexattr_t) - return int; - pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init"); - - begin - if pthread_mutex_init_base (mutex, attr.all) /= 0 then - return errno; - end if; - - return 0; - end pthread_mutex_init; - - function pthread_mutex_destroy - (mutex : access pthread_mutex_t) - return int - is - function pthread_mutex_destroy_base - (mutex : access pthread_mutex_t) - return int; - pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy"); - - begin - if pthread_mutex_destroy_base (mutex) /= 0 then - return errno; - end if; - - return 0; - end pthread_mutex_destroy; - - 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"); - - begin - if pthread_mutex_lock_base (mutex) /= 0 then - return errno; - end if; - - return 0; - end pthread_mutex_lock; - - 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"); - - begin - if pthread_mutex_unlock_base (mutex) /= 0 then - return errno; - end if; - - return 0; - end pthread_mutex_unlock; - - function pthread_condattr_init - (attr : access pthread_condattr_t) - return int - is - function pthread_condattr_create - (attr : access pthread_condattr_t) - return int; - pragma Import (C, pthread_condattr_create, "pthread_condattr_create"); - - begin - if pthread_condattr_create (attr) /= 0 then - return errno; - end if; - - return 0; - end pthread_condattr_init; - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) - return int - is - function pthread_condattr_delete - (attr : access pthread_condattr_t) - return int; - pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete"); - - begin - if pthread_condattr_delete (attr) /= 0 then - return errno; - end if; - - return 0; - end pthread_condattr_destroy; - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) - return int - is - function pthread_cond_init_base - (cond : access pthread_cond_t; - attr : pthread_condattr_t) - return int; - pragma Import (C, pthread_cond_init_base, "pthread_cond_init"); - - begin - if pthread_cond_init_base (cond, attr.all) /= 0 then - return errno; - end if; - - return 0; - end pthread_cond_init; - - function pthread_cond_destroy - (cond : access pthread_cond_t) - return int - is - function pthread_cond_destroy_base - (cond : access pthread_cond_t) - return int; - pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy"); - - begin - if pthread_cond_destroy_base (cond) /= 0 then - return errno; - end if; - - return 0; - end pthread_cond_destroy; - - function pthread_cond_signal - (cond : access pthread_cond_t) - return int - is - function pthread_cond_signal_base - (cond : access pthread_cond_t) - return int; - pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal"); - - begin - if pthread_cond_signal_base (cond) /= 0 then - return errno; - end if; - - return 0; - end pthread_cond_signal; - - 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"); - - begin - if pthread_cond_wait_base (cond, mutex) /= 0 then - return errno; - end if; - - return 0; - end pthread_cond_wait; - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - reltime : access timespec) return int - is - function pthread_cond_timedwait_base - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - reltime : access timespec) return int; - pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait"); - - begin - if pthread_cond_timedwait_base (cond, mutex, reltime) /= 0 then - if errno = EAGAIN then - return ETIMEDOUT; - end if; - - return errno; - end if; - - return 0; - end pthread_cond_timedwait; - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) - return int - is - function pthread_setscheduler - (thread : pthread_t; - policy : int; - prio : int) - return int; - pragma Import (C, pthread_setscheduler, "pthread_setscheduler"); - - begin - if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then - return errno; - end if; - - return 0; - end pthread_setschedparam; - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) - return int - is - pragma Unreferenced (attr, protocol); - begin - return 0; - end pthread_mutexattr_setprotocol; - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) - return int - is - pragma Unreferenced (attr, prioceiling); - begin - return 0; - end pthread_mutexattr_setprioceiling; - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) - return int - is - pragma Unreferenced (attr, contentionscope); - begin - return 0; - end pthread_attr_setscope; - - function sched_yield return int is - procedure pthread_yield; - pragma Import (C, pthread_yield, "pthread_yield"); - - begin - pthread_yield; - return 0; - end sched_yield; - - ----------------------------- - -- P1003.1c - Section 16 -- - ----------------------------- - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) - return int - is - pragma Unreferenced (attr, detachstate); - begin - return 0; - end pthread_attr_setdetachstate; - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) - return int - is - -- The LynxOS pthread_create doesn't seems to work. - -- Workaround : We're using st_new instead. - -- - -- function pthread_create_base - -- (thread : access pthread_t; - -- attributes : pthread_attr_t; - -- start_routine : Thread_Body; - -- arg : System.Address) - -- return int; - -- pragma Import (C, pthread_create_base, "pthread_create"); - - St : aliased st_t := attributes.st; - - function st_new - (start_routine : Thread_Body; - arg : System.Address; - attributes : access st_t; - thread : access pthread_t) - return int; - pragma Import (C, st_new, "st_new"); - - begin - -- Following code would be used if above commented function worked - - -- if pthread_create_base - -- (thread, attributes.all, start_routine, arg) /= 0 then - - if st_new (start_routine, arg, St'Access, thread) /= 0 then - return errno; - end if; - - return 0; - end pthread_create; - - function pthread_detach (thread : pthread_t) return int is - aliased_thread : aliased pthread_t := thread; - - function pthread_detach_base (thread : access pthread_t) return int; - pragma Import (C, pthread_detach_base, "pthread_detach"); - - begin - if pthread_detach_base (aliased_thread'Access) /= 0 then - return errno; - end if; - - return 0; - end pthread_detach; - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) - return int - is - function pthread_setspecific_base - (key : pthread_key_t; - value : System.Address) - return int; - pragma Import (C, pthread_setspecific_base, "pthread_setspecific"); - - begin - if pthread_setspecific_base (key, value) /= 0 then - return errno; - end if; - - return 0; - end pthread_setspecific; - - function pthread_getspecific (key : pthread_key_t) return System.Address is - procedure pthread_getspecific_base - (key : pthread_key_t; - value : access System.Address); - pragma Import (C, pthread_getspecific_base, "pthread_getspecific"); - - value : aliased System.Address := System.Null_Address; - - begin - pthread_getspecific_base (key, value'Unchecked_Access); - return value; - end pthread_getspecific; - - function Get_Stack_Base (thread : pthread_t) return Address is - pragma Warnings (Off, thread); - - begin - return Null_Address; - end Get_Stack_Base; - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) - return int - is - function pthread_keycreate - (key : access pthread_key_t; - destructor : destructor_pointer) - return int; - pragma Import (C, pthread_keycreate, "pthread_keycreate"); - - begin - if pthread_keycreate (key, destructor) /= 0 then - return errno; - end if; - - return 0; - end pthread_key_create; - - procedure pthread_init is - begin - null; - end pthread_init; - -end System.OS_Interface; diff --git a/gcc/ada/52osinte.ads b/gcc/ada/52osinte.ads deleted file mode 100644 index 71607a408a6..00000000000 --- a/gcc/ada/52osinte.ads +++ /dev/null @@ -1,564 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 a LynxOS (Native) version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-mthreads"); - - subtype int is Interfaces.C.int; - subtype char is Interfaces.C.char; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 11; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIMEDOUT : constant := 60; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 63; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGBRK : constant := 6; -- break - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGCORE : constant := 7; -- kill with core dump - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGURG : constant := 16; -- urgent condition on IO channel - SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 18; -- user stop requested from tty - SIGCONT : constant := 19; -- stopped process has been continued - SIGCLD : constant := 20; -- alias for SIGCHLD - SIGCHLD : constant := 20; -- child status change - SIGTTIN : constant := 21; -- background tty read attempted - SIGTTOU : constant := 22; -- background tty write attempted - SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) - SIGPOLL : constant := 23; -- pollable event occurred - SIGXCPU : constant := 24; -- CPU time limit exceeded - SIGXFSZ : constant := 25; -- filesize limit exceeded - SIGVTALRM : constant := 26; -- virtual timer expired - SIGPROF : constant := 27; -- profiling timer expired - SIGWINCH : constant := 28; -- window size change - SIGLOST : constant := 29; -- SUN 4.1 compatibility - SIGUSR1 : constant := 30; -- user defined signal 1 - SIGUSR2 : constant := 31; -- user defined signal 2 - SIGPRIO : constant := 32; -- sent to a process with its priority or - -- group is changed - - SIGADAABORT : constant := SIGABRT; - -- Change this if you want to use another signal for task abort. - -- SIGTERM might be a good one. - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := - (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); - Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP, SIGPRIO); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : int; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - SA_SIGINFO : constant := 16#80#; - - SIG_BLOCK : constant := 0; - SIG_UNBLOCK : constant := 1; - SIG_SETMASK : constant := 2; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - Time_Slice_Supported : constant Boolean := True; - -- Indicates wether time slicing is supported - - type timespec is private; - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; - pragma Inline (clock_gettime); - -- LynxOS has non standard clock_gettime - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timezone is record - tz_minuteswest : int; - tz_dsttime : int; - end record; - pragma Convention (C, struct_timezone); - type struct_timezone_ptr is access all struct_timezone; - - type struct_timeval is private; - -- This is needed on systems that do not have clock_gettime() - -- but do have gettimeofday(). - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 16#00200000#; - SCHED_RR : constant := 16#00100000#; - SCHED_OTHER : constant := 16#00400000#; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - --------- - -- LWP -- - --------- - - function lwp_self return System.Address; - -- lwp_self does not exist on this thread library, revert to pthread_self - -- which is the closest approximation (with getpid). This function is - -- needed to share 7staprop.adb across POSIX-like targets. - pragma Import (C, lwp_self, "pthread_self"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type st_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 0; - - ----------- - -- Stack -- - ----------- - - Stack_Base_Available : constant Boolean := False; - -- Indicates wether the stack base is available on this target. - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- returns the stack base of the specified thread. - -- Only call this function when Stack_Base_Available is True. - - function Get_Page_Size return size_t; - function Get_Page_Size return Address; - pragma Import (C, Get_Page_Size, "getpagesize"); - -- returns the size of a page, or 0 if this is not relevant on this - -- target - - PROT_NONE : constant := 0; - PROT_READ : constant := 1; - PROT_WRITE : constant := 2; - PROT_EXEC : constant := 4; - PROT_USER : constant := 8; - PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC + PROT_USER; - - PROT_ON : constant := PROT_READ; - PROT_OFF : constant := PROT_ALL; - - function mprotect (addr : Address; len : size_t; prot : int) return int; - pragma Import (C, mprotect); - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) return int; - pragma Inline (sigwait); - -- LynxOS has non standard sigwait - - function pthread_kill (thread : pthread_t; sig : Signal) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask, "sigprocmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Inline (pthread_mutexattr_init); - -- LynxOS has a nonstandard pthread_mutexattr_init - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Inline (pthread_mutexattr_destroy); - -- Lynxos has a nonstandard pthread_mutexattr_destroy - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Inline (pthread_mutex_init); - -- LynxOS has a nonstandard pthread_mutex_init - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Inline (pthread_mutex_destroy); - -- LynxOS has a nonstandard pthread_mutex_destroy - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Inline (pthread_mutex_lock); - -- LynxOS has a nonstandard pthread_mutex_lock - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Inline (pthread_mutex_unlock); - -- LynxOS has a nonstandard pthread_mutex_unlock - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Inline (pthread_condattr_init); - -- LynxOS has a nonstandard pthread_condattr_init - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Inline (pthread_condattr_destroy); - -- LynxOS has a nonstandard pthread_condattr_destroy - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Inline (pthread_cond_init); - -- LynxOS has a non standard pthread_cond_init - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Inline (pthread_cond_destroy); - -- LynxOS has a nonstandard pthread_cond_destroy - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Inline (pthread_cond_signal); - -- LynxOS has a nonstandard pthread_cond_signal - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Inline (pthread_cond_wait); - -- LynxOS has a nonstandard pthread_cond_wait - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - reltime : access timespec) return int; - pragma Inline (pthread_cond_timedwait); - -- LynxOS has a nonstandard pthrad_cond_timedwait - - Relative_Timed_Wait : constant Boolean := True; - -- pthread_cond_timedwait requires a relative delay time - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - PTHREAD_PRIO_NONE : constant := 0; - PTHREAD_PRIO_INHERIT : constant := 0; - PTHREAD_PRIO_PROTECT : constant := 0; - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Inline (pthread_setschedparam); - -- LynxOS doesn't have pthread_setschedparam. - -- Instead, use pthread_setscheduler - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int; - pragma Inline (pthread_mutexattr_setprotocol); - -- LynxOS doesn't have pthread_mutexattr_setprotocol - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int; - pragma Inline (pthread_mutexattr_setprioceiling); - -- LynxOS doesn't have pthread_mutexattr_setprioceiling - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - -- LynxOS doesn't have pthread_attr_setscope: all threads have system scope - pragma Inline (pthread_attr_setscope); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; - policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched"); - - function sched_yield return int; - -- pragma Import (C, sched_yield, "sched_yield"); - pragma Inline (sched_yield); - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "pthread_attr_create"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "pthread_attr_delete"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Inline (pthread_attr_setdetachstate); - -- LynxOS doesn't have pthread_attr_setdetachstate - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Inline (pthread_create); - -- LynxOS has a non standard pthread_create - - function pthread_detach (thread : pthread_t) return int; - pragma Inline (pthread_detach); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Inline (pthread_setspecific); - -- LynxOS has a non standard pthread_setspecific - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Inline (pthread_getspecific); - -- LynxOS has a non standard pthread_getspecific - - type destructor_pointer is access procedure (arg : System.Address); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Inline (pthread_key_create); - -- LynxOS has a non standard pthread_keycreate - - procedure pthread_init; - -- This is a dummy procedure to share some GNULLI files - -private - - type sigbit_array is array (1 .. 2) of long; - type sigset_t is record - sa_sigbits : sigbit_array; - end record; - pragma Convention (C_Pass_By_Copy, sigset_t); - - type pid_t is new long; - - type time_t is new long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is new unsigned_char; - CLOCK_REALTIME : constant clockid_t := 0; - - type struct_timeval is record - tv_sec : time_t; - tv_usec : time_t; - end record; - pragma Convention (C, struct_timeval); - - type st_t is record - stksize : int; - prio : int; - inheritsched : int; - state : int; - sched : int; - end record; - pragma Convention (C, st_t); - - type pthread_attr_t is record - st : st_t; - pthread_attr_scope : int; -- ignored - end record; - pragma Convention (C, pthread_attr_t); - - type pthread_condattr_t is new int; - - type pthread_mutexattr_t is new int; - - type tid_t is new short; - type pthread_t is new tid_t; - - type synch_ptr is access all pthread_mutex_t; - type pthread_mutex_t is record - w_count : int; - mut_owner : int; - id : unsigned; - next : synch_ptr; - end record; - pragma Convention (C, pthread_mutex_t); - - type pthread_cond_t is new pthread_mutex_t; - - type pthread_key_t is new int; - -end System.OS_Interface; diff --git a/gcc/ada/53osinte.ads b/gcc/ada/53osinte.ads deleted file mode 100644 index 95b093ae7fa..00000000000 --- a/gcc/ada/53osinte.ads +++ /dev/null @@ -1,556 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 a HPUX 11.0 (Native THREADS) version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-lpthread"); - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 11; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIMEDOUT : constant := 238; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 44; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGUSR1 : constant := 16; -- user defined signal 1 - SIGUSR2 : constant := 17; -- user defined signal 2 - SIGCLD : constant := 18; -- alias for SIGCHLD - SIGCHLD : constant := 18; -- child status change - SIGPWR : constant := 19; -- power-fail restart - SIGVTALRM : constant := 20; -- virtual timer alarm - SIGPROF : constant := 21; -- profiling timer alarm - SIGIO : constant := 22; -- asynchronous I/O - SIGPOLL : constant := 22; -- pollable event occurred - SIGWINCH : constant := 23; -- window size change - SIGSTOP : constant := 24; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 25; -- user stop requested from tty - SIGCONT : constant := 26; -- stopped process has been continued - SIGTTIN : constant := 27; -- background tty read attempted - SIGTTOU : constant := 28; -- background tty write attempted - SIGURG : constant := 29; -- urgent condition on IO channel - SIGLOST : constant := 30; -- remote lock lost (NFS) - SIGDIL : constant := 32; -- DIL signal - SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit) - SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit) - SIGCANCEL : constant := 35; -- used for pthread cancellation. - SIGGFAULT : constant := 36; -- Graphics framebuffer fault - - SIGADAABORT : constant := SIGABRT; - -- Note: on other targets, we usually use SIGABRT, but on HPUX, it - -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM. - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := - (SIGABRT, SIGPIPE, SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, - SIGALRM, SIGVTALRM, SIGIO, SIGCHLD); - - Reserved : constant Signal_Set := (SIGKILL, SIGSTOP); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : int; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - SA_SIGINFO : constant := 16#10#; - - SIG_BLOCK : constant := 0; - SIG_UNBLOCK : constant := 1; - SIG_SETMASK : constant := 2; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - Time_Slice_Supported : constant Boolean := True; - -- Indicates wether time slicing is supported - - type timespec is private; - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; - pragma Import (C, clock_gettime, "clock_gettime"); - - function clock_getres - (clock_id : clockid_t; - res : access timespec) return int; - pragma Import (C, clock_getres, "clock_getres"); - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timezone is record - tz_minuteswest : int; - tz_dsttime : int; - end record; - pragma Convention (C, struct_timezone); - type struct_timezone_ptr is access all struct_timezone; - - type struct_timeval is private; - -- This is needed on systems that do not have clock_gettime() - -- but do have gettimeofday(). - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 0; - SCHED_RR : constant := 1; - SCHED_OTHER : constant := 2; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - --------- - -- LWP -- - --------- - - function lwp_self return System.Address; - pragma Import (C, lwp_self, "_lwp_self"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 16#de#; - - ----------- - -- Stack -- - ----------- - - Stack_Base_Available : constant Boolean := False; - -- Indicates wether the stack base is available on this target. - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- returns the stack base of the specified thread. - -- Only call this function when Stack_Base_Available is True. - - function Get_Page_Size return size_t; - function Get_Page_Size return Address; - pragma Import (C, Get_Page_Size, "getpagesize"); - -- returns the size of a page, or 0 if this is not relevant on this - -- target - - PROT_NONE : constant := 0; - PROT_READ : constant := 1; - PROT_WRITE : constant := 2; - PROT_EXEC : constant := 4; - PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; - - PROT_ON : constant := PROT_READ; - PROT_OFF : constant := PROT_ALL; - - function mprotect (addr : Address; len : size_t; prot : int) return int; - pragma Import (C, mprotect); - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - procedure pthread_init; - pragma Inline (pthread_init); - -- This is a dummy procedure to share some GNULLI files - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) return int; - pragma Import (C, sigwait, "sigwait"); - - function pthread_kill - (thread : pthread_t; - sig : Signal) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask, "pthread_sigmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "pthread_cond_init"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); - - Relative_Timed_Wait : constant Boolean := False; - -- pthread_cond_timedwait requires an absolute delay time - - ---------------------------- - -- POSIX.1c Section 13 -- - ---------------------------- - - PTHREAD_PRIO_NONE : constant := 16#100#; - PTHREAD_PRIO_PROTECT : constant := 16#200#; - PTHREAD_PRIO_INHERIT : constant := 16#400#; - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol); - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int; - pragma Import (C, pthread_mutexattr_setprioceiling); - - type Array_7_Int is array (0 .. 6) of int; - type struct_sched_param is record - sched_priority : int; - sched_reserved : Array_7_Int; - end record; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) - return int; - pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import (C, pthread_attr_setinheritsched); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; - policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy); - - function sched_yield return int; - pragma Import (C, sched_yield, "sched_yield"); - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "__pthread_attr_init_system"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Import (C, pthread_attr_setdetachstate); - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "__pthread_create_system"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "pthread_setspecific"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Import (C, pthread_getspecific, "pthread_getspecific"); - - type destructor_pointer is access procedure (arg : System.Address); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "pthread_key_create"); - -private - - type unsigned_int_array_8 is array (0 .. 7) of unsigned; - type sigset_t is record - sigset : unsigned_int_array_8; - end record; - pragma Convention (C_Pass_By_Copy, sigset_t); - - type pid_t is new int; - - type time_t is new long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 1; - - type struct_timeval is record - tv_sec : time_t; - tv_usec : time_t; - end record; - pragma Convention (C, struct_timeval); - - type pthread_attr_t is new int; - type pthread_condattr_t is new int; - type pthread_mutexattr_t is new int; - type pthread_t is new int; - - type short_array is array (Natural range <>) of short; - type int_array is array (Natural range <>) of int; - - type pthread_mutex_t is record - m_short : short_array (0 .. 1); - m_int : int; - m_int1 : int_array (0 .. 3); - m_pad : int; -- needed for 32 bit ABI, but *not* for 64 bit - m_ptr : System.Address; - m_int2 : int_array (0 .. 1); - m_int3 : int_array (0 .. 3); - m_short2 : short_array (0 .. 1); - m_int4 : int_array (0 .. 4); - m_int5 : int_array (0 .. 1); - end record; - pragma Convention (C, pthread_mutex_t); - - type pthread_cond_t is record - c_short : short_array (0 .. 1); - c_int : int; - c_int1 : int_array (0 .. 3); - m_pad : int; -- needed for 32 bit ABI, but *not* for 64 bit - m_ptr : System.Address; - c_int2 : int_array (0 .. 1); - c_int3 : int_array (0 .. 1); - c_int4 : int_array (0 .. 1); - end record; - pragma Convention (C, pthread_cond_t); - - type pthread_key_t is new int; - -end System.OS_Interface; diff --git a/gcc/ada/54osinte.ads b/gcc/ada/54osinte.ads deleted file mode 100644 index b5ad0af3877..00000000000 --- a/gcc/ada/54osinte.ads +++ /dev/null @@ -1,539 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 a Solaris (POSIX Threads) version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-lposix4"); - pragma Linker_Options ("-lpthread"); - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 11; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIMEDOUT : constant := 145; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 45; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGUSR1 : constant := 16; -- user defined signal 1 - SIGUSR2 : constant := 17; -- user defined signal 2 - SIGCLD : constant := 18; -- alias for SIGCHLD - SIGCHLD : constant := 18; -- child status change - SIGPWR : constant := 19; -- power-fail restart - SIGWINCH : constant := 20; -- window size change - SIGURG : constant := 21; -- urgent condition on IO channel - SIGPOLL : constant := 22; -- pollable event occurred - SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias) - SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 24; -- user stop requested from tty - SIGCONT : constant := 25; -- stopped process has been continued - SIGTTIN : constant := 26; -- background tty read attempted - SIGTTOU : constant := 27; -- background tty write attempted - SIGVTALRM : constant := 28; -- virtual timer expired - SIGPROF : constant := 29; -- profiling timer expired - SIGXCPU : constant := 30; -- CPU time limit exceeded - SIGXFSZ : constant := 31; -- filesize limit exceeded - SIGWAITING : constant := 32; -- process's lwps blocked (Solaris) - SIGLWP : constant := 33; -- used by thread library (Solaris) - SIGFREEZE : constant := 34; -- used by CPR (Solaris) - SIGTHAW : constant := 35; -- used by CPR (Solaris) - SIGCANCEL : constant := 36; -- thread cancellation signal (libthread) - - SIGADAABORT : constant := SIGABRT; - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := (SIGTRAP, SIGLWP, SIGPROF); - - -- Following signals should not be disturbed. - -- See c-posix-signals.c in FLORIST - - Reserved : constant Signal_Set := - (SIGKILL, SIGSTOP, SIGWAITING, SIGCANCEL); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type struct_sigaction is record - sa_flags : int; - sa_handler : System.Address; - sa_mask : sigset_t; - sa_resv1 : int; - sa_resv2 : int; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - SA_SIGINFO : constant := 16#0008#; - - SIG_BLOCK : constant := 1; - SIG_UNBLOCK : constant := 2; - SIG_SETMASK : constant := 3; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - Time_Slice_Supported : constant Boolean := True; - -- Indicates wether time slicing is supported - - type timespec is private; - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; - pragma Import (C, clock_gettime, "clock_gettime"); - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timeval is private; - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 1; - SCHED_RR : constant := 2; - SCHED_OTHER : constant := 0; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - --------- - -- LWP -- - --------- - - function lwp_self return System.Address; - pragma Import (C, lwp_self, "_lwp_self"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 16#40#; - - ----------- - -- Stack -- - ----------- - - Stack_Base_Available : constant Boolean := False; - -- Indicates wether the stack base is available on this target. - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- returns the stack base of the specified thread. - -- Only call this function when Stack_Base_Available is True. - - function Get_Page_Size return size_t; - function Get_Page_Size return Address; - pragma Import (C, Get_Page_Size, "getpagesize"); - -- returns the size of a page, or 0 if this is not relevant on this - -- target - - PROT_NONE : constant := 0; - PROT_READ : constant := 1; - PROT_WRITE : constant := 2; - PROT_EXEC : constant := 4; - PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; - - PROT_ON : constant := PROT_READ; - PROT_OFF : constant := PROT_ALL; - - function mprotect (addr : Address; len : size_t; prot : int) return int; - pragma Import (C, mprotect); - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - procedure pthread_init; - -- This is a dummy procedure to share some GNULLI files - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) return int; - pragma Import (C, sigwait, "__posix_sigwait"); - - function pthread_kill - (thread : pthread_t; - sig : Signal) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask, "pthread_sigmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "pthread_cond_init"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); - - Relative_Timed_Wait : constant Boolean := False; - -- pthread_cond_timedwait requires an absolute delay time - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - PTHREAD_PRIO_NONE : constant := 0; - PTHREAD_PRIO_INHERIT : constant := 16#10#; - PTHREAD_PRIO_PROTECT : constant := 16#20#; - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol); - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int; - pragma Import (C, pthread_mutexattr_setprioceiling); - - type Array_8_Int is array (0 .. 7) of int; - type struct_sched_param is record - sched_priority : int; - sched_pad : Array_8_Int; - end record; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import (C, pthread_attr_setinheritsched); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; - policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy); - - function sched_yield return int; - pragma Import (C, sched_yield, "sched_yield"); - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "pthread_attr_init"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Import (C, pthread_attr_setdetachstate); - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "pthread_create"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "pthread_setspecific"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Import (C, pthread_getspecific, "pthread_getspecific"); - - type destructor_pointer is access procedure (arg : System.Address); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "pthread_key_create"); - -private - - type array_type_1 is array (Integer range 0 .. 3) of unsigned_long; - type sigset_t is record - X_X_sigbits : array_type_1; - end record; - pragma Convention (C, sigset_t); - - type pid_t is new long; - - type time_t is new long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 0; - - type struct_timeval is record - tv_sec : time_t; - tv_usec : time_t; - end record; - pragma Convention (C, struct_timeval); - - type pthread_attr_t is record - pthread_attrp : System.Address; - end record; - pragma Convention (C, pthread_attr_t); - - type pthread_condattr_t is record - pthread_condattrp : System.Address; - end record; - pragma Convention (C, pthread_condattr_t); - - type pthread_mutexattr_t is record - pthread_mutexattrp : System.Address; - end record; - pragma Convention (C, pthread_mutexattr_t); - - type pthread_t is new unsigned; - - type uint64_t is mod 2 ** 64; - - type pthread_mutex_t is record - pthread_mutex_flags : uint64_t; - pthread_mutex_owner64 : uint64_t; - pthread_mutex_data : uint64_t; - end record; - pragma Convention (C, pthread_mutex_t); - type pthread_mutex_t_ptr is access pthread_mutex_t; - - type pthread_cond_t is record - pthread_cond_flags : uint64_t; - pthread_cond_data : uint64_t; - end record; - pragma Convention (C, pthread_cond_t); - - type pthread_key_t is new unsigned; - -end System.OS_Interface; diff --git a/gcc/ada/55osinte.adb b/gcc/ada/55osinte.adb deleted file mode 100644 index 466a15d2b33..00000000000 --- a/gcc/ada/55osinte.adb +++ /dev/null @@ -1,108 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUNTIME 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-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. It is -- --- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- --- State University (http://www.gnat.com). -- --- -- ------------------------------------------------------------------------------- - --- This is the FreeBSD THREADS version of this package - -with Interfaces.C; use Interfaces.C; - -package body System.OS_Interface is - - function Errno return int is - type int_ptr is access all int; - - function internal_errno return int_ptr; - pragma Import (C, internal_errno, "__error"); - begin - return (internal_errno.all); - end Errno; - - function Get_Stack_Base (thread : pthread_t) return Address is - pragma Unreferenced (thread); - begin - return (0); - end Get_Stack_Base; - - procedure pthread_init is - begin - null; - end pthread_init; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (TS : timespec) return Duration is - begin - return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; - 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'(ts_sec => S, - ts_nsec => long (Long_Long_Integer (F * 10#1#E9))); - end To_Timespec; - - - 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; - - 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; - -end System.OS_Interface; diff --git a/gcc/ada/55osinte.ads b/gcc/ada/55osinte.ads deleted file mode 100644 index 13e545871c1..00000000000 --- a/gcc/ada/55osinte.ads +++ /dev/null @@ -1,644 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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. It is -- --- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- --- State University (http://www.gnat.com). -- --- -- ------------------------------------------------------------------------------- - --- This is the FreeBSD PTHREADS version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-pthread"); - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function Errno return int; - pragma Inline (Errno); - - EAGAIN : constant := 35; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIMEDOUT : constant := 60; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 31; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGURG : constant := 16; -- urgent condition on IO channel - SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 18; -- user stop requested from tty - SIGCONT : constant := 19; -- stopped process has been continued - SIGCLD : constant := 20; -- alias for SIGCHLD - SIGCHLD : constant := 20; -- child status change - SIGTTIN : constant := 21; -- background tty read attempted - SIGTTOU : constant := 22; -- background tty write attempted - SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) - SIGXCPU : constant := 24; -- CPU time limit exceeded - SIGXFSZ : constant := 25; -- filesize limit exceeded - SIGVTALRM : constant := 26; -- virtual timer expired - SIGPROF : constant := 27; -- profiling timer expired - SIGWINCH : constant := 28; -- window size change - SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD) - SIGUSR1 : constant := 30; -- user defined signal 1 - SIGUSR2 : constant := 31; -- user defined signal 2 - - SIGADAABORT : constant := SIGABRT; - -- Change this if you want to use another signal for task abort. - -- SIGTERM might be a good one. - - type Signal_Set is array (Natural range <>) of Signal; - - -- Interrupts that must be unmasked at all times. FreeBSD - -- pthreads will not allow an application to mask out any - -- interrupt needed by the threads library. - Unmasked : constant Signal_Set := - (SIGTRAP, SIGBUS, SIGTTIN, SIGTTOU, SIGTSTP); - - -- FreeBSD will uses SIGPROF for timing. Do not allow a - -- handler to attach to this signal. - Reserved : constant Signal_Set := (0 .. 0 => SIGPROF); - - type sigset_t is private; - - function sigaddset - (set : access sigset_t; - sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset - (set : access sigset_t; - sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember - (set : access sigset_t; - sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - -- sigcontext is architecture dependent, so define it private - type struct_sigcontext is private; - - type old_struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : int; - end record; - pragma Convention (C, old_struct_sigaction); - - type new_struct_sigaction is record - sa_handler : System.Address; - sa_flags : int; - sa_mask : sigset_t; - end record; - pragma Convention (C, new_struct_sigaction); - - subtype struct_sigaction is new_struct_sigaction; - type struct_sigaction_ptr is access all struct_sigaction; - - SIG_BLOCK : constant := 1; - SIG_UNBLOCK : constant := 2; - SIG_SETMASK : constant := 3; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - SA_SIGINFO : constant := 16#0040#; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - Time_Slice_Supported : constant Boolean := True; - -- Indicates wether time slicing is supported (i.e SCHED_RR is supported) - - type timespec is private; - - function nanosleep (rqtp, rmtp : access timespec) return int; - pragma Import (C, nanosleep, "nanosleep"); - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) - return int; - pragma Import (C, clock_gettime, "clock_gettime"); - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timezone is record - tz_minuteswest : int; - tz_dsttime : int; - end record; - pragma Convention (C, struct_timezone); - type struct_timeval is private; - -- This is needed on systems that do not have clock_gettime() - -- but do have gettimeofday(). - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - function gettimeofday - (tv : access struct_timeval; - tz : System.Address) return int; - pragma Import (C, gettimeofday, "gettimeofday"); - - procedure usleep (useconds : unsigned_long); - pragma Import (C, usleep, "usleep"); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 1; - SCHED_OTHER : constant := 2; - SCHED_RR : constant := 3; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - Self_PID : constant pid_t; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - --------- - -- LWP -- - --------- - - function lwp_self return System.Address; - -- lwp_self does not exist on this thread library, revert to pthread_self - -- which is the closest approximation (with getpid). This function is - -- needed to share 7staprop.adb across POSIX-like targets. - pragma Import (C, lwp_self, "pthread_self"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 1; - PTHREAD_CREATE_JOINABLE : constant := 0; - - ----------- - -- Stack -- - ----------- - - Stack_Base_Available : constant Boolean := False; - -- Indicates wether the stack base is available on this target. - -- This allows us to share s-osinte.adb between all the FSU run time. - -- Note that this value can only be true if pthread_t has a complete - -- definition that corresponds exactly to the C header files. - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- returns the stack base of the specified thread. - -- Only call this function when Stack_Base_Available is True. - - function Get_Page_Size return size_t; - function Get_Page_Size return Address; - pragma Import (C, Get_Page_Size, "getpagesize"); - -- returns the size of a page, or 0 if this is not relevant on this - -- target - - PROT_NONE : constant := 0; - PROT_READ : constant := 1; - PROT_WRITE : constant := 2; - PROT_EXEC : constant := 4; - PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; - - PROT_ON : constant := PROT_NONE; - PROT_OFF : constant := PROT_ALL; - - function mprotect - (addr : Address; len : size_t; prot : int) return int; - pragma Import (C, mprotect); - - ----------------------------------------- - -- Nonstandard Thread Initialization -- - ----------------------------------------- - -- FSU_THREADS requires pthread_init, which is nonstandard - -- and this should be invoked during the elaboration of s-taprop.adb - -- - -- FreeBSD does not require this so we provide an empty Ada body. - procedure pthread_init; - - --------------------------- - -- POSIX.1c Section 3 -- - --------------------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) return int; - pragma Import (C, sigwait, "sigwait"); - - function pthread_kill - (thread : pthread_t; - sig : Signal) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask, "pthread_sigmask"); - - ---------------------------- - -- POSIX.1c Section 11 -- - ---------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "pthread_cond_init"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); - - Relative_Timed_Wait : constant Boolean := False; - -- pthread_cond_timedwait requires an absolute delay time - - ---------------------------- - -- POSIX.1c Section 13 -- - ---------------------------- - - PTHREAD_PRIO_NONE : constant := 0; - PTHREAD_PRIO_PROTECT : constant := 2; - PTHREAD_PRIO_INHERIT : constant := 1; - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int; - pragma Import - (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol"); - - function pthread_mutexattr_getprotocol - (attr : access pthread_mutexattr_t; - protocol : access int) return int; - pragma Import - (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol"); - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int; - pragma Import - (C, pthread_mutexattr_setprioceiling, - "pthread_mutexattr_setprioceiling"); - - function pthread_mutexattr_getprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : access int) return int; - pragma Import - (C, pthread_mutexattr_getprioceiling, - "pthread_mutexattr_getprioceiling"); - - type struct_sched_param is record - sched_priority : int; - end record; - pragma Convention (C, struct_sched_param); - - function pthread_getschedparam - (thread : pthread_t; - policy : access int; - param : access struct_sched_param) return int; - pragma Import (C, pthread_getschedparam, "pthread_getschedparam"); - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); - - function pthread_attr_getscope - (attr : access pthread_attr_t; - contentionscope : access int) return int; - pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import - (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched"); - - function pthread_attr_getinheritsched - (attr : access pthread_attr_t; - inheritsched : access int) return int; - pragma Import - (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched"); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; - policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy, - "pthread_attr_setschedpolicy"); - - function pthread_attr_getschedpolicy - (attr : access pthread_attr_t; - policy : access int) return int; - pragma Import (C, pthread_attr_getschedpolicy, - "pthread_attr_getschedpolicy"); - - function pthread_attr_setschedparam - (attr : access pthread_attr_t; - sched_param : int) return int; - pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam"); - - function pthread_attr_getschedparam - (attr : access pthread_attr_t; - sched_param : access int) return int; - pragma Import (C, pthread_attr_getschedparam, "pthread_attr_getschedparam"); - - function sched_yield return int; - pragma Import (C, sched_yield, "pthread_yield"); - - ----------------------------- - -- P1003.1c - Section 16 -- - ----------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "pthread_attr_init"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Import - (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate"); - - function pthread_attr_getdetachstate - (attr : access pthread_attr_t; - detachstate : access int) return int; - pragma Import - (C, pthread_attr_getdetachstate, "pthread_attr_getdetachstate"); - - function pthread_attr_getstacksize - (attr : access pthread_attr_t; - stacksize : access size_t) return int; - pragma Import - (C, pthread_attr_getstacksize, "pthread_attr_getstacksize"); - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import - (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "pthread_create"); - - function pthread_detach (thread : pthread_t) return int; - pragma Import (C, pthread_detach, "pthread_detach"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - ---------------------------- - -- POSIX.1c Section 17 -- - ---------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "pthread_setspecific"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Import (C, pthread_getspecific, "pthread_getspecific"); - - type destructor_pointer is access - procedure (arg : System.Address); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "pthread_key_create"); - - -------------------------------------- - -- Non-portable pthread functions -- - -------------------------------------- - - function pthread_set_name_np - (thread : pthread_t; - name : System.Address) return int; - pragma Import (C, pthread_set_name_np, "pthread_set_name_np"); - -private - - type sigset_t is array (1 .. 4) of unsigned; - - -- In FreeBSD the component sa_handler turns out to - -- be one a union type, and the selector is a macro: - -- #define sa_handler __sigaction_u._handler - -- #define sa_sigaction __sigaction_u._sigaction - - -- Should we add a signal_context type here ? - -- How could it be done independent of the CPU architecture ? - -- sigcontext type is opaque, so it is architecturally neutral. - -- It is always passed as an access type, so define it as an empty record - -- since the contents are not used anywhere. - type struct_sigcontext is null record; - pragma Convention (C, struct_sigcontext); - - type pid_t is new int; - Self_PID : constant pid_t := 0; - - type time_t is new long; - - type timespec is record - ts_sec : time_t; - ts_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 0; - - type struct_timeval is record - tv_sec : long; - tv_usec : long; - end record; - pragma Convention (C, struct_timeval); - - type pthread_t is new System.Address; - type pthread_attr_t is new System.Address; - type pthread_mutex_t is new System.Address; - type pthread_mutexattr_t is new System.Address; - type pthread_cond_t is new System.Address; - type pthread_condattr_t is new System.Address; - type pthread_key_t is new int; - -end System.OS_Interface; diff --git a/gcc/ada/55system.ads b/gcc/ada/55system.ads deleted file mode 100644 index 72c51b0df52..00000000000 --- a/gcc/ada/55system.ads +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (GNU-Linux/ia64 Version) -- --- -- --- 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 := 0.01; - - -- 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) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -private - - 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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := False; - ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; - 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 := True; - -end System; diff --git a/gcc/ada/56osinte.adb b/gcc/ada/56osinte.adb deleted file mode 100644 index 0cb052632a3..00000000000 --- a/gcc/ada/56osinte.adb +++ /dev/null @@ -1,154 +0,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) 2001-2002 Ada Core Technologies, 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 LynxOS (POSIX 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 : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return - struct_timeval' - (tv_sec => S, - tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); - end To_Timeval; - - ------------- - -- sigwait -- - ------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) - return int - is - function sigwaitinfo - (set : access sigset_t; - info : System.Address) return Signal; - pragma Import (C, sigwaitinfo, "sigwaitinfo"); - - begin - sig.all := sigwaitinfo (set, Null_Address); - - if sig.all = -1 then - return errno; - end if; - - return 0; - end sigwait; - - -------------------- - -- Get_Stack_Base -- - -------------------- - - function Get_Stack_Base (thread : pthread_t) return Address is - pragma Warnings (Off, thread); - - begin - return Null_Address; - end Get_Stack_Base; - - ------------------ - -- pthread_init -- - ------------------ - - procedure pthread_init is - begin - null; - end pthread_init; - -end System.OS_Interface; diff --git a/gcc/ada/56osinte.ads b/gcc/ada/56osinte.ads deleted file mode 100644 index 8b6b33885d1..00000000000 --- a/gcc/ada/56osinte.ads +++ /dev/null @@ -1,592 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 a LynxOS (POSIX Threads) version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-mthreads"); - -- Selects the POSIX 1.c runtime, rather than the non-threading runtime - -- or the deprecated legacy threads library. The -mthreads flag is - -- defined in patch.LynxOS and matches the definition for Lynx's gcc. - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 11; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIMEDOUT : constant := 60; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 63; - - -- Max_Interrupt is the number of OS signals, as defined in: - -- - -- /usr/include/sys/signal.h - -- - -- - -- The lowest numbered signal is 1, but 0 is a valid argument to some - -- library functions, eg. kill(2). However, 0 is not just another - -- signal: For instance 'I in Signal' and similar should be used with - -- caution. - - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGBRK : constant := 6; -- break - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in future - SIGCORE : constant := 7; -- kill with core dump - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGURG : constant := 16; -- urgent condition on IO channel - SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 18; -- user stop requested from tty - SIGCONT : constant := 19; -- stopped process has been continued - SIGCLD : constant := 20; -- alias for SIGCHLD - SIGCHLD : constant := 20; -- child status change - SIGTTIN : constant := 21; -- background tty read attempted - SIGTTOU : constant := 22; -- background tty write attempted - SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) - SIGPOLL : constant := 23; -- pollable event occurred - SIGTHREADKILL : constant := 24; -- Reserved by LynxOS runtime - SIGXCPU : constant := 24; -- CPU time limit exceeded - SIGXFSZ : constant := 25; -- filesize limit exceeded - SIGVTALRM : constant := 26; -- virtual timer expired - SIGPROF : constant := 27; -- profiling timer expired - SIGWINCH : constant := 28; -- window size change - SIGLOST : constant := 29; -- SUN 4.1 compatibility - SIGUSR1 : constant := 30; -- user defined signal 1 - SIGUSR2 : constant := 31; -- user defined signal 2 - - SIGPRIO : constant := 32; - -- sent to a process with its priority or group is changed - - SIGADAABORT : constant := SIGABRT; - -- Change this if you want to use another signal for task abort. - -- SIGTERM might be a good one. - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := - (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGTHREADKILL); - Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP, SIGPRIO); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : int; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - SA_SIGINFO : constant := 16#80#; - - SIG_BLOCK : constant := 0; - SIG_UNBLOCK : constant := 1; - SIG_SETMASK : constant := 2; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - Time_Slice_Supported : constant Boolean := True; - -- Indicates whether time slicing is supported - - type timespec is private; - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; - pragma Import (C, clock_gettime, "clock_gettime"); - - function clock_getres - (clock_id : clockid_t; - res : access timespec) return int; - pragma Import (C, clock_getres, "clock_getres"); - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timezone is record - tz_minuteswest : int; - tz_dsttime : int; - end record; - pragma Convention (C, struct_timezone); - type struct_timezone_ptr is access all struct_timezone; - - type struct_timeval is private; - -- This is needed on systems that do not have clock_gettime() - -- but do have gettimeofday(). - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 16#200000#; - SCHED_RR : constant := 16#100000#; - SCHED_OTHER : constant := 16#400000#; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - --------- - -- LWP -- - --------- - - function lwp_self return System.Address; - pragma Import (C, lwp_self, "pthread_self"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 1; - PTHREAD_CREATE_JOINABLE : constant := 0; - - ----------- - -- Stack -- - ----------- - - Stack_Base_Available : constant Boolean := False; - -- Indicates whether the stack base is available on this target. - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- Returns the stack base of the specified thread. - -- Only call this function when Stack_Base_Available is True. - - function Get_Page_Size return size_t; - function Get_Page_Size return Address; - pragma Import (C, Get_Page_Size, "getpagesize"); - -- Returns the size of a page, or 0 if this is not relevant on this - -- target - - PROT_NONE : constant := 1; - PROT_READ : constant := 2; - PROT_WRITE : constant := 4; - PROT_EXEC : constant := 8; - PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; - - PROT_ON : constant := PROT_READ; - PROT_OFF : constant := PROT_ALL; - - function mprotect (addr : Address; len : size_t; prot : int) return int; - pragma Import (C, mprotect); - - ----------------------------------------- - -- Nonstandard Thread Initialization -- - ----------------------------------------- - - procedure pthread_init; - -- This is a dummy procedure to share some GNULLI files - - --------------------------- - -- POSIX.1c Section 3 -- - --------------------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) return int; - pragma Inline (sigwait); - -- LynxOS has non standard sigwait - - function pthread_kill - (thread : pthread_t; - sig : Signal) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask, "pthread_sigmask"); - -- The behavior of pthread_sigmask on LynxOS requires - -- further investigation. - - ---------------------------- - -- POSIX.1c Section 11 -- - ---------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "pthread_cond_init"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); - - Relative_Timed_Wait : constant Boolean := False; - -- pthread_cond_timedwait requires an absolute delay time - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - PTHREAD_PRIO_NONE : constant := 0; - PTHREAD_PRIO_INHERIT : constant := 1; - PTHREAD_PRIO_PROTECT : constant := 2; - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol); - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int; - pragma Import (C, pthread_mutexattr_setprioceiling); - - type struct_sched_param is record - sched_priority : int; - end record; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import (C, pthread_attr_setinheritsched); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; - policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy); - - function sched_yield return int; - pragma Import (C, sched_yield, "sched_yield"); - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "pthread_attr_init"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Import (C, pthread_attr_setdetachstate); - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "pthread_create"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function st_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, st_setspecific, "st_setspecific"); - - function st_getspecific - (key : pthread_key_t; - retval : System.Address) return int; - pragma Import (C, st_getspecific, "st_getspecific"); - - type destructor_pointer is access procedure (arg : System.Address); - - function st_keycreate - (destructor : destructor_pointer; - key : access pthread_key_t) return int; - pragma Import (C, st_keycreate, "st_keycreate"); - -private - - type sigset_t is record - X1, X2 : long; - end record; - pragma Convention (C, sigset_t); - - type pid_t is new long; - - type time_t is new long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is new unsigned_char; - CLOCK_REALTIME : constant clockid_t := 0; - - type struct_timeval is record - tv_sec : time_t; - tv_usec : time_t; - end record; - pragma Convention (C, struct_timeval); - - type st_attr_t is record - stksize : int; - prio : int; - inheritsched : int; - state : int; - sched : int; - detachstate : int; - guardsize : int; - end record; - pragma Convention (C, st_attr_t); - - type pthread_attr_t is record - pthread_attr_magic : unsigned; - st : st_attr_t; - pthread_attr_scope : int; - end record; - pragma Convention (C, pthread_attr_t); - - type pthread_condattr_t is record - cv_magic : unsigned; - cv_pshared : unsigned; - end record; - pragma Convention (C, pthread_condattr_t); - - type pthread_mutexattr_t is record - m_flags : unsigned; - m_prio_c : int; - m_pshared : int; - end record; - pragma Convention (C, pthread_mutexattr_t); - - type tid_t is new short; - type pthread_t is new tid_t; - - type block_obj_t is new System.Address; - -- typedef struct _block_obj_s { - -- struct st_entry *b_head; - -- } block_obj_t; - - type pthread_mutex_t is record - m_flags : unsigned; - m_owner : tid_t; - m_wait : block_obj_t; - m_prio_c : int; - m_oldprio : int; - m_count : int; - m_referenced : int; - end record; - pragma Convention (C, pthread_mutex_t); - type pthread_mutex_t_ptr is access all pthread_mutex_t; - - type pthread_cond_t is record - cv_magic : unsigned; - cv_wait : block_obj_t; - cv_mutex : pthread_mutex_t_ptr; - cv_refcnt : int; - end record; - pragma Convention (C, pthread_cond_t); - - type pthread_key_t is new int; - -end System.OS_Interface; diff --git a/gcc/ada/56system.ads b/gcc/ada/56system.ads deleted file mode 100644 index a7371a2d9a2..00000000000 --- a/gcc/ada/56system.ads +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (FreeBSD/x86 Version) -- --- -- --- 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 := 0.000_001; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := False; - 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 := True; - -end System; diff --git a/gcc/ada/56taprop.adb b/gcc/ada/56taprop.adb deleted file mode 100644 index 6276d7f5092..00000000000 --- a/gcc/ada/56taprop.adb +++ /dev/null @@ -1,1184 +0,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 . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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 a LynxOS version of this file, adapted to make --- SCHED_FIFO and ceiling locking (Annex D compliance) work properly - --- This package contains all the GNULL primitives that interface directly --- with the underlying OS. - -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.Tasking.Debug; --- used for Known_Tasks - -with System.Task_Info; --- used for Task_Info_Type - -with Interfaces.C; --- used for int --- size_t - -with System.Interrupt_Management; --- used for Keep_Unmasked --- Abort_Task_Interrupt --- Interrupt_ID - -with System.Interrupt_Management.Operations; --- used for Set_Interrupt_Mask --- All_Tasks_Mask -pragma Elaborate_All (System.Interrupt_Management.Operations); - -with System.Parameters; --- used for Size_Type - -with System.Tasking; --- used for Ada_Task_Control_Block --- Task_ID - -with System.Soft_Links; --- used for Defer/Undefer_Abort - --- Note that we do not use System.Tasking.Initialization directly since --- this is a higher level package that we shouldn't depend on. For example --- when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Initialization - -with System.OS_Primitives; --- used for Delay_Modes - -with Unchecked_Deallocation; - -package body System.Task_Primitives.Operations is - - use System.Tasking.Debug; - use System.Tasking; - use Interfaces.C; - use System.OS_Interface; - use System.Parameters; - use System.OS_Primitives; - - package SSL renames System.Soft_Links; - - ---------------- - -- Local Data -- - ---------------- - - -- The followings are logically constants, but need to be initialized - -- at run time. - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_ID associated with a thread - - Environment_Task_ID : Task_ID; - -- A variable to hold Task_ID for the environment task. - - Locking_Policy : Character; - pragma Import (C, Locking_Policy, "__gl_locking_policy"); - -- Value of the pragma Locking_Policy: - -- 'C' for Ceiling_Locking - -- 'I' for Inherit_Locking - -- ' ' for none. - - Unblocked_Signal_Mask : aliased sigset_t; - -- The set of signals that should unblocked in all tasks - - -- The followings are internal configuration constants needed. - - Next_Serial_Number : Task_Serial_Number := 100; - -- We start at 100, to reserve some special values for - -- using in error checking. - - Time_Slice_Val : Integer; - pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - - Dispatching_Policy : Character; - pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - - FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; - -- Indicates whether FIFO_Within_Priorities is set. - - Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads). - - -------------------- - -- Local Packages -- - -------------------- - - package Specific is - - procedure Initialize (Environment_Task : Task_ID); - pragma Inline (Initialize); - -- Initialize various data needed by this package. - - function Is_Valid_Task return Boolean; - pragma Inline (Is_Valid_Task); - -- Does the current thread have an ATCB? - - procedure Set (Self_Id : Task_ID); - pragma Inline (Set); - -- Set the self id for the current task. - - function Self return Task_ID; - pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task. - - end Specific; - - package body Specific is separate; - -- The body of this package is target specific. - - --------------------------------- - -- Support for foreign threads -- - --------------------------------- - - function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; - -- Allocate and Initialize a new ATCB for the current Thread. - - function Register_Foreign_Thread - (Thread : Thread_Id) return Task_ID is separate; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Abort_Handler (Sig : Signal); - -- Signal handler used to implement asynchronous abort. - - procedure Set_OS_Priority (T : Task_ID; Prio : System.Any_Priority); - -- This procedure calls the scheduler of the OS to set thread's priority - - ------------------- - -- Abort_Handler -- - ------------------- - - procedure Abort_Handler (Sig : Signal) is - pragma Unreferenced (Sig); - - T : constant Task_ID := Self; - Result : Interfaces.C.int; - Old_Set : aliased sigset_t; - - begin - -- It is not safe to raise an exception when using ZCX and the GCC - -- exception handling mechanism. - - if ZCX_By_Default and then GCC_ZCX_Support then - return; - end if; - - if T.Deferral_Level = 0 - and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then - not T.Aborting - then - T.Aborting := True; - - -- Make sure signals used for RTS internal purpose are unmasked - - Result := - pthread_sigmask (SIG_UNBLOCK, - Unblocked_Signal_Mask'Unchecked_Access, - Old_Set'Unchecked_Access); - pragma Assert (Result = 0); - - raise Standard'Abort_Signal; - end if; - end Abort_Handler; - - ----------------- - -- Stack_Guard -- - ----------------- - - procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is - Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread); - Guard_Page_Address : Address; - - Res : Interfaces.C.int; - - begin - if Stack_Base_Available then - - -- Compute the guard page address - - Guard_Page_Address := - Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size; - - if On then - Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_ON); - else - Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_OFF); - end if; - - pragma Assert (Res = 0); - end if; - end Stack_Guard; - - -------------------- - -- Get_Thread_Id -- - -------------------- - - function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_ID renames Specific.Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : access Lock) - is - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - if Locking_Policy = 'C' then - L.Ceiling := Prio; - end if; - - Result := pthread_mutex_init (L.Mutex'Access, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is - pragma Unreferenced (Level); - - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutex_init (L, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Attributes'Access); - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L.Mutex'Access); - pragma Assert (Result = 0); - end Finalize_Lock; - - procedure Finalize_Lock (L : access RTS_Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0); - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - Result : Interfaces.C.int; - T : constant Task_ID := Self; - - begin - if Locking_Policy = 'C' then - if T.Common.Current_Priority > L.Ceiling then - Ceiling_Violation := True; - return; - end if; - - L.Saved_Priority := T.Common.Current_Priority; - - if T.Common.Current_Priority < L.Ceiling then - Set_OS_Priority (T, L.Ceiling); - end if; - end if; - - Result := pthread_mutex_lock (L.Mutex'Access); - - -- Assume that the cause of EINVAL is a priority ceiling violation - - Ceiling_Violation := (Result = EINVAL); - pragma Assert (Result = 0 or else Result = EINVAL); - end Write_Lock; - - -- No tricks on RTS_Locks - - procedure Write_Lock - (L : access RTS_Lock; Global_Lock : Boolean := False) - is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_lock (L); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - procedure Write_Lock (T : Task_ID) is - Result : Interfaces.C.int; - begin - if not Single_Lock then - Result := pthread_mutex_lock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - begin - Write_Lock (L, Ceiling_Violation); - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : access Lock) is - Result : Interfaces.C.int; - T : constant Task_ID := Self; - - begin - Result := pthread_mutex_unlock (L.Mutex'Access); - pragma Assert (Result = 0); - - if Locking_Policy = 'C' then - if T.Common.Current_Priority > L.Saved_Priority then - Set_OS_Priority (T, L.Saved_Priority); - end if; - end if; - end Unlock; - - procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); - end if; - end Unlock; - - procedure Unlock (T : Task_ID) is - Result : Interfaces.C.int; - begin - if not Single_Lock then - Result := pthread_mutex_unlock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Unlock; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : Task_ID; - Reason : System.Tasking.Task_States) - is - pragma Unreferenced (Reason); - Result : Interfaces.C.int; - - begin - if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; - - -- EINTR is not considered a failure - - pragma Assert (Result = 0 or else Result = EINTR); - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - -- This is for use within the run-time system, so abort is - -- assumed to be already deferred, and the caller should be - -- holding its own ATCB lock. - - procedure Timed_Sleep - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Unreferenced (Reason); - - Check_Time : constant Duration := Monotonic_Clock; - Rel_Time : Duration; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - Timedout := True; - Yielded := False; - - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time); - end if; - - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); - end if; - end if; - - if Abs_Time > Check_Time then - if Relative_Timed_Wait then - Request := To_Timespec (Rel_Time); - else - Request := To_Timespec (Abs_Time); - end if; - - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; - - if Single_Lock then - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, - Request'Access); - - else - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, - Request'Access); - end if; - - exit when Abs_Time <= Monotonic_Clock; - - if Result = 0 or Result = EINTR then - - -- Somebody may have called Wakeup for us - - Timedout := False; - exit; - end if; - - pragma Assert (Result = ETIMEDOUT); - end loop; - end if; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - -- This is for use in implementing delay statements, so we assume - -- the caller is abort-deferred but is holding no locks. - - procedure Timed_Delay - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes) - is - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Rel_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - -- Only the little window between deferring abort and - -- locking Self_ID is the reason we need to - -- check for pending abort and priority change below! - - SSL.Abort_Defer.all; - - if Single_Lock then - Lock_RTS; - end if; - - -- Comments needed in code below ??? - - Write_Lock (Self_ID); - - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time); - end if; - - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); - end if; - end if; - - if Abs_Time > Check_Time then - if Relative_Timed_Wait then - Request := To_Timespec (Rel_Time); - else - Request := To_Timespec (Abs_Time); - end if; - - Self_ID.Common.State := Delay_Sleep; - - loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - if Single_Lock then - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, Request'Access); - else - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Request'Access); - end if; - - exit when Abs_Time <= Monotonic_Clock; - - pragma Assert (Result = 0 - or else Result = ETIMEDOUT - or else Result = EINTR); - end loop; - - Self_ID.Common.State := Runnable; - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - Result := sched_yield; - SSL.Abort_Undefer.all; - end Timed_Delay; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration is - TS : aliased timespec; - Result : Interfaces.C.int; - begin - Result := clock_gettime - (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access); - pragma Assert (Result = 0); - return To_Duration (TS); - end Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - Res : aliased timespec; - Result : Interfaces.C.int; - begin - Result := clock_getres - (clock_id => CLOCK_REALTIME, Res => Res'Unchecked_Access); - pragma Assert (Result = 0); - return To_Duration (Res); - end RT_Resolution; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is - pragma Unreferenced (Reason); - Result : Interfaces.C.int; - begin - Result := pthread_cond_signal (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Wakeup; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - Result : Interfaces.C.int; - pragma Unreferenced (Result); - begin - if Do_Yield then - Result := sched_yield; - end if; - end Yield; - - ------------------ - -- Set_Priority -- - ------------------ - - procedure Set_OS_Priority (T : Task_ID; Prio : System.Any_Priority) is - Result : Interfaces.C.int; - Param : aliased struct_sched_param; - - begin - Param.sched_priority := Interfaces.C.int (Prio); - - if Time_Slice_Supported and then Time_Slice_Val > 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_RR, Param'Access); - - elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_FIFO, Param'Access); - - else - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_OTHER, Param'Access); - end if; - - pragma Assert (Result = 0); - end Set_OS_Priority; - - type Prio_Array_Type is array (System.Any_Priority) of Integer; - pragma Atomic_Components (Prio_Array_Type); - Prio_Array : Prio_Array_Type; - -- Comments needed for these declarations ??? - - procedure Set_Priority - (T : Task_ID; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) - is - Array_Item : Integer; - - begin - Set_OS_Priority (T, Prio); - - if Locking_Policy = 'C' then - -- Annex D requirements: loss of inheritance puts task at the - -- beginning of the queue for that prio; copied from 5ztaprop - -- (VxWorks) - - if Loss_Of_Inheritance - and then Prio < T.Common.Current_Priority then - - Array_Item := Prio_Array (T.Common.Base_Priority) + 1; - Prio_Array (T.Common.Base_Priority) := Array_Item; - - loop - Yield; - exit when Array_Item = Prio_Array (T.Common.Base_Priority) - or else Prio_Array (T.Common.Base_Priority) = 1; - end loop; - - Prio_Array (T.Common.Base_Priority) := - Prio_Array (T.Common.Base_Priority) - 1; - end if; - end if; - - T.Common.Current_Priority := Prio; - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_ID) return System.Any_Priority is - begin - return T.Common.Current_Priority; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (Self_ID : Task_ID) is - begin - Self_ID.Common.LL.Thread := pthread_self; - Self_ID.Common.LL.LWP := lwp_self; - - Specific.Set (Self_ID); - - Lock_RTS; - - for J in Known_Tasks'Range loop - if Known_Tasks (J) = null then - Known_Tasks (J) := Self_ID; - Self_ID.Known_Tasks_Index := J; - exit; - end if; - end loop; - - Unlock_RTS; - end Enter_Task; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_ID is - begin - if Is_Valid_Task then - return Self; - else - return Register_Foreign_Thread (pthread_self); - end if; - end Register_Foreign_Thread; - - ---------------------- - -- Initialize_TCB -- - ---------------------- - - procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is - Mutex_Attr : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - Cond_Attr : aliased pthread_condattr_t; - - begin - -- Give the task a unique serial number. - - Self_ID.Serial_Number := Next_Serial_Number; - Next_Serial_Number := Next_Serial_Number + 1; - pragma Assert (Next_Serial_Number /= 0); - - if not Single_Lock then - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, - Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result = 0 then - Succeeded := True; - else - if not Single_Lock then - Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Succeeded := False; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_ID; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - Attributes : aliased pthread_attr_t; - Adjusted_Stack_Size : Interfaces.C.size_t; - Result : Interfaces.C.int; - - use System.Task_Info; - - begin - if Stack_Size = Unspecified_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size); - - elsif Stack_Size < Minimum_Stack_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); - - else - Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); - end if; - - if Stack_Base_Available then - - -- If Stack Checking is supported then allocate 2 additional pages: - -- - -- In the worst case, stack is allocated at something like - -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages - -- to be sure the effective stack size is greater than what - -- has been asked. - - Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Get_Page_Size; - end if; - - Result := pthread_attr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_attr_setdetachstate - (Attributes'Access, PTHREAD_CREATE_DETACHED); - pragma Assert (Result = 0); - - Result := pthread_attr_setstacksize - (Attributes'Access, Adjusted_Stack_Size); - pragma Assert (Result = 0); - - if T.Common.Task_Info /= Default_Scope then - - -- We are assuming that Scope_Type has the same values than the - -- corresponding C macros - - Result := pthread_attr_setscope - (Attributes'Access, Task_Info_Type'Pos (T.Common.Task_Info)); - pragma Assert (Result = 0); - end if; - - -- Since the initial signal mask of a thread is inherited from the - -- creator, and the Environment task has all its signals masked, we - -- do not need to manipulate caller's signal mask at this point. - -- All tasks in RTS will have All_Tasks_Mask initially. - - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); - pragma Assert (Result = 0 or else Result = EAGAIN); - - Succeeded := Result = 0; - - Result := pthread_attr_destroy (Attributes'Access); - pragma Assert (Result = 0); - - Set_Priority (T, Priority); - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_ID) is - Result : Interfaces.C.int; - Tmp : Task_ID := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); - - begin - if not Single_Lock then - Result := pthread_mutex_destroy (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_cond_destroy (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - Free (Tmp); - - if Is_Self then - Result := st_setspecific (ATCB_Key, System.Null_Address); - pragma Assert (Result = 0); - end if; - - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - procedure Exit_Task is - begin - Specific.Set (null); - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_ID) is - Result : Interfaces.C.int; - begin - Result := pthread_kill (T.Common.LL.Thread, - Signal (System.Interrupt_Management.Abort_Task_Interrupt)); - pragma Assert (Result = 0); - end Abort_Task; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy versions - - function Check_Exit (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - begin - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - begin - return True; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_ID is - begin - return Environment_Task_ID; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean - is - pragma Unreferenced (T); - pragma Unreferenced (Thread_Self); - begin - return False; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) return Boolean - is - pragma Unreferenced (T); - pragma Unreferenced (Thread_Self); - begin - return False; - end Resume_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_ID) is - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - Tmp_Set : aliased sigset_t; - Result : Interfaces.C.int; - - function State - (Int : System.Interrupt_Management.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: - - 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 - Environment_Task_ID := Environment_Task; - - -- Initialize the lock used to synchronize chain of all ATCBs. - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - - Specific.Initialize (Environment_Task); - - Enter_Task (Environment_Task); - - -- Install the abort-signal handler - - if State (System.Interrupt_Management.Abort_Task_Interrupt) - /= Default - then - act.sa_flags := 0; - act.sa_handler := Abort_Handler'Address; - - Result := sigemptyset (Tmp_Set'Access); - pragma Assert (Result = 0); - act.sa_mask := Tmp_Set; - - Result := - sigaction - (Signal (System.Interrupt_Management.Abort_Task_Interrupt), - act'Unchecked_Access, - old_act'Unchecked_Access); - - pragma Assert (Result = 0); - end if; - end Initialize; - -begin - declare - Result : Interfaces.C.int; - - begin - -- Mask Environment task for all signals. The original mask of the - -- Environment task will be recovered by Interrupt_Server task - -- during the elaboration of s-interr.adb. - - System.Interrupt_Management.Operations.Set_Interrupt_Mask - (System.Interrupt_Management.Operations.All_Tasks_Mask'Access); - - -- Prepare the set of signals that should unblocked in all tasks - - Result := sigemptyset (Unblocked_Signal_Mask'Access); - pragma Assert (Result = 0); - - for J in Interrupt_Management.Interrupt_ID loop - if System.Interrupt_Management.Keep_Unmasked (J) then - Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); - pragma Assert (Result = 0); - end if; - end loop; - end; -end System.Task_Primitives.Operations; diff --git a/gcc/ada/56taspri.ads b/gcc/ada/56taspri.ads deleted file mode 100644 index bf079fd34a3..00000000000 --- a/gcc/ada/56taspri.ads +++ /dev/null @@ -1,97 +0,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 LynxOS version of this package, derived from --- 7staspri.ads - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with System.OS_Interface; --- used for pthread_mutex_t --- pthread_cond_t --- pthread_t - -package System.Task_Primitives is - - type Lock is limited private; - -- Should be used for implementation of protected objects. - - type RTS_Lock is limited private; - -- Should be used inside the runtime system. - -- The difference between Lock and the RTS_Lock is that the later - -- one serves only as a semaphore so that do not check for - -- ceiling violations. - - type Task_Body_Access is access procedure; - -- Pointer to the task body's entry point (or possibly a wrapper - -- declared local to the GNARL). - - type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task - -- basis. A component of this type is guaranteed to be included - -- in the Ada_Task_Control_Block. - -private - - type Lock is record - Mutex : aliased System.OS_Interface.pthread_mutex_t; - Ceiling : System.Any_Priority; - Saved_Priority : System.Any_Priority; - end record; - - type RTS_Lock is new System.OS_Interface.pthread_mutex_t; - - type Private_Data is record - Thread : aliased System.OS_Interface.pthread_t; - pragma Atomic (Thread); - -- Thread field may be updated by two different threads of control. - -- (See, Enter_Task and Create_Task in s-taprop.adb). - -- They put the same value (thr_self value). We do not want to - -- use lock on those operations and the only thing we have to - -- make sure is that they are updated in atomic fashion. - - 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; diff --git a/gcc/ada/56tpopsp.adb b/gcc/ada/56tpopsp.adb deleted file mode 100644 index 2673d0e30b6..00000000000 --- a/gcc/ada/56tpopsp.adb +++ /dev/null @@ -1,113 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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 a LynxOS 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 := st_keycreate (null, ATCB_Key'Access); - pragma Assert (Result = 0); - end Initialize; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean is - Result : Interfaces.C.int; - Value : aliased System.Address; - begin - Result := st_getspecific (ATCB_Key, Value'Address); - pragma Assert (Result = 0); - return (Value /= System.Null_Address); - end Is_Valid_Task; - - --------- - -- Set -- - --------- - - procedure Set (Self_Id : Task_ID) is - Result : Interfaces.C.int; - - begin - Result := st_setspecific (ATCB_Key, To_Address (Self_Id)); - pragma Assert (Result = 0); - end Set; - - ---------- - -- Self -- - ---------- - - -- To make Ada tasks and C threads interoperate better, we have added some - -- functionality to Self. Suppose a C main program (with threads) calls an - -- Ada procedure and the Ada procedure calls the tasking runtime system. - -- Eventually, a call will be made to self. Since the call is not coming - -- from an Ada task, there will be no corresponding ATCB. - - -- What we do in Self is to catch references that do not come from - -- recognized Ada tasks, and create an ATCB for the calling thread. - - -- The new ATCB will be "detached" from the normal Ada task master - -- hierarchy, much like the existing implicitly created signal-server - -- tasks. - - function Self return Task_ID is - Value : aliased System.Address; - - Result : Interfaces.C.int; - pragma Unreferenced (Result); - - begin - Result := st_getspecific (ATCB_Key, Value'Address); - -- Is it OK not to check this result??? - - -- If the key value is Null, then it is a non-Ada task. - - if Value /= System.Null_Address then - return To_Task_ID (Value); - else - return Register_Foreign_Thread; - end if; - end Self; - -end Specific; diff --git a/gcc/ada/57system.ads b/gcc/ada/57system.ads deleted file mode 100644 index caeae17a168..00000000000 --- a/gcc/ada/57system.ads +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (LynxOS PPC Version) -- --- -- --- 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 := 0.01; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 254; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 254; - subtype Interrupt_Priority is Any_Priority range 255 .. 255; - - Default_Priority : constant Priority := 15; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := False; - 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 := True; - -end System; diff --git a/gcc/ada/58system.ads b/gcc/ada/58system.ads deleted file mode 100644 index 130b5f0d451..00000000000 --- a/gcc/ada/58system.ads +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (LynxOS x86 Version) -- --- -- --- 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 := 0.01; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 254; - Max_Interrupt_Priority : constant Positive := 255; - - subtype Any_Priority is Integer range 0 .. 255; - subtype Priority is Any_Priority range 0 .. 254; - subtype Interrupt_Priority is Any_Priority range 255 .. 255; - - Default_Priority : constant Priority := 15; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := False; - 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 := True; - -end System; diff --git a/gcc/ada/5amastop.adb b/gcc/ada/5amastop.adb deleted file mode 100644 index 956efa4e553..00000000000 --- a/gcc/ada/5amastop.adb +++ /dev/null @@ -1,181 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- SYSTEM.MACHINE_STATE_OPERATIONS -- --- -- --- B o d y -- --- (Version for Alpha/Dec Unix) -- --- -- --- 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 of System.Machine_State_Operations is for use on --- Alpha systems running DEC Unix. - -with System.Memory; - -package body System.Machine_State_Operations is - - use System.Exceptions; - - pragma Linker_Options ("-lexc"); - -- Needed for definitions of exc_capture_context and exc_virtual_unwind - - ---------------------------- - -- Allocate_Machine_State -- - ---------------------------- - - function Allocate_Machine_State return Machine_State is - use System.Storage_Elements; - - function c_machine_state_length return Storage_Offset; - pragma Import (C, c_machine_state_length, "__gnat_machine_state_length"); - - begin - return Machine_State - (Memory.Alloc (Memory.size_t (c_machine_state_length))); - end Allocate_Machine_State; - - ------------------- - -- Enter_Handler -- - ------------------- - - procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is - procedure c_enter_handler (M : Machine_State; Handler : Handler_Loc); - pragma Import (C, c_enter_handler, "__gnat_enter_handler"); - - begin - c_enter_handler (M, Handler); - end Enter_Handler; - - ---------------- - -- Fetch_Code -- - ---------------- - - function Fetch_Code (Loc : Code_Loc) return Code_Loc is - begin - return Loc; - end Fetch_Code; - - ------------------------ - -- Free_Machine_State -- - ------------------------ - - procedure Free_Machine_State (M : in out Machine_State) is - begin - Memory.Free (Address (M)); - M := Machine_State (Null_Address); - end Free_Machine_State; - - ------------------ - -- Get_Code_Loc -- - ------------------ - - function Get_Code_Loc (M : Machine_State) return Code_Loc is - Asm_Call_Size : constant := 4; - - function c_get_code_loc (M : Machine_State) return Code_Loc; - pragma Import (C, c_get_code_loc, "__gnat_get_code_loc"); - - -- Code_Loc returned by c_get_code_loc is the return point but here we - -- want Get_Code_Loc to return the call point. Under DEC Unix a call - -- asm instruction takes 4 bytes. So we must remove this value from - -- c_get_code_loc to have the call point. - - Loc : constant Code_Loc := c_get_code_loc (M); - - begin - if Loc = 0 then - return 0; - else - return Loc - Asm_Call_Size; - end if; - end Get_Code_Loc; - - -------------------------- - -- Machine_State_Length -- - -------------------------- - - function Machine_State_Length - return System.Storage_Elements.Storage_Offset - is - use System.Storage_Elements; - - function c_machine_state_length return Storage_Offset; - pragma Import (C, c_machine_state_length, "__gnat_machine_state_length"); - - begin - return c_machine_state_length; - end Machine_State_Length; - - --------------- - -- Pop_Frame -- - --------------- - - procedure Pop_Frame - (M : Machine_State; - Info : Subprogram_Info_Type) - is - pragma Warnings (Off, Info); - - procedure exc_virtual_unwind - (Fcn : System.Address; - M : Machine_State); - pragma Import (C, exc_virtual_unwind, "exc_virtual_unwind"); - - begin - exc_virtual_unwind (System.Null_Address, M); - end Pop_Frame; - - ----------------------- - -- Set_Machine_State -- - ----------------------- - - procedure Set_Machine_State (M : Machine_State) is - procedure c_capture_context (M : Machine_State); - pragma Import (C, c_capture_context, "exc_capture_context"); - - begin - c_capture_context (M); - Pop_Frame (M, System.Null_Address); - end Set_Machine_State; - - ------------------------------ - -- Set_Signal_Machine_State -- - ------------------------------ - - procedure Set_Signal_Machine_State - (M : Machine_State; - Context : System.Address) - is - pragma Warnings (Off, M); - pragma Warnings (Off, Context); - - begin - null; - end Set_Signal_Machine_State; - -end System.Machine_State_Operations; diff --git a/gcc/ada/5aml-tgt.adb b/gcc/ada/5aml-tgt.adb deleted file mode 100644 index 2474da3ea84..00000000000 --- a/gcc/ada/5aml-tgt.adb +++ /dev/null @@ -1,380 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T -- --- (True64 Version) -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-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. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a set of target dependent routines to build --- static, dynamic and shared libraries. - --- This is the True64 version of the body. - -with MLib.Fil; -with MLib.Utl; -with Namet; use Namet; -with Opt; -with Output; use Output; -with Prj.Com; -with System; - -package body MLib.Tgt is - - use GNAT; - use MLib; - - Expect_Unresolved : aliased String := "-Wl,-expect_unresolved,*"; - - No_Arguments : aliased Argument_List := (1 .. 0 => null); - Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; - - Wl_Init_String : aliased String := "-Wl,-init"; - Wl_Init : constant String_Access := Wl_Init_String'Access; - Wl_Fini_String : aliased String := "-Wl,-fini"; - Wl_Fini : constant String_Access := Wl_Fini_String'Access; - - Init_Fini_List : constant Argument_List_Access := - new Argument_List'(1 => Wl_Init, - 2 => null, - 3 => Wl_Fini, - 4 => null); - -- Used to put switches for automatic elaboration/finalization - - --------------------- - -- Archive_Builder -- - --------------------- - - function Archive_Builder return String is - begin - return "ar"; - end Archive_Builder; - - ----------------------------- - -- Archive_Builder_Options -- - ----------------------------- - - function Archive_Builder_Options return String_List_Access is - begin - return new String_List'(1 => new String'("cr")); - end Archive_Builder_Options; - - ----------------- - -- Archive_Ext -- - ----------------- - - function Archive_Ext return String is - begin - return "a"; - end Archive_Ext; - - --------------------- - -- Archive_Indexer -- - --------------------- - - function Archive_Indexer return String is - begin - return "ranlib"; - end Archive_Indexer; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Foreign : Argument_List; - Afiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Address : String := ""; - Lib_Version : String := ""; - Relocatable : Boolean := False; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Foreign); - pragma Unreferenced (Afiles); - pragma Unreferenced (Interfaces); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Lib_Address); - pragma Unreferenced (Relocatable); - - Lib_File : constant String := - Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Filename, DLL_Ext); - - Version_Arg : String_Access; - Symbolic_Link_Needed : Boolean := False; - - Init_Fini : Argument_List_Access := Empty_Argument_List; - - begin - if Opt.Verbose_Mode then - Write_Str ("building relocatable shared library "); - Write_Line (Lib_File); - end if; - - -- If specified, add automatic elaboration/finalization - - if Auto_Init then - Init_Fini := Init_Fini_List; - Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init"); - Init_Fini (4) := new String'("-Wl," & Lib_Filename & "final"); - end if; - - if Lib_Version = "" then - Utl.Gcc - (Output_File => Lib_File, - Objects => Ofiles, - Options => - Options & - Expect_Unresolved'Access & - Init_Fini.all, - Driver_Name => Driver_Name); - - else - Version_Arg := new String'("-Wl,-soname," & Lib_Version); - - if Is_Absolute_Path (Lib_Version) then - Utl.Gcc - (Output_File => Lib_Version, - Objects => Ofiles, - Options => - Options & - Version_Arg & - Expect_Unresolved'Access & - Init_Fini.all, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := Lib_Version /= Lib_File; - - else - Utl.Gcc - (Output_File => Lib_Dir & Directory_Separator & Lib_Version, - Objects => Ofiles, - Options => - Options & - Version_Arg & - Expect_Unresolved'Access & - Init_Fini.all, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := - Lib_Dir & Directory_Separator & Lib_Version /= Lib_File; - end if; - - if Symbolic_Link_Needed then - declare - Success : Boolean; - Oldpath : String (1 .. Lib_Version'Length + 1); - Newpath : String (1 .. Lib_File'Length + 1); - - Result : Integer; - pragma Unreferenced (Result); - - function Symlink - (Oldpath : System.Address; - Newpath : System.Address) - return Integer; - pragma Import (C, Symlink, "__gnat_symlink"); - - begin - Oldpath (1 .. Lib_Version'Length) := Lib_Version; - Oldpath (Oldpath'Last) := ASCII.NUL; - Newpath (1 .. Lib_File'Length) := Lib_File; - Newpath (Newpath'Last) := ASCII.NUL; - - Delete_File (Lib_File, Success); - - Result := Symlink (Oldpath'Address, Newpath'Address); - end; - end if; - end if; - end Build_Dynamic_Library; - - ------------------------- - -- Default_DLL_Address -- - ------------------------- - - function Default_DLL_Address return String is - begin - return ""; - end Default_DLL_Address; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return "so"; - end DLL_Ext; - - -------------------- - -- Dynamic_Option -- - -------------------- - - function Dynamic_Option return String is - begin - return "-shared"; - end Dynamic_Option; - - ------------------- - -- Is_Object_Ext -- - ------------------- - - function Is_Object_Ext (Ext : String) return Boolean is - begin - return Ext = ".o"; - end Is_Object_Ext; - - -------------- - -- Is_C_Ext -- - -------------- - - function Is_C_Ext (Ext : String) return Boolean is - begin - return Ext = ".c"; - end Is_C_Ext; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".a" or else Ext = ".so"; - end Is_Archive_Ext; - - ------------- - -- Libgnat -- - ------------- - - function Libgnat return String is - begin - return "libgnat.a"; - end Libgnat; - - ------------------------ - -- Library_Exists_For -- - ------------------------ - - function Library_Exists_For (Project : Project_Id) return Boolean is - begin - if not Projects.Table (Project).Library then - Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & - "for non library project"); - return False; - - else - declare - Lib_Dir : constant String := - Get_Name_String (Projects.Table (Project).Library_Dir); - Lib_Name : constant String := - Get_Name_String (Projects.Table (Project).Library_Name); - - begin - if Projects.Table (Project).Library_Kind = Static then - return Is_Regular_File - (Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - return Is_Regular_File - (Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - end; - end if; - end Library_Exists_For; - - --------------------------- - -- Library_File_Name_For -- - --------------------------- - - function Library_File_Name_For (Project : Project_Id) return Name_Id is - begin - if not Projects.Table (Project).Library then - Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & - "for non library project"); - return No_Name; - - else - declare - Lib_Name : constant String := - Get_Name_String (Projects.Table (Project).Library_Name); - - begin - Name_Len := 3; - Name_Buffer (1 .. Name_Len) := "lib"; - - if Projects.Table (Project).Library_Kind = Static then - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - - return Name_Find; - end; - end if; - end Library_File_Name_For; - - ---------------- - -- Object_Ext -- - ---------------- - - function Object_Ext return String is - begin - return "o"; - end Object_Ext; - - ---------------- - -- PIC_Option -- - ---------------- - - function PIC_Option return String is - begin - return ""; - end PIC_Option; - - ----------------------------------------------- - -- Standalone_Library_Auto_Init_Is_Supported -- - ----------------------------------------------- - - function Standalone_Library_Auto_Init_Is_Supported return Boolean is - begin - return True; - end Standalone_Library_Auto_Init_Is_Supported; - - --------------------------- - -- Support_For_Libraries -- - --------------------------- - - function Support_For_Libraries return Library_Support is - begin - return Full; - end Support_For_Libraries; - -end MLib.Tgt; diff --git a/gcc/ada/5aosinte.adb b/gcc/ada/5aosinte.adb deleted file mode 100644 index e0b683e52cd..00000000000 --- a/gcc/ada/5aosinte.adb +++ /dev/null @@ -1,135 +0,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) 1998-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 the DEC Unix version of this package. - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with Interfaces.C; use Interfaces.C; -with System.Machine_Code; use System.Machine_Code; - -package body System.OS_Interface is - - ------------------ - -- pthread_init -- - ------------------ - - procedure pthread_init is - begin - null; - end pthread_init; - - ------------------ - -- pthread_self -- - ------------------ - - function pthread_self return pthread_t is - Self : pthread_t; - begin - Asm ("call_pal 0x9e" & ASCII.LF & ASCII.HT & - "bis $31, $0, %0", - Outputs => pthread_t'Asm_Output ("=r", Self), - Clobber => "$0"); - return Self; - end pthread_self; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (TS : timespec) return Duration is - begin - return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; - end To_Duration; - - function To_Duration (TV : struct_timeval) return Duration is - begin - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end To_Duration; - - ----------------- - -- To_Timespec -- - ----------------- - - function To_Timespec (D : Duration) return timespec is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return timespec'(tv_sec => S, - tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); - end To_Timespec; - - ---------------- - -- To_Timeval -- - ---------------- - - function To_Timeval (D : Duration) return struct_timeval is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return - struct_timeval' - (tv_sec => S, - tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); - end To_Timeval; - -end System.OS_Interface; diff --git a/gcc/ada/5aosinte.ads b/gcc/ada/5aosinte.ads deleted file mode 100644 index dc01b058343..00000000000 --- a/gcc/ada/5aosinte.ads +++ /dev/null @@ -1,539 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 DEC Unix 4.0/5.1 version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-lpthread"); - pragma Linker_Options ("-lmach"); - pragma Linker_Options ("-lexc"); - pragma Linker_Options ("-lrt"); - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - subtype char_array is Interfaces.C.char_array; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "_Geterrno"); - - EAGAIN : constant := 35; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIMEDOUT : constant := 60; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 48; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGIOT : constant := 6; -- abort (terminate) process - SIGLOST : constant := 6; -- old BSD signal ?? - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGURG : constant := 16; -- urgent condition on IO channel - SIGIOINT : constant := 16; -- printer to backend error signal - SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 18; -- user stop requested from tty - SIGCONT : constant := 19; -- stopped process has been continued - SIGCHLD : constant := 20; -- child status change - SIGTTIN : constant := 21; -- background tty read attempted - SIGTTOU : constant := 22; -- background tty write attempted - SIGPOLL : constant := 23; -- I/O possible, or completed - SIGIO : constant := 23; -- STREAMS version of SIGPOLL - SIGAIO : constant := 23; -- base lan i/o - SIGPTY : constant := 23; -- pty i/o - SIGXCPU : constant := 24; -- CPU time limit exceeded - SIGXFSZ : constant := 25; -- filesize limit exceeded - SIGVTALRM : constant := 26; -- virtual timer expired - SIGPROF : constant := 27; -- profiling timer expired - SIGWINCH : constant := 28; -- window size change - SIGINFO : constant := 29; -- information request - SIGPWR : constant := 29; -- Power Fail/Restart -- SVID3/SVR4 - SIGUSR1 : constant := 30; -- user defined signal 1 - SIGUSR2 : constant := 31; -- user defined signal 2 - SIGRESV : constant := 32; -- reserved by Digital for future use - - SIGADAABORT : constant := SIGABRT; - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := (0 .. 0 => SIGTRAP); - Reserved : constant Signal_Set := (SIGALRM, SIGABRT, SIGKILL, SIGSTOP); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset); - - type union_type_3 is new String (1 .. 116); - type siginfo_t is record - si_signo : int; - si_errno : int; - si_code : int; - X_data : union_type_3; - end record; - for siginfo_t'Size use 8 * 128; - pragma Convention (C, siginfo_t); - - type struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : int; - sa_signo : int; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - SIG_BLOCK : constant := 1; - SIG_UNBLOCK : constant := 2; - SIG_SETMASK : constant := 3; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - SA_NODEFER : constant := 8; - SA_SIGINFO : constant := 16#40#; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction); - - ---------- - -- Time -- - ---------- - - type timespec is private; - - function nanosleep (rqtp, rmtp : access timespec) return int; - pragma Import (C, nanosleep); - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; - pragma Import (C, clock_gettime); - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timezone is record - tz_minuteswest : int; - tz_dsttime : int; - end record; - pragma Convention (C, struct_timezone); - type struct_timeval is private; - -- This is needed on systems that do not have clock_gettime() - -- but do have gettimeofday(). - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 1; - SCHED_RR : constant := 2; - SCHED_OTHER : constant := 3; - SCHED_LFI : constant := 5; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill); - - function getpid return pid_t; - pragma Import (C, getpid); - - BIND_NO_INHERIT : constant := 1; - - function bind_to_cpu - (pid : pid_t; - cpu_mask : unsigned_long; - flag : unsigned_long := BIND_NO_INHERIT) return int; - pragma Import (C, bind_to_cpu); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 1; - - PTHREAD_SCOPE_PROCESS : constant := 0; - PTHREAD_SCOPE_SYSTEM : constant := 1; - - PTHREAD_EXPLICIT_SCHED : constant := 1; - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - procedure pthread_init; - pragma Inline (pthread_init); - -- This is a dummy procedure to share some GNULLI files - - --------------------------- - -- POSIX.1c Section 3 -- - --------------------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) return int; - pragma Import (C, sigwait, "__sigwaitd10"); - - function pthread_kill - (thread : pthread_t; - sig : Signal) return int; - pragma Import (C, pthread_kill); - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask); - - ---------------------------- - -- POSIX.1c Section 11 -- - ---------------------------- - - function pthread_mutexattr_init (attr : access pthread_mutexattr_t) - return int; - pragma Import (C, pthread_mutexattr_init); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "__pthread_mutex_init"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "__pthread_mutex_destroy"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_lock, "__pthread_mutex_lock"); - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_unlock, "__pthread_mutex_unlock"); - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "__pthread_cond_init"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "__pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "__pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait, "__pthread_cond_wait"); - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - pragma Import (C, pthread_cond_timedwait, "__pthread_cond_timedwait"); - - ---------------------------- - -- POSIX.1c Section 13 -- - ---------------------------- - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol); - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int; - pragma Import (C, pthread_mutexattr_setprioceiling); - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Import (C, pthread_setschedparam); - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import (C, pthread_attr_setinheritsched, - "__pthread_attr_setinheritsched"); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy); - - function pthread_attr_setschedparam - (attr : access pthread_attr_t; - sched_param : access struct_sched_param) return int; - pragma Import (C, pthread_attr_setschedparam); - - function sched_yield return int; - pragma Import (C, sched_yield); - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) - return int; - pragma Import (C, pthread_attr_init); - - function pthread_attr_destroy (attributes : access pthread_attr_t) - return int; - pragma Import (C, pthread_attr_destroy); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Import (C, pthread_attr_setdetachstate); - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize, "__pthread_attr_setstacksize"); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "__pthread_create"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "__pthread_exit"); - - function pthread_self return pthread_t; - pragma Inline (pthread_self); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; value : System.Address) return int; - pragma Import (C, pthread_setspecific, "__pthread_setspecific"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Import (C, pthread_getspecific, "__pthread_getspecific"); - - type destructor_pointer is access procedure (arg : System.Address); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create); - -private - - type sigset_t is new unsigned_long; - - type pid_t is new int; - - type time_t is new int; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 1; - - type struct_timeval is record - tv_sec : time_t; - tv_usec : time_t; - end record; - pragma Convention (C, struct_timeval); - - type unsigned_long_array is array (Natural range <>) of unsigned_long; - - type pthread_t is new System.Address; - - type pthread_cond_t is record - state : unsigned; - valid : unsigned; - name : System.Address; - arg : unsigned; - reserved1 : unsigned; - sequence : unsigned_long; - block : System.Address; - end record; - pragma Convention (C, pthread_cond_t); - - type pthread_attr_t is record - valid : long; - name : System.Address; - arg : unsigned_long; - reserved : unsigned_long_array (0 .. 18); - end record; - pragma Convention (C, pthread_attr_t); - - type pthread_mutex_t is record - lock : unsigned; - valid : unsigned; - name : System.Address; - arg : unsigned; - depth : unsigned; - sequence : unsigned_long; - owner : unsigned_long; - block : System.Address; - end record; - for pthread_mutex_t'Size use 8 * 48; - pragma Convention (C, pthread_mutex_t); - - type pthread_mutexattr_t is record - valid : long; - reserved : unsigned_long_array (0 .. 14); - end record; - pragma Convention (C, pthread_mutexattr_t); - - type pthread_condattr_t is record - valid : long; - reserved : unsigned_long_array (0 .. 12); - end record; - pragma Convention (C, pthread_condattr_t); - - type pthread_key_t is new unsigned; - -end System.OS_Interface; diff --git a/gcc/ada/5asystem.ads b/gcc/ada/5asystem.ads deleted file mode 100644 index f0067b37f84..00000000000 --- a/gcc/ada/5asystem.ads +++ /dev/null @@ -1,221 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (DEC Unix Version) -- --- -- --- 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 / 1024.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) - - Max_Priority : constant Positive := 60; - Max_Interrupt_Priority : constant Positive := 63; - - subtype Any_Priority is Integer range 0 .. 63; - subtype Priority is Any_Priority range 0 .. 60; - subtype Interrupt_Priority is Any_Priority range 61 .. 63; - - Default_Priority : constant Priority := 30; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := False; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := True; - Stack_Check_Probes : constant Boolean := True; - 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 := False; - ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; - 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 := True; - - -- Note: Denorm is False because denormals are only handled properly - -- if the -mieee switch is set, and we do not require this usage. - - --------------------------- - -- Underlying Priorities -- - --------------------------- - - -- Important note: this section of the file must come AFTER the - -- definition of the system implementation parameters to ensure - -- that the value of these parameters is available for analysis - -- of the declarations here (using Rtsfind at compile time). - - -- The underlying priorities table provides a generalized mechanism - -- for mapping from Ada priorities to system priorities. In some - -- cases a 1-1 mapping is not the convenient or optimal choice. - - -- For Dec Unix 4.0d, we use a default 1-to-1 mapping that provides - -- the full range of 64 priorities available from the operating system. - - -- On DU prior to 4.0d, less than 64 priorities are available so there - -- are two possibilities: - - -- Limit your range of priorities to the range provided by the - -- OS (e.g 16 .. 32 on 4.0b) - - -- Replace the standard table as described below - - -- To replace the default values of the Underlying_Priorities mapping, - -- copy this source file into your build directory, edit the file to - -- reflect your desired behavior, and recompile with the command: - - -- $ gcc -c -O3 -gnatpgn system.ads - - -- then recompile the run-time parts that depend on this package: - - -- $ gnatmake -a -gnatn -O3 - - -- then force rebuilding your application if you need different options: - - -- $ gnatmake -f - - type Priorities_Mapping is array (Any_Priority) of Integer; - pragma Suppress_Initialization (Priorities_Mapping); - -- Suppress initialization in case gnat.adc specifies Normalize_Scalars - - Underlying_Priorities : constant Priorities_Mapping := - - (Priority'First => 0, - - 1 => 1, 2 => 2, 3 => 3, 4 => 4, 5 => 5, - 6 => 6, 7 => 7, 8 => 8, 9 => 9, 10 => 10, - 11 => 11, 12 => 12, 13 => 13, 14 => 14, 15 => 15, - 16 => 16, 17 => 17, 18 => 18, 19 => 19, 20 => 20, - 21 => 21, 22 => 22, 23 => 23, 24 => 24, 25 => 25, - 26 => 26, 27 => 27, 28 => 28, 29 => 29, - - Default_Priority => 30, - - 31 => 31, 32 => 32, 33 => 33, 34 => 34, 35 => 35, - 36 => 36, 37 => 37, 38 => 38, 39 => 39, 40 => 40, - 41 => 41, 42 => 42, 43 => 43, 44 => 44, 45 => 45, - 46 => 46, 47 => 47, 48 => 48, 49 => 49, 50 => 50, - 51 => 51, 52 => 52, 53 => 53, 54 => 54, 55 => 55, - 56 => 56, 57 => 57, 58 => 58, 59 => 59, - - Priority'Last => 60, - - 61 => 61, 62 => 62, - - Interrupt_Priority'Last => 63); - -end System; diff --git a/gcc/ada/5ataprop.adb b/gcc/ada/5ataprop.adb deleted file mode 100644 index 1fa1c22fa4b..00000000000 --- a/gcc/ada/5ataprop.adb +++ /dev/null @@ -1,1136 +0,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 . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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 a DEC Unix 4.0d version of this package - --- This package contains all the GNULL primitives that interface directly --- with the underlying OS. - -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.Tasking.Debug; --- used for Known_Tasks - -with System.Task_Info; --- used for Task_Info_Type - -with Interfaces; --- used for Shift_Left - -with Interfaces.C; --- used for int --- size_t - -with System.Interrupt_Management; --- used for Keep_Unmasked --- Abort_Task_Interrupt --- Interrupt_ID - -with System.Interrupt_Management.Operations; --- used for Set_Interrupt_Mask --- All_Tasks_Mask -pragma Elaborate_All (System.Interrupt_Management.Operations); - -with System.Parameters; --- used for Size_Type - -with System.Tasking; --- used for Ada_Task_Control_Block --- Task_ID --- ATCB components and types - -with System.Soft_Links; --- used for Defer/Undefer_Abort - --- Note that we do not use System.Tasking.Initialization directly since --- this is a higher level package that we shouldn't depend on. For example --- when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Initialization - -with System.OS_Primitives; --- used for Delay_Modes - -with Unchecked_Deallocation; - -package body System.Task_Primitives.Operations is - - use System.Tasking.Debug; - use System.Tasking; - use Interfaces.C; - use System.OS_Interface; - use System.Parameters; - use System.OS_Primitives; - - package SSL renames System.Soft_Links; - - ---------------- - -- Local Data -- - ---------------- - - -- The followings are logically constants, but need to be initialized - -- at run time. - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_ID associated with a thread - - Environment_Task_ID : Task_ID; - -- A variable to hold Task_ID for the environment task. - - Unblocked_Signal_Mask : aliased sigset_t; - -- The set of signals that should unblocked in all tasks - - Time_Slice_Val : Integer; - pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - - Locking_Policy : Character; - pragma Import (C, Locking_Policy, "__gl_locking_policy"); - - Dispatching_Policy : Character; - pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - - FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; - -- Indicates whether FIFO_Within_Priorities is set. - - Curpid : pid_t; - - Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads). - - -------------------- - -- Local Packages -- - -------------------- - - package Specific is - - procedure Initialize (Environment_Task : Task_ID); - pragma Inline (Initialize); - -- Initialize various data needed by this package. - - function Is_Valid_Task return Boolean; - pragma Inline (Is_Valid_Task); - -- Does executing thread have a TCB? - - procedure Set (Self_Id : Task_ID); - pragma Inline (Set); - -- Set the self id for the current task. - - function Self return Task_ID; - pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task. - - end Specific; - - package body Specific is separate; - -- The body of this package is target specific. - - --------------------------------- - -- Support for foreign threads -- - --------------------------------- - - function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; - -- Allocate and Initialize a new ATCB for the current Thread. - - function Register_Foreign_Thread - (Thread : Thread_Id) return Task_ID is separate; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Abort_Handler (Sig : Signal); - -- Signal handler used to implement asynchronous abortion. - - ------------------- - -- Abort_Handler -- - ------------------- - - procedure Abort_Handler (Sig : Signal) is - pragma Unreferenced (Sig); - - T : constant Task_ID := Self; - Result : Interfaces.C.int; - Old_Set : aliased sigset_t; - - begin - -- It is not safe to raise an exception when using ZCX and the GCC - -- exception handling mechanism. - - if ZCX_By_Default and then GCC_ZCX_Support then - return; - end if; - - if T.Deferral_Level = 0 - and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then - not T.Aborting - then - T.Aborting := True; - - -- Make sure signals used for RTS internal purpose are unmasked - - Result := pthread_sigmask (SIG_UNBLOCK, - Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); - pragma Assert (Result = 0); - - raise Standard'Abort_Signal; - end if; - end Abort_Handler; - - ------------------ - -- Stack_Guard -- - ------------------ - - -- The underlying thread system sets a guard page at the - -- bottom of a thread stack, so nothing is needed. - - procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is - pragma Unreferenced (T); - pragma Unreferenced (On); - - begin - null; - end Stack_Guard; - - -------------------- - -- Get_Thread_Id -- - -------------------- - - function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_ID renames Specific.Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Initialize_TCB and the Storage_Error is - -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) - -- used in RTS is initialized before any status change of RTS. - -- Therefore rasing Storage_Error in the following routines - -- should be able to be handled safely. - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : access Lock) - is - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - if Locking_Policy = 'C' then - L.Ceiling := Interfaces.C.int (Prio); - end if; - - Result := pthread_mutex_init (L.L'Access, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Attributes'Access); - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is - pragma Unreferenced (Level); - - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutex_init (L, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Attributes'Access); - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L.L'Access); - pragma Assert (Result = 0); - end Finalize_Lock; - - procedure Finalize_Lock (L : access RTS_Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0); - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - Result : Interfaces.C.int; - Self_ID : Task_ID; - All_Tasks_Link : Task_ID; - Current_Prio : System.Any_Priority; - - begin - -- Perform ceiling checks only when this is the locking policy in use. - - if Locking_Policy = 'C' then - Self_ID := Self; - All_Tasks_Link := Self_ID.Common.All_Tasks_Link; - Current_Prio := Get_Priority (Self_ID); - - -- If there is no other task, no need to check priorities - - if All_Tasks_Link /= Null_Task - and then L.Ceiling < Interfaces.C.int (Current_Prio) - then - Ceiling_Violation := True; - return; - end if; - end if; - - Result := pthread_mutex_lock (L.L'Access); - pragma Assert (Result = 0); - - Ceiling_Violation := False; - end Write_Lock; - - procedure Write_Lock - (L : access RTS_Lock; Global_Lock : Boolean := False) - is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_lock (L); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - procedure Write_Lock (T : Task_ID) is - Result : Interfaces.C.int; - begin - if not Single_Lock then - Result := pthread_mutex_lock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - begin - Write_Lock (L, Ceiling_Violation); - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_unlock (L.L'Access); - pragma Assert (Result = 0); - end Unlock; - - procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); - end if; - end Unlock; - - procedure Unlock (T : Task_ID) is - Result : Interfaces.C.int; - begin - if not Single_Lock then - Result := pthread_mutex_unlock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Unlock; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : Task_ID; - Reason : System.Tasking.Task_States) - is - pragma Unreferenced (Reason); - - Result : Interfaces.C.int; - - begin - if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; - - -- EINTR is not considered a failure. - - pragma Assert (Result = 0 or else Result = EINTR); - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - -- This is for use within the run-time system, so abort is - -- assumed to be already deferred, and the caller should be - -- holding its own ATCB lock. - - procedure Timed_Sleep - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : System.Tasking.Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Unreferenced (Reason); - - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - Timedout := True; - Yielded := False; - - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; - - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); - - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; - - if Single_Lock then - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, - Request'Access); - - else - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, - Request'Access); - end if; - - exit when Abs_Time <= Monotonic_Clock; - - if Result = 0 or Result = EINTR then - - -- Somebody may have called Wakeup for us - - Timedout := False; - exit; - end if; - - pragma Assert (Result = ETIMEDOUT); - end loop; - end if; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - -- This is for use in implementing delay statements, so - -- we assume the caller is abort-deferred but is holding - -- no locks. - - procedure Timed_Delay - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes) - is - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - -- Only the little window between deferring abort and - -- locking Self_ID is the reason we need to - -- check for pending abort and priority change below! :( - - SSL.Abort_Defer.all; - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - - if Mode = Relative then - Abs_Time := Time + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; - - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); - Self_ID.Common.State := Delay_Sleep; - - loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - if Single_Lock then - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, - Request'Access); - else - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Request'Access); - end if; - - exit when Abs_Time <= Monotonic_Clock; - - pragma Assert (Result = 0 or else - Result = ETIMEDOUT or else - Result = EINTR); - end loop; - - Self_ID.Common.State := Runnable; - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - Yield; - SSL.Abort_Undefer.all; - end Timed_Delay; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration is - TS : aliased timespec; - Result : Interfaces.C.int; - - begin - Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); - pragma Assert (Result = 0); - return To_Duration (TS); - end Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - begin - return 1.0 / 1024.0; -- Clock on DEC Alpha ticks at 1024 Hz - end RT_Resolution; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is - pragma Unreferenced (Reason); - Result : Interfaces.C.int; - begin - Result := pthread_cond_signal (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Wakeup; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - Result : Interfaces.C.int; - pragma Unreferenced (Result); - begin - if Do_Yield then - Result := sched_yield; - end if; - end Yield; - - ------------------ - -- Set_Priority -- - ------------------ - - procedure Set_Priority - (T : Task_ID; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) - is - pragma Unreferenced (Loss_Of_Inheritance); - - Result : Interfaces.C.int; - Param : aliased struct_sched_param; - - begin - T.Common.Current_Priority := Prio; - Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); - - if Time_Slice_Val > 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_RR, Param'Access); - - elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_FIFO, Param'Access); - - else - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_OTHER, Param'Access); - end if; - - pragma Assert (Result = 0); - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_ID) return System.Any_Priority is - begin - return T.Common.Current_Priority; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (Self_ID : Task_ID) is - begin - Self_ID.Common.LL.Thread := pthread_self; - Specific.Set (Self_ID); - - Lock_RTS; - - for J in Known_Tasks'Range loop - if Known_Tasks (J) = null then - Known_Tasks (J) := Self_ID; - Self_ID.Known_Tasks_Index := J; - exit; - end if; - end loop; - - Unlock_RTS; - end Enter_Task; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_ID is - begin - if Is_Valid_Task then - return Self; - else - return Register_Foreign_Thread (pthread_self); - end if; - end Register_Foreign_Thread; - - -------------------- - -- Initialize_TCB -- - -------------------- - - procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is - Mutex_Attr : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - Cond_Attr : aliased pthread_condattr_t; - - begin - if not Single_Lock then - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := pthread_mutex_init - (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := pthread_cond_init - (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result = 0 then - Succeeded := True; - else - if not Single_Lock then - Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Succeeded := False; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_ID; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - Attributes : aliased pthread_attr_t; - Adjusted_Stack_Size : Interfaces.C.size_t; - Result : Interfaces.C.int; - Param : aliased System.OS_Interface.struct_sched_param; - - use System.Task_Info; - - begin - if Stack_Size = Unspecified_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size); - - elsif Stack_Size < Minimum_Stack_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); - - else - Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); - end if; - - Result := pthread_attr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_attr_setdetachstate - (Attributes'Access, PTHREAD_CREATE_DETACHED); - pragma Assert (Result = 0); - - Result := pthread_attr_setstacksize - (Attributes'Access, Adjusted_Stack_Size); - pragma Assert (Result = 0); - - Param.sched_priority := - Interfaces.C.int (Underlying_Priorities (Priority)); - Result := pthread_attr_setschedparam - (Attributes'Access, Param'Access); - pragma Assert (Result = 0); - - if Time_Slice_Val > 0 then - Result := pthread_attr_setschedpolicy - (Attributes'Access, System.OS_Interface.SCHED_RR); - - elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then - Result := pthread_attr_setschedpolicy - (Attributes'Access, System.OS_Interface.SCHED_FIFO); - - else - Result := pthread_attr_setschedpolicy - (Attributes'Access, System.OS_Interface.SCHED_OTHER); - end if; - - pragma Assert (Result = 0); - - -- Set the scheduling parameters explicitly, since this is the - -- only way to force the OS to take e.g. the sched policy and scope - -- attributes into account. - - Result := pthread_attr_setinheritsched - (Attributes'Access, PTHREAD_EXPLICIT_SCHED); - pragma Assert (Result = 0); - - T.Common.Current_Priority := Priority; - - if T.Common.Task_Info /= null then - case T.Common.Task_Info.Contention_Scope is - when System.Task_Info.Process_Scope => - Result := pthread_attr_setscope - (Attributes'Access, PTHREAD_SCOPE_PROCESS); - - when System.Task_Info.System_Scope => - Result := pthread_attr_setscope - (Attributes'Access, PTHREAD_SCOPE_SYSTEM); - - when System.Task_Info.Default_Scope => - Result := 0; - end case; - - pragma Assert (Result = 0); - end if; - - -- Since the initial signal mask of a thread is inherited from the - -- creator, and the Environment task has all its signals masked, we - -- do not need to manipulate caller's signal mask at this point. - -- All tasks in RTS will have All_Tasks_Mask initially. - - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); - pragma Assert (Result = 0 or else Result = EAGAIN); - - Succeeded := Result = 0; - - Result := pthread_attr_destroy (Attributes'Access); - pragma Assert (Result = 0); - - if T.Common.Task_Info /= null then - -- ??? We're using a process-wide function to implement a task - -- specific characteristic. - - if T.Common.Task_Info.Bind_To_Cpu_Number = 0 then - Result := bind_to_cpu (Curpid, 0); - elsif T.Common.Task_Info.Bind_To_Cpu_Number > 0 then - Result := bind_to_cpu - (Curpid, - Interfaces.C.unsigned_long ( - Interfaces.Shift_Left - (Interfaces.Unsigned_64'(1), - T.Common.Task_Info.Bind_To_Cpu_Number - 1))); - pragma Assert (Result = 0); - end if; - end if; - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_ID) is - Result : Interfaces.C.int; - Tmp : Task_ID := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); - - begin - if not Single_Lock then - Result := pthread_mutex_destroy (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_cond_destroy (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - procedure Exit_Task is - begin - Specific.Set (null); - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_ID) is - Result : Interfaces.C.int; - begin - Result := - pthread_kill - (T.Common.LL.Thread, - Signal (System.Interrupt_Management.Abort_Task_Interrupt)); - pragma Assert (Result = 0); - end Abort_Task; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy version - - function Check_Exit (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - - begin - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - - begin - return True; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_ID is - begin - return Environment_Task_ID; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) return Boolean - is - pragma Warnings (Off, T); - pragma Warnings (Off, Thread_Self); - - begin - return False; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) return Boolean - is - pragma Warnings (Off, T); - pragma Warnings (Off, Thread_Self); - - begin - return False; - end Resume_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_ID) is - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - Tmp_Set : aliased sigset_t; - Result : Interfaces.C.int; - - function State - (Int : System.Interrupt_Management.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: - - 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 - Environment_Task_ID := Environment_Task; - - -- Initialize the lock used to synchronize chain of all ATCBs. - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - - Specific.Initialize (Environment_Task); - - Enter_Task (Environment_Task); - - -- Install the abort-signal handler - - if State (System.Interrupt_Management.Abort_Task_Interrupt) - /= Default - then - act.sa_flags := 0; - act.sa_handler := Abort_Handler'Address; - - Result := sigemptyset (Tmp_Set'Access); - pragma Assert (Result = 0); - act.sa_mask := Tmp_Set; - - Result := - sigaction - (Signal (System.Interrupt_Management.Abort_Task_Interrupt), - act'Unchecked_Access, - old_act'Unchecked_Access); - pragma Assert (Result = 0); - end if; - end Initialize; - -begin - declare - Result : Interfaces.C.int; - - begin - -- Mask Environment task for all signals. The original mask of the - -- Environment task will be recovered by Interrupt_Server task - -- during the elaboration of s-interr.adb. - - System.Interrupt_Management.Operations.Set_Interrupt_Mask - (System.Interrupt_Management.Operations.All_Tasks_Mask'Access); - - -- Prepare the set of signals that should unblocked in all tasks - - Result := sigemptyset (Unblocked_Signal_Mask'Access); - pragma Assert (Result = 0); - - for J in Interrupt_Management.Interrupt_ID loop - if System.Interrupt_Management.Keep_Unmasked (J) then - Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); - pragma Assert (Result = 0); - end if; - end loop; - end; - - Curpid := getpid; -end System.Task_Primitives.Operations; diff --git a/gcc/ada/5atasinf.ads b/gcc/ada/5atasinf.ads deleted file mode 100644 index 179f469c37c..00000000000 --- a/gcc/ada/5atasinf.ads +++ /dev/null @@ -1,111 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T A S K _ I N F O -- --- -- --- S p e c -- --- (Compiler Interface) -- --- -- --- Copyright (C) 1998-2003 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 contains the definitions and routines associated with the --- implementation and use of the Task_Info pragma. It is specialized --- appropriately for targets that make use of this pragma. - --- Note: the compiler generates direct calls to this interface, via Rtsfind. --- Any changes to this interface may require corresponding compiler changes. - --- This unit may be used directly from an application program by providing --- an appropriate WITH, and the interface can be expected to remain stable. - --- This is a DEC Unix 4.0d version of this package. - -package System.Task_Info is - pragma Elaborate_Body; - -- To ensure that a body is allowed - - ----------------------------------------- - -- Implementation of Task_Info Feature -- - ----------------------------------------- - - -- The Task_Info pragma: - - -- pragma Task_Info (EXPRESSION); - - -- allows the specification on a task by task basis of a value of type - -- System.Task_Info.Task_Info_Type to be passed to a task when it is - -- created. The specification of this type, and the effect on the task - -- that is created is target dependent. - - -- The Task_Info pragma appears within a task definition (compare the - -- definition and implementation of pragma Priority). If no such pragma - -- appears, then the value Task_Info_Unspecified is passed. If a pragma - -- is present, then it supplies an alternative value. If the argument of - -- the pragma is a discriminant reference, then the value can be set on - -- a task by task basis by supplying the appropriate discriminant value. - - -- Note that this means that the type used for Task_Info_Type must be - -- suitable for use as a discriminant (i.e. a scalar or access type). - - ------------------ - -- Declarations -- - ------------------ - - type Scope_Type is - (Process_Scope, - -- Contend only with threads in same process - - System_Scope, - -- Contend with all threads on same CPU - - Default_Scope); - - type Thread_Attributes is record - Bind_To_Cpu_Number : Integer; - -- -1: Do nothing - -- 0: Unbind - -- 1-N: Bind all unbound threads to this CPU - - Contention_Scope : Scope_Type; - end record; - - type Task_Info_Type is access all Thread_Attributes; - -- Type used for passing information to task create call, using the - -- Task_Info pragma. This type may be specialized for individual - -- implementations, but it must be a type that can be used as a - -- discriminant (i.e. a scalar or access type). - - Unspecified_Thread_Attribute : aliased Thread_Attributes := - Thread_Attributes'(-1, Default_Scope); - - Unspecified_Task_Info : constant Task_Info_Type := - Unspecified_Thread_Attribute'Access; - -- Value passed to task in the absence of a Task_Info pragma - -- Don't call new here because the tasking run time has not been - -- elaborated yet, so calling Task_Lock is unsafe. - -end System.Task_Info; diff --git a/gcc/ada/5ataspri.ads b/gcc/ada/5ataspri.ads deleted file mode 100644 index 2caf54b5f25..00000000000 --- a/gcc/ada/5ataspri.ads +++ /dev/null @@ -1,93 +0,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-2000 Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the DEC Unix 4.0 version of this package. - --- This package provides low-level support for most tasking features. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with Interfaces.C; --- used for int --- size_t - -with System.OS_Interface; --- used for pthread_mutex_t --- pthread_cond_t --- pthread_t - -package System.Task_Primitives is - - type Lock is limited private; - -- Should be used for implementation of protected objects. - - type RTS_Lock is limited private; - -- Should be used inside the runtime system. - -- The difference between Lock and the RTS_Lock is that the later - -- one serves only as a semaphore so that do not check for - -- ceiling violations. - - type Task_Body_Access is access procedure; - -- Pointer to the task body's entry point (or possibly a wrapper - -- declared local to the GNARL). - - type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task - -- basis. A component of this type is guaranteed to be included - -- in the Ada_Task_Control_Block. - -private - - type Lock is record - L : aliased System.OS_Interface.pthread_mutex_t; - Ceiling : Interfaces.C.int; - end record; - - type RTS_Lock is new System.OS_Interface.pthread_mutex_t; - type Private_Data is record - Thread : aliased System.OS_Interface.pthread_t; - pragma Atomic (Thread); - -- Thread field may be updated by two different threads of control. - -- (See, Enter_Task and Create_Task in s-taprop.adb). - -- They put the same value (thr_self value). We do not want to - -- use lock on those operations and the only thing we have to - -- make sure is that they are updated in atomic fashion. - - CV : aliased System.OS_Interface.pthread_cond_t; - L : aliased RTS_Lock; - -- protection for all components is lock L - end record; - -end System.Task_Primitives; diff --git a/gcc/ada/5atpopsp.adb b/gcc/ada/5atpopsp.adb deleted file mode 100644 index c1c0815c790..00000000000 --- a/gcc/ada/5atpopsp.adb +++ /dev/null @@ -1,108 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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 a POSIX version of this package where foreign threads are --- recognized. - --- Currently, DEC Unix, SCO UnixWare, Solaris pthread, HPUX pthread and --- GNU/Linux threads use this version. - -separate (System.Task_Primitives.Operations) -package body Specific is - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_ID) is - pragma Warnings (Off, Environment_Task); - Result : Interfaces.C.int; - - begin - Result := pthread_key_create (ATCB_Key'Access, null); - pragma Assert (Result = 0); - end Initialize; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean is - begin - return pthread_getspecific (ATCB_Key) /= System.Null_Address; - end Is_Valid_Task; - - --------- - -- Set -- - --------- - - procedure Set (Self_Id : Task_ID) is - Result : Interfaces.C.int; - begin - Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id)); - pragma Assert (Result = 0); - end Set; - - ---------- - -- Self -- - ---------- - - -- To make Ada tasks and C threads interoperate better, we have added some - -- functionality to Self. Suppose a C main program (with threads) calls an - -- Ada procedure and the Ada procedure calls the tasking runtime system. - -- Eventually, a call will be made to self. Since the call is not coming - -- from an Ada task, there will be no corresponding ATCB. - - -- What we do in Self is to catch references that do not come from - -- recognized Ada tasks, and create an ATCB for the calling thread. - - -- The new ATCB will be "detached" from the normal Ada task master - -- hierarchy, much like the existing implicitly created signal-server - -- tasks. - - function Self return Task_ID is - Result : System.Address; - - begin - Result := pthread_getspecific (ATCB_Key); - - -- If the key value is Null, then it is a non-Ada task. - - if Result /= System.Null_Address then - return To_Task_ID (Result); - else - return Register_Foreign_Thread; - end if; - end Self; - -end Specific; diff --git a/gcc/ada/5avxwork.ads b/gcc/ada/5avxwork.ads deleted file mode 100644 index 6d5e424a33c..00000000000 --- a/gcc/ada/5avxwork.ads +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . V X W O R K S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Alpha VxWorks version of this package. - -with Interfaces.C; - -package System.VxWorks is - pragma Preelaborate (System.VxWorks); - - package IC renames Interfaces.C; - - -- Floating point context record. Alpha version - - FP_NUM_DREGS : constant := 32; - type Fpx_Array is array (1 .. FP_NUM_DREGS) of IC.double; - - type FP_CONTEXT is record - fpx : Fpx_Array; - fpcsr : IC.long; - end record; - pragma Convention (C, FP_CONTEXT); - - Num_HW_Interrupts : constant := 256; - -- Number of entries in hardware interrupt vector table. - -end System.VxWorks; diff --git a/gcc/ada/5bml-tgt.adb b/gcc/ada/5bml-tgt.adb deleted file mode 100644 index c95d64893a4..00000000000 --- a/gcc/ada/5bml-tgt.adb +++ /dev/null @@ -1,391 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T -- --- (AIX Version) -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2004, 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. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a set of target dependent routines to build --- static, dynamic or relocatable libraries. - --- This is the AIX version of the body. - -with Ada.Strings.Fixed; use Ada.Strings.Fixed; -with GNAT.OS_Lib; use GNAT.OS_Lib; - -with MLib.Fil; -with MLib.Utl; -with Namet; use Namet; -with Osint; use Osint; -with Opt; -with Output; use Output; -with Prj.Com; -with Prj.Util; use Prj.Util; - -package body MLib.Tgt is - - No_Arguments : aliased Argument_List := (1 .. 0 => null); - Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; - - Wl_Initfini_String : constant String := "-Wl,-binitfini:"; - - Init_Fini_List : constant Argument_List_Access := - new Argument_List'(1 => null); - -- Used to put switch for automatic elaboration/finalization - - Bexpall : aliased String := "-Wl,-bexpall"; - Bexpall_Option : constant String_Access := Bexpall'Access; - -- The switch to export all symbols - - Lpthreads : aliased String := "-lpthreads"; - Native_Thread_Options : aliased Argument_List := (1 => Lpthreads'Access); - -- The switch to use when linking a library against libgnarl when using - -- Native threads. - - Lgthreads : aliased String := "-lgthreads"; - Lmalloc : aliased String := "-lmalloc"; - FSU_Thread_Options : aliased Argument_List := - (1 => Lgthreads'Access, 2 => Lmalloc'Access); - -- The switches to use when linking a library against libgnarl when using - -- FSU threads. - - Thread_Options : Argument_List_Access := null; - -- Designate the thread switches to used when linking a library against - -- libgnarl. Depends on the thread library (Native or FSU). Resolved for - -- the first library linked against libgnarl. - - --------------------- - -- Archive_Builder -- - --------------------- - - function Archive_Builder return String is - begin - return "ar"; - end Archive_Builder; - - ----------------------------- - -- Archive_Builder_Options -- - ----------------------------- - - function Archive_Builder_Options return String_List_Access is - begin - return new String_List'(1 => new String'("cr")); - end Archive_Builder_Options; - - ----------------- - -- Archive_Ext -- - ----------------- - - function Archive_Ext return String is - begin - return "a"; - end Archive_Ext; - - --------------------- - -- Archive_Indexer -- - --------------------- - - function Archive_Indexer return String is - begin - return "ranlib"; - end Archive_Indexer; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Foreign : Argument_List; - Afiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Address : String := ""; - Lib_Version : String := ""; - Relocatable : Boolean := False; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Foreign); - pragma Unreferenced (Afiles); - pragma Unreferenced (Interfaces); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Lib_Address); - pragma Unreferenced (Lib_Version); - pragma Unreferenced (Relocatable); - - Lib_File : constant String := - Lib_Dir & Directory_Separator & "lib" & - MLib.Fil.Ext_To (Lib_Filename, DLL_Ext); - -- The file name of the library - - Init_Fini : Argument_List_Access := Empty_Argument_List; - -- The switch for automatic initialization of Stand-Alone Libraries. - -- Changed to a real switch when Auto_Init is True. - - Options_2 : Argument_List_Access := Empty_Argument_List; - -- Changed to the thread options, if -lgnarl is specified - - begin - if Opt.Verbose_Mode then - Write_Str ("building relocatable shared library "); - Write_Line (Lib_File); - end if; - - -- If specified, add automatic elaboration/finalization - - if Auto_Init then - Init_Fini := Init_Fini_List; - Init_Fini (1) := - new String'(Wl_Initfini_String & Lib_Filename & "init:" & - Lib_Filename & "final"); - end if; - - -- Look for -lgnarl in Options. If found, set the thread options. - - for J in Options'Range loop - if Options (J).all = "-lgnarl" then - - -- If Thread_Options is null, read s-osinte.ads to discover the - -- thread library and set Thread_Options accordingly. - - if Thread_Options = null then - declare - File : Text_File; - Line : String (1 .. 100); - Last : Natural; - - begin - Open - (File, Include_Dir_Default_Prefix & "/s-osinte.ads"); - - while not End_Of_File (File) loop - Get_Line (File, Line, Last); - - if Index (Line (1 .. Last), "-lpthreads") /= 0 then - Thread_Options := Native_Thread_Options'Access; - exit; - - elsif Index (Line (1 .. Last), "-lgthreads") /= 0 then - Thread_Options := FSU_Thread_Options'Access; - exit; - end if; - end loop; - - Close (File); - - if Thread_Options = null then - Prj.Com.Fail ("cannot find the thread library in use"); - end if; - - exception - when others => - Prj.Com.Fail ("cannot open s-osinte.ads"); - end; - end if; - - Options_2 := Thread_Options; - exit; - end if; - end loop; - - -- Finally, call GCC (or the driver specified) to build the library - - MLib.Utl.Gcc - (Output_File => Lib_File, - Objects => Ofiles, - Options => Options & Bexpall_Option & Init_Fini.all, - Driver_Name => Driver_Name, - Options_2 => Options_2.all); - end Build_Dynamic_Library; - - ------------------------- - -- Default_DLL_Address -- - ------------------------- - - function Default_DLL_Address return String is - begin - return ""; - end Default_DLL_Address; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return "a"; - end DLL_Ext; - - -------------------- - -- Dynamic_Option -- - -------------------- - - function Dynamic_Option return String is - begin - return "-shared"; - end Dynamic_Option; - - ------------------- - -- Is_Object_Ext -- - ------------------- - - function Is_Object_Ext (Ext : String) return Boolean is - begin - return Ext = ".o"; - end Is_Object_Ext; - - -------------- - -- Is_C_Ext -- - -------------- - - function Is_C_Ext (Ext : String) return Boolean is - begin - return Ext = ".c"; - end Is_C_Ext; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".a"; - end Is_Archive_Ext; - - ------------- - -- Libgnat -- - ------------- - - function Libgnat return String is - begin - return "libgnat.a"; - end Libgnat; - - ------------------------ - -- Library_Exists_For -- - ------------------------ - - function Library_Exists_For (Project : Project_Id) return Boolean is - begin - if not Projects.Table (Project).Library then - Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & - "for non library project"); - return False; - - else - declare - Lib_Dir : constant String := - Get_Name_String - (Projects.Table (Project).Library_Dir); - Lib_Name : constant String := - Get_Name_String - (Projects.Table (Project).Library_Name); - - begin - if Projects.Table (Project).Library_Kind = Static then - return Is_Regular_File - (Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - return Is_Regular_File - (Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - end; - end if; - end Library_Exists_For; - - --------------------------- - -- Library_File_Name_For -- - --------------------------- - - function Library_File_Name_For (Project : Project_Id) return Name_Id is - begin - if not Projects.Table (Project).Library then - Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & - "for non library project"); - return No_Name; - - else - declare - Lib_Name : constant String := - Get_Name_String (Projects.Table (Project).Library_Name); - - begin - Name_Len := 3; - Name_Buffer (1 .. Name_Len) := "lib"; - - if Projects.Table (Project).Library_Kind = Static then - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - - return Name_Find; - end; - end if; - end Library_File_Name_For; - - ---------------- - -- Object_Ext -- - ---------------- - - function Object_Ext return String is - begin - return "o"; - end Object_Ext; - - ---------------- - -- PIC_Option -- - ---------------- - - function PIC_Option return String is - begin - return "-fPIC"; - end PIC_Option; - - ----------------------------------------------- - -- Standalone_Library_Auto_Init_Is_Supported -- - ----------------------------------------------- - - function Standalone_Library_Auto_Init_Is_Supported return Boolean is - begin - return True; - end Standalone_Library_Auto_Init_Is_Supported; - - --------------------------- - -- Support_For_Libraries -- - --------------------------- - - function Support_For_Libraries return Library_Support is - begin - return Full; - end Support_For_Libraries; - -end MLib.Tgt; diff --git a/gcc/ada/5bosinte.adb b/gcc/ada/5bosinte.adb deleted file mode 100644 index 5fe86b1d606..00000000000 --- a/gcc/ada/5bosinte.adb +++ /dev/null @@ -1,159 +0,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) 1997-2002, 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 AIX (Native) version of this package - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with Interfaces.C; - -package body System.OS_Interface is - - use Interfaces.C; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (TS : timespec) return Duration is - begin - return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; - end To_Duration; - - function To_Duration (TV : struct_timeval) return Duration is - begin - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end To_Duration; - - ----------------- - -- To_Timespec -- - ----------------- - - function To_Timespec (D : Duration) return timespec is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return timespec'(tv_sec => S, - tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); - end To_Timespec; - - ---------------- - -- To_Timeval -- - ---------------- - - function To_Timeval (D : Duration) return struct_timeval is - S : long; - F : Duration; - - begin - S := long (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return - struct_timeval' - (tv_sec => S, - tv_usec => long (Long_Long_Integer (F * 10#1#E6))); - end To_Timeval; - - ------------------- - -- clock_gettime -- - ------------------- - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) - return int - is - pragma Warnings (Off, clock_id); - - Result : int; - tv : aliased struct_timeval; - - function gettimeofday - (tv : access struct_timeval; - tz : System.Address := System.Null_Address) - return int; - pragma Import (C, gettimeofday, "gettimeofday"); - - begin - Result := gettimeofday (tv'Unchecked_Access); - tp.all := To_Timespec (To_Duration (tv)); - return Result; - end clock_gettime; - - ----------------- - -- sched_yield -- - ----------------- - - -- AIX Thread does not have sched_yield; - - function sched_yield return int is - - procedure pthread_yield; - pragma Import (C, pthread_yield, "sched_yield"); - - begin - pthread_yield; - return 0; - end sched_yield; - - function Get_Stack_Base (thread : pthread_t) return Address is - pragma Warnings (Off, thread); - - begin - return Null_Address; - end Get_Stack_Base; - -end System.OS_Interface; diff --git a/gcc/ada/5bosinte.ads b/gcc/ada/5bosinte.ads deleted file mode 100644 index c761eb8a048..00000000000 --- a/gcc/ada/5bosinte.ads +++ /dev/null @@ -1,586 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 a AIX (Native THREADS) version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-lpthreads"); - pragma Linker_Options ("-lc_r"); - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 11; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIMEDOUT : constant := 78; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 63; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGUSR1 : constant := 30; -- user defined signal 1 - SIGUSR2 : constant := 31; -- user defined signal 2 - SIGCLD : constant := 20; -- alias for SIGCHLD - SIGCHLD : constant := 20; -- child status change - SIGPWR : constant := 29; -- power-fail restart - SIGWINCH : constant := 28; -- window size change - SIGURG : constant := 16; -- urgent condition on IO channel - SIGPOLL : constant := 23; -- pollable event occurred - SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) - SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 18; -- user stop requested from tty - SIGCONT : constant := 19; -- stopped process has been continued - SIGTTIN : constant := 21; -- background tty read attempted - SIGTTOU : constant := 22; -- background tty write attempted - SIGVTALRM : constant := 34; -- virtual timer expired - SIGPROF : constant := 32; -- profiling timer expired - SIGXCPU : constant := 24; -- CPU time limit exceeded - SIGXFSZ : constant := 25; -- filesize limit exceeded - SIGWAITING : constant := 39; -- m:n scheduling - - -- the following signals are AIX specific - SIGMSG : constant := 27; -- input data is in the ring buffer - SIGDANGER : constant := 33; -- system crash imminent - SIGMIGRATE : constant := 35; -- migrate process - SIGPRE : constant := 36; -- programming exception - SIGVIRT : constant := 37; -- AIX virtual time alarm - SIGALRM1 : constant := 38; -- m:n condition variables - SIGKAP : constant := 60; -- keep alive poll from native keyboard - SIGGRANT : constant := SIGKAP; -- monitor mode granted - SIGRETRACT : constant := 61; -- monitor mode should be relinguished - SIGSOUND : constant := 62; -- sound control has completed - SIGSAK : constant := 63; -- secure attention key - - SIGADAABORT : constant := SIGTERM; - -- Note: on other targets, we usually use SIGABRT, but on AiX, it - -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM. - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := - (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); - Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : int; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - SA_SIGINFO : constant := 16#0100#; - - SIG_BLOCK : constant := 0; - SIG_UNBLOCK : constant := 1; - SIG_SETMASK : constant := 2; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - Time_Slice_Supported : constant Boolean := False; - -- Indicates wether time slicing is supported - - type timespec is private; - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; - -- AiX threads don't have clock_gettime - -- We instead use gettimeofday() - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timezone is record - tz_minuteswest : int; - tz_dsttime : int; - end record; - pragma Convention (C, struct_timezone); - type struct_timezone_ptr is access all struct_timezone; - - type struct_timeval is private; - -- This is needed on systems that do not have clock_gettime() - -- but do have gettimeofday(). - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 1; - SCHED_RR : constant := 2; - SCHED_OTHER : constant := 0; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - --------- - -- LWP -- - --------- - - function lwp_self return System.Address; - pragma Import (C, lwp_self, "thread_self"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 1; - - ----------- - -- Stack -- - ----------- - - Stack_Base_Available : constant Boolean := False; - -- Indicates wether the stack base is available on this target. - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- returns the stack base of the specified thread. - -- Only call this function when Stack_Base_Available is True. - - function Get_Page_Size return size_t; - function Get_Page_Size return Address; - pragma Import (C, Get_Page_Size, "getpagesize"); - -- returns the size of a page, or 0 if this is not relevant on this - -- target - - PROT_NONE : constant := 0; - PROT_READ : constant := 1; - PROT_WRITE : constant := 2; - PROT_EXEC : constant := 4; - PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; - - PROT_ON : constant := PROT_READ; - PROT_OFF : constant := PROT_ALL; - - function mprotect (addr : Address; len : size_t; prot : int) return int; - pragma Import (C, mprotect); - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - -- Though not documented, pthread_init *must* be called before any other - -- pthread call - - procedure pthread_init; - pragma Import (C, pthread_init, "pthread_init"); - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) return int; - pragma Import (C, sigwait, "sigwait"); - - function pthread_kill - (thread : pthread_t; - sig : Signal) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask, "sigthreadmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "pthread_cond_init"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); - - Relative_Timed_Wait : constant Boolean := False; - -- pthread_cond_timedwait requires an absolute delay time - - ---------------------------- - -- POSIX.1c Section 13 -- - ---------------------------- - - PTHREAD_PRIO_NONE : constant := 0; - PTHREAD_PRIO_PROTECT : constant := 0; - PTHREAD_PRIO_INHERIT : constant := 0; - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol); - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int; - pragma Import (C, pthread_mutexattr_setprioceiling); - - type Array_5_Int is array (0 .. 5) of int; - type struct_sched_param is record - sched_priority : int; - sched_policy : int; - sched_reserved : Array_5_Int; - end record; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import (C, pthread_attr_setinheritsched); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; - policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy); - - function pthread_attr_setschedparam - (attr : access pthread_attr_t; - sched_param : int) return int; - pragma Import (C, pthread_attr_setschedparam); - - function sched_yield return int; - -- AiX have a nonstandard sched_yield. - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "pthread_attr_init"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Import (C, pthread_attr_setdetachstate); - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) - return int; - pragma Import (C, pthread_create, "pthread_create"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "pthread_setspecific"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Import (C, pthread_getspecific, "pthread_getspecific"); - - type destructor_pointer is access - procedure (arg : System.Address); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "pthread_key_create"); - -private - - type sigset_t is record - losigs : unsigned_long; - hisigs : unsigned_long; - end record; - pragma Convention (C_Pass_By_Copy, sigset_t); - - type pid_t is new int; - - type time_t is new long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 0; - - type struct_timeval is record - tv_sec : long; - tv_usec : long; - end record; - pragma Convention (C, struct_timeval); - - type pthread_attr_t is new System.Address; - pragma Convention (C, pthread_attr_t); - -- typedef struct __pt_attr *pthread_attr_t; - - type pthread_condattr_t is new System.Address; - pragma Convention (C, pthread_condattr_t); - -- typedef struct __pt_attr *pthread_condattr_t; - - type pthread_mutexattr_t is new System.Address; - pragma Convention (C, pthread_mutexattr_t); - -- typedef struct __pt_attr *pthread_mutexattr_t; - - type pthread_t is new System.Address; - pragma Convention (C, pthread_t); - -- typedef void *pthread_t; - - type ptq_queue; - type ptq_queue_ptr is access all ptq_queue; - - type ptq_queue is record - ptq_next : ptq_queue_ptr; - ptq_prev : ptq_queue_ptr; - end record; - - type Array_3_Int is array (0 .. 3) of int; - type pthread_mutex_t is record - link : ptq_queue; - ptmtx_lock : int; - ptmtx_flags : long; - protocol : int; - prioceiling : int; - ptmtx_owner : pthread_t; - mtx_id : int; - attr : pthread_attr_t; - mtx_kind : int; - lock_cpt : int; - reserved : Array_3_Int; - end record; - pragma Convention (C, pthread_mutex_t); - type pthread_mutex_t_ptr is access pthread_mutex_t; - - type pthread_cond_t is record - link : ptq_queue; - ptcv_lock : int; - ptcv_flags : long; - ptcv_waiters : ptq_queue; - cv_id : int; - attr : pthread_attr_t; - mutex : pthread_mutex_t_ptr; - cptwait : int; - reserved : int; - end record; - pragma Convention (C, pthread_cond_t); - - type pthread_key_t is new unsigned; - -end System.OS_Interface; diff --git a/gcc/ada/5bsystem.ads b/gcc/ada/5bsystem.ads deleted file mode 100644 index fa28445a423..00000000000 --- a/gcc/ada/5bsystem.ads +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (AIX/PPC Version) -- --- -- --- 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 := 0.01; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := False; - 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 := True; - -end System; diff --git a/gcc/ada/5cosinte.ads b/gcc/ada/5cosinte.ads deleted file mode 100644 index 7ea96a83299..00000000000 --- a/gcc/ada/5cosinte.ads +++ /dev/null @@ -1,589 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 a AIX (FSU THREADS) version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -package System.OS_Interface is - pragma Preelaborate; - -- pragma Elaborate_Body; - - pragma Linker_Options ("-lgthreads"); - pragma Linker_Options ("-lmalloc"); - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 11; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIMEDOUT : constant := 78; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 63; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGUSR1 : constant := 30; -- user defined signal 1 - SIGUSR2 : constant := 31; -- user defined signal 2 - SIGCLD : constant := 20; -- alias for SIGCHLD - SIGCHLD : constant := 20; -- child status change - SIGPWR : constant := 29; -- power-fail restart - SIGWINCH : constant := 28; -- window size change - SIGURG : constant := 16; -- urgent condition on IO channel - SIGPOLL : constant := 23; -- pollable event occurred - SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) - SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 18; -- user stop requested from tty - SIGCONT : constant := 19; -- stopped process has been continued - SIGTTIN : constant := 21; -- background tty read attempted - SIGTTOU : constant := 22; -- background tty write attempted - SIGVTALRM : constant := 34; -- virtual timer expired - SIGPROF : constant := 32; -- profiling timer expired - SIGXCPU : constant := 24; -- CPU time limit exceeded - SIGXFSZ : constant := 25; -- filesize limit exceeded - SIGWAITING : constant := 39; -- m:n scheduling - - -- the following signals are AIX specific - SIGMSG : constant := 27; -- input data is in the ring buffer - SIGDANGER : constant := 33; -- system crash imminent - SIGMIGRATE : constant := 35; -- migrate process - SIGPRE : constant := 36; -- programming exception - SIGVIRT : constant := 37; -- AIX virtual time alarm - SIGALRM1 : constant := 38; -- m:n condition variables - SIGKAP : constant := 60; -- keep alive poll from native keyboard - SIGGRANT : constant := SIGKAP; -- monitor mode granted - SIGRETRACT : constant := 61; -- monitor mode should be relinguished - SIGSOUND : constant := 62; -- sound control has completed - SIGSAK : constant := 63; -- secure attention key - - SIGADAABORT : constant := SIGABRT; - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := - (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); - Reserved : constant Signal_Set := - (SIGKILL, SIGSTOP, SIGALRM, SIGWAITING); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : int; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - SA_SIGINFO : constant := 16#0100#; - - SIG_BLOCK : constant := 0; - SIG_UNBLOCK : constant := 1; - SIG_SETMASK : constant := 2; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "_internal_sigaction"); - - ---------- - -- Time -- - ---------- - - Time_Slice_Supported : constant Boolean := True; - -- Indicates wether time slicing is supported (i.e FSU threads have been - -- compiled with DEF_RR) - - type timespec is private; - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; - pragma Import (C, clock_gettime, "clock_gettime"); - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timeval is private; - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 0; - SCHED_RR : constant := 1; - SCHED_OTHER : constant := 2; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - --------- - -- LWP -- - --------- - - function lwp_self return System.Address; - -- lwp_self does not exist on this thread library, revert to pthread_self - -- which is the closest approximation (with getpid). This function is - -- needed to share 7staprop.adb across POSIX-like targets. - pragma Import (C, lwp_self, "pthread_self"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 1; - - ----------- - -- Stack -- - ----------- - - Stack_Base_Available : constant Boolean := True; - -- Indicates wether the stack base is available on this target. - -- This allows us to share s-osinte.adb between all the FSU run time. - -- Note that this value can only be true if pthread_t has a complete - -- definition that corresponds exactly to the C header files. - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- returns the stack base of the specified thread. - -- Only call this function when Stack_Base_Available is True. - - function Get_Page_Size return size_t; - function Get_Page_Size return Address; - pragma Import (C, Get_Page_Size, "getpagesize"); - -- returns the size of a page, or 0 if this is not relevant on this - -- target - - PROT_NONE : constant := 0; - PROT_READ : constant := 1; - PROT_WRITE : constant := 2; - PROT_EXEC : constant := 4; - PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; - - PROT_ON : constant := PROT_READ; - PROT_OFF : constant := PROT_ALL; - - function mprotect (addr : Address; len : size_t; prot : int) return int; - pragma Import (C, mprotect); - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - procedure pthread_init; - -- FSU_THREADS requires pthread_init, which is nonstandard - -- and this should be invoked during the elaboration of s-taprop.adb - pragma Import (C, pthread_init, "pthread_init"); - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) return int; - -- FSU_THREADS has a nonstandard sigwait - - function pthread_kill - (thread : pthread_t; - sig : Signal) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - -- FSU threads does not have pthread_sigmask. Instead, it redefines - -- sigprocmask and then uses a special syscall API to call the system - -- version. Doing syscalls on AiX is very difficult, so we rename the - -- pthread version instead. - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask, "_internal_sigprocmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - -- FSU_THREADS has nonstandard pthread_mutex_lock - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - -- FSU_THREADS has nonstandard pthread_mutex_lock - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "pthread_cond_init"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - -- FSU_THREADS has a nonstandard pthread_cond_wait - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - -- FSU_THREADS has a nonstandard pthread_cond_timedwait - - Relative_Timed_Wait : constant Boolean := False; - -- pthread_cond_timedwait requires an absolute delay time - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - PTHREAD_PRIO_NONE : constant := 0; - PTHREAD_PRIO_PROTECT : constant := 2; - PTHREAD_PRIO_INHERIT : constant := 1; - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol); - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int; - pragma Import - (C, pthread_mutexattr_setprioceiling, - "pthread_mutexattr_setprio_ceiling"); - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - -- FSU_THREADS does not have pthread_setschedparam - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import (C, pthread_attr_setinheritsched); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; - policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched"); - - function sched_yield return int; - -- FSU_THREADS does not have sched_yield; - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "pthread_attr_init"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - -- FSU_THREADS has a nonstandard pthread_attr_setdetachstate - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "pthread_create"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "pthread_setspecific"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - -- FSU_THREADS has a nonstandard pthread_getspecific - - type destructor_pointer is access procedure (arg : System.Address); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "pthread_key_create"); - -private - - type sigset_t is record - losigs : unsigned_long; - hisigs : unsigned_long; - end record; - pragma Convention (C_Pass_By_Copy, sigset_t); - - type pid_t is new int; - - type time_t is new long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 0; - - type struct_timeval is record - tv_sec : long; - tv_usec : long; - end record; - pragma Convention (C, struct_timeval); - - type pthread_attr_t is record - flags : int; - stacksize : int; - contentionscope : int; - inheritsched : int; - detachstate : int; - sched : int; - prio : int; - starttime : timespec; - deadline : timespec; - period : timespec; - end record; - pragma Convention (C_Pass_By_Copy, pthread_attr_t); - - type pthread_condattr_t is record - flags : int; - end record; - pragma Convention (C, pthread_condattr_t); - - type pthread_mutexattr_t is record - flags : int; - prio_ceiling : int; - protocol : int; - end record; - pragma Convention (C, pthread_mutexattr_t); - - type sigjmp_buf is array (Integer range 0 .. 63) of int; - - type pthread_t_struct is record - context : sigjmp_buf; - pbody : sigjmp_buf; - errno : int; - ret : int; - stack_base : System.Address; - end record; - pragma Convention (C, pthread_t_struct); - - type pthread_t is access all pthread_t_struct; - - type queue_t is record - head : System.Address; - tail : System.Address; - end record; - pragma Convention (C, queue_t); - - type pthread_mutex_t is record - queue : queue_t; - lock : plain_char; - owner : System.Address; - flags : int; - prio_ceiling : int; - protocol : int; - prev_max_ceiling_prio : int; - end record; - pragma Convention (C, pthread_mutex_t); - - type pthread_cond_t is record - queue : queue_t; - flags : int; - waiters : int; - mutex : System.Address; - end record; - pragma Convention (C, pthread_cond_t); - - type pthread_key_t is new int; - -end System.OS_Interface; diff --git a/gcc/ada/5csystem.ads b/gcc/ada/5csystem.ads deleted file mode 100644 index 8ddf3b06a6a..00000000000 --- a/gcc/ada/5csystem.ads +++ /dev/null @@ -1,160 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks Version Sparc/64) -- --- -- --- 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 - - -- VxWorks for UltraSparc uses 64bit words but 32bit pointers - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 64; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - - -- Priority-related Declarations (RM D.1) - - -- 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 := True; - 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; diff --git a/gcc/ada/5dsystem.ads b/gcc/ada/5dsystem.ads deleted file mode 100644 index 1fa021d5187..00000000000 --- a/gcc/ada/5dsystem.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks Version Xscale) -- --- -- --- 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 := 32; - Memory_Size : constant := 2 ** 32; - - -- 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 := True; - 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; diff --git a/gcc/ada/5esystem.ads b/gcc/ada/5esystem.ads deleted file mode 100644 index d48b684f84c..00000000000 --- a/gcc/ada/5esystem.ads +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (x86 Solaris Version) -- --- -- --- 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 := 0.01; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := True; - 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 := False; - ZCX_By_Default : constant Boolean := False; - GCC_ZCX_Support : constant Boolean := False; - Front_End_ZCX_Support : constant Boolean := True; - - -- Obsolete entries, to be removed eventually (bootstrap issues!) - - High_Integrity_Mode : constant Boolean := False; - Long_Shifts_Inlined : constant Boolean := True; - -end System; diff --git a/gcc/ada/5fintman.adb b/gcc/ada/5fintman.adb deleted file mode 100644 index 2a290e105da..00000000000 --- a/gcc/ada/5fintman.adb +++ /dev/null @@ -1,152 +0,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) 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 SGI Pthread version of this package. - --- PLEASE DO NOT add any dependences on other packages. --- This package is designed to work with or without tasking support. - --- Make a careful study of all signals available under the OS, --- to see which need to be reserved, kept always unmasked, --- or kept always unmasked. --- Be on the lookout for special signals that --- may be used by the thread library. - -with Interfaces.C; --- used for int - -with System.OS_Interface; --- used for various Constants, Signal and types - -package body System.Interrupt_Management is - - use System.OS_Interface; - - type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID; - Exception_Interrupts : constant Interrupt_List := - (SIGTSTP, SIGILL, SIGTRAP, SIGEMT, SIGFPE, SIGBUS, SIGSTOP, SIGKILL, - SIGSEGV, SIGSYS, SIGXCPU, SIGXFSZ, SIGPROF, SIGPTINTR, SIGPTRESCHED, - SIGABRT, SIGPIPE); - - --------------------------- - -- Initialize_Interrupts -- - --------------------------- - - -- Nothing needs to be done on this platform - - procedure Initialize_Interrupts is - begin - null; - end Initialize_Interrupts; - - Unreserve_All_Interrupts : Interfaces.C.int; - pragma Import - (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); - - use type Interfaces.C.int; - -begin - declare - 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 - Abort_Task_Interrupt := SIGABRT; - - -- Change this if you want to use another signal for task abort. - -- SIGTERM might be a good one. - - 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; - 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's - -- not in "User" state. Check for Unreserve_All_Interrupts last - - if State (SIGINT) /= User then - Keep_Unmasked (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; - - -- 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 not existing 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; diff --git a/gcc/ada/5fosinte.adb b/gcc/ada/5fosinte.adb deleted file mode 100644 index 9c4c616dfa2..00000000000 --- a/gcc/ada/5fosinte.adb +++ /dev/null @@ -1,120 +0,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) 1992-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 the IRIX version of this package. - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with Interfaces.C; use Interfaces.C; - -package body System.OS_Interface is - - ------------------ - -- pthread_init -- - ------------------ - - procedure pthread_init is - begin - null; - end pthread_init; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (TS : timespec) return Duration is - begin - return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; - end To_Duration; - - function To_Duration (TV : struct_timeval) return Duration is - begin - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end To_Duration; - - ----------------- - -- To_Timespec -- - ----------------- - - function To_Timespec (D : Duration) return timespec is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return timespec'(tv_sec => S, - tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); - end To_Timespec; - - ---------------- - -- To_Timeval -- - ---------------- - - function To_Timeval (D : Duration) return struct_timeval is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return - struct_timeval' - (tv_sec => S, - tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); - end To_Timeval; - -end System.OS_Interface; diff --git a/gcc/ada/5fosinte.ads b/gcc/ada/5fosinte.ads deleted file mode 100644 index 92c11070dad..00000000000 --- a/gcc/ada/5fosinte.ads +++ /dev/null @@ -1,527 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 SGI Pthreads version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -package System.OS_Interface is - - pragma Preelaborate; - - pragma Linker_Options ("-lpthread"); - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EINTR : constant := 4; -- interrupted system call - EAGAIN : constant := 11; -- No more processes - ENOMEM : constant := 12; -- Not enough core - EINVAL : constant := 22; -- Invalid argument - ETIMEDOUT : constant := 145; -- Connection timed out - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 64; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the - -- future - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGUSR1 : constant := 16; -- user defined signal 1 - SIGUSR2 : constant := 17; -- user defined signal 2 - SIGCLD : constant := 18; -- alias for SIGCHLD - SIGCHLD : constant := 18; -- child status change - SIGPWR : constant := 19; -- power-fail restart - SIGWINCH : constant := 20; -- window size change - SIGURG : constant := 21; -- urgent condition on IO channel - SIGPOLL : constant := 22; -- pollable event occurred - SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias) - SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 24; -- user stop requested from tty - SIGCONT : constant := 25; -- stopped process has been continued - SIGTTIN : constant := 26; -- background tty read attempted - SIGTTOU : constant := 27; -- background tty write attempted - SIGVTALRM : constant := 28; -- virtual timer expired - SIGPROF : constant := 29; -- profiling timer expired - SIGXCPU : constant := 30; -- CPU time limit exceeded - SIGXFSZ : constant := 31; -- filesize limit exceeded - SIGK32 : constant := 32; -- reserved for kernel (IRIX) - SIGCKPT : constant := 33; -- Checkpoint warning - SIGRESTART : constant := 34; -- Restart warning - SIGUME : constant := 35; -- Uncorrectable memory error - -- Signals defined for Posix 1003.1c. - SIGPTINTR : constant := 47; - SIGPTRESCHED : constant := 48; - -- Posix 1003.1b signals - SIGRTMIN : constant := 49; -- Posix 1003.1b signals - SIGRTMAX : constant := 64; -- Posix 1003.1b signals - - type sigset_t is private; - type sigset_t_ptr is access all sigset_t; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type array_type_2 is array (Integer range 0 .. 1) of int; - type struct_sigaction is record - sa_flags : int; - sa_handler : System.Address; - sa_mask : sigset_t; - sa_resv : array_type_2; - end record; - pragma Convention (C, struct_sigaction); - - type struct_sigaction_ptr is access all struct_sigaction; - - SIG_BLOCK : constant := 1; - SIG_UNBLOCK : constant := 2; - SIG_SETMASK : constant := 3; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr := null) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - type timespec is private; - type timespec_ptr is access all timespec; - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - CLOCK_SGI_FAST : constant clockid_t; - CLOCK_SGI_CYCLE : constant clockid_t; - - SGI_CYCLECNTR_SIZE : constant := 165; - - function syssgi (request : Interfaces.C.int) return Interfaces.C.ptrdiff_t; - pragma Import (C, syssgi, "syssgi"); - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; - pragma Import (C, clock_gettime, "clock_gettime"); - - function clock_getres - (clock_id : clockid_t; - tp : access timespec) return int; - pragma Import (C, clock_getres, "clock_getres"); - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timeval is private; - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 1; - SCHED_RR : constant := 2; - SCHED_TS : constant := 3; - SCHED_OTHER : constant := 3; - SCHED_NP : constant := 4; - - function sched_get_priority_min (Policy : int) return int; - pragma Import (C, sched_get_priority_min, "sched_get_priority_min"); - - function sched_get_priority_max (Policy : int) return int; - pragma Import (C, sched_get_priority_max, "sched_get_priority_max"); - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 1; - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - procedure pthread_init; - pragma Inline (pthread_init); - -- This is a dummy procedure to share some GNULLI files - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) return int; - pragma Import (C, sigwait, "sigwait"); - - function pthread_kill - (thread : pthread_t; - sig : Signal) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask, "pthread_sigmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "pthread_cond_init"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - PTHREAD_PRIO_NONE : constant := 0; - PTHREAD_PRIO_PROTECT : constant := 2; - PTHREAD_PRIO_INHERIT : constant := 1; - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol); - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int; - pragma Import (C, pthread_mutexattr_setprioceiling); - - type struct_sched_param is record - sched_priority : int; - end record; - pragma Convention (C, struct_sched_param); - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) - return int; - pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import - (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched"); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; - policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy); - - function pthread_attr_setschedparam - (attr : access pthread_attr_t; - sched_param : access struct_sched_param) - return int; - pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam"); - - function sched_yield return int; - pragma Import (C, sched_yield, "sched_yield"); - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "pthread_attr_init"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Import (C, pthread_attr_setdetachstate); - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "pthread_create"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "pthread_setspecific"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Import (C, pthread_getspecific, "pthread_getspecific"); - - type destructor_pointer is access procedure (arg : System.Address); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "pthread_key_create"); - - --------------------------------------------------------------- - -- Non portable SGI 6.5 additions to the pthread interface -- - -- must be executed from within the context of a system -- - -- scope task -- - --------------------------------------------------------------- - - function pthread_setrunon_np (cpu : int) return int; - pragma Import (C, pthread_setrunon_np, "pthread_setrunon_np"); - -private - - type array_type_1 is array (Integer range 0 .. 3) of unsigned; - type sigset_t is record - X_X_sigbits : array_type_1; - end record; - pragma Convention (C, sigset_t); - - type pid_t is new long; - - type time_t is new long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 1; - CLOCK_SGI_CYCLE : constant clockid_t := 2; - CLOCK_SGI_FAST : constant clockid_t := 3; - - type struct_timeval is record - tv_sec : time_t; - tv_usec : time_t; - end record; - pragma Convention (C, struct_timeval); - - type array_type_9 is array (Integer range 0 .. 4) of long; - type pthread_attr_t is record - X_X_D : array_type_9; - end record; - pragma Convention (C, pthread_attr_t); - - type array_type_8 is array (Integer range 0 .. 1) of long; - type pthread_condattr_t is record - X_X_D : array_type_8; - end record; - pragma Convention (C, pthread_condattr_t); - - type array_type_7 is array (Integer range 0 .. 1) of long; - type pthread_mutexattr_t is record - X_X_D : array_type_7; - end record; - pragma Convention (C, pthread_mutexattr_t); - - type pthread_t is new unsigned; - - type array_type_10 is array (Integer range 0 .. 7) of long; - type pthread_mutex_t is record - X_X_D : array_type_10; - end record; - pragma Convention (C, pthread_mutex_t); - - type array_type_11 is array (Integer range 0 .. 7) of long; - type pthread_cond_t is record - X_X_D : array_type_11; - end record; - pragma Convention (C, pthread_cond_t); - - type pthread_key_t is new int; - -end System.OS_Interface; diff --git a/gcc/ada/5fsystem.ads b/gcc/ada/5fsystem.ads deleted file mode 100644 index 165a8780497..00000000000 --- a/gcc/ada/5fsystem.ads +++ /dev/null @@ -1,153 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (SGI Irix, o32 ABI) -- --- -- --- Copyright (C) 1992-2004 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 := 0.01; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := False; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := True; - 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 := False; - 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 := True; - - -- Note: Denorm is False because denormals are not supported on the - -- R10000, and we want the code to be valid for this processor. - -end System; diff --git a/gcc/ada/5ftaprop.adb b/gcc/ada/5ftaprop.adb deleted file mode 100644 index 6eb6e2ad52a..00000000000 --- a/gcc/ada/5ftaprop.adb +++ /dev/null @@ -1,1139 +0,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 . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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 a IRIX (pthread library) version of this package - --- This package contains all the GNULL primitives that interface directly --- with the underlying OS. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with Interfaces.C; --- used for int --- size_t - -with System.Task_Info; - -with System.Tasking.Debug; --- used for Known_Tasks - -with System.IO; --- used for Put_Line - -with System.Interrupt_Management; --- used for Keep_Unmasked --- Abort_Task_Interrupt --- Interrupt_ID - -with System.Interrupt_Management.Operations; --- used for Set_Interrupt_Mask --- All_Tasks_Mask -pragma Elaborate_All (System.Interrupt_Management.Operations); - -with System.Parameters; --- used for Size_Type - -with System.Tasking; --- used for Ada_Task_Control_Block --- Task_ID - -with System.Soft_Links; --- used for Defer/Undefer_Abort - --- Note that we do not use System.Tasking.Initialization directly since --- this is a higher level package that we shouldn't depend on. For example --- when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Initialization - -with System.Program_Info; --- used for Default_Task_Stack --- Default_Time_Slice --- Stack_Guard_Pages --- Pthread_Sched_Signal --- Pthread_Arena_Size - -with System.OS_Interface; --- used for various type, constant, and operations - -with System.OS_Primitives; --- used for Delay_Modes - -with Unchecked_Conversion; -with Unchecked_Deallocation; - -package body System.Task_Primitives.Operations is - - use System.Tasking; - use System.Tasking.Debug; - use Interfaces.C; - use System.OS_Interface; - use System.OS_Primitives; - use System.Parameters; - - package SSL renames System.Soft_Links; - - ------------------ - -- Local Data -- - ------------------ - - -- The followings are logically constants, but need to be initialized - -- at run time. - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_ID associated with a thread - - Environment_Task_ID : Task_ID; - -- A variable to hold Task_ID for the environment task. - - Locking_Policy : Character; - pragma Import (C, Locking_Policy, "__gl_locking_policy"); - - Real_Time_Clock_Id : constant clockid_t := CLOCK_REALTIME; - - Unblocked_Signal_Mask : aliased sigset_t; - - Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads). - - -------------------- - -- Local Packages -- - -------------------- - - package Specific is - - procedure Initialize (Environment_Task : Task_ID); - pragma Inline (Initialize); - -- Initialize various data needed by this package. - - function Is_Valid_Task return Boolean; - pragma Inline (Is_Valid_Task); - -- Does executing thread have a TCB? - - procedure Set (Self_Id : Task_ID); - pragma Inline (Set); - -- Set the self id for the current task. - - function Self return Task_ID; - pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task. - - end Specific; - - package body Specific is separate; - -- The body of this package is target specific. - - --------------------------------- - -- Support for foreign threads -- - --------------------------------- - - function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; - -- Allocate and Initialize a new ATCB for the current Thread. - - function Register_Foreign_Thread - (Thread : Thread_Id) return Task_ID is separate; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function To_Address is new Unchecked_Conversion (Task_ID, System.Address); - - procedure Abort_Handler (Sig : Signal); - -- Signal handler used to implement asynchronous abort. - - ------------------- - -- Abort_Handler -- - ------------------- - - procedure Abort_Handler (Sig : Signal) is - pragma Unreferenced (Sig); - - T : constant Task_ID := Self; - Result : Interfaces.C.int; - Old_Set : aliased sigset_t; - - begin - -- It is not safe to raise an exception when using ZCX and the GCC - -- exception handling mechanism. - - if ZCX_By_Default and then GCC_ZCX_Support then - return; - end if; - - if T.Deferral_Level = 0 - and then T.Pending_ATC_Level < T.ATC_Nesting_Level - then - -- Make sure signals used for RTS internal purpose are unmasked - - Result := pthread_sigmask - (SIG_UNBLOCK, - Unblocked_Signal_Mask'Unchecked_Access, - Old_Set'Unchecked_Access); - pragma Assert (Result = 0); - - raise Standard'Abort_Signal; - end if; - end Abort_Handler; - - ----------------- - -- Stack_Guard -- - ----------------- - - -- The underlying thread system sets a guard page at the - -- bottom of a thread stack, so nothing is needed. - - procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is - pragma Unreferenced (On); - pragma Unreferenced (T); - begin - null; - end Stack_Guard; - - ------------------- - -- Get_Thread_Id -- - ------------------- - - function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_ID renames Specific.Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Initialize_TCB and the Storage_Error is - -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) - -- used in RTS is initialized before any status change of RTS. - -- Therefore rasing Storage_Error in the following routines - -- should be able to be handled safely. - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : access Lock) - is - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - if Locking_Policy = 'C' then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_PROTECT); - pragma Assert (Result = 0); - - Result := pthread_mutexattr_setprioceiling - (Attributes'Access, Interfaces.C.int (Prio)); - pragma Assert (Result = 0); - end if; - - Result := pthread_mutex_init (L, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Attributes'Access); - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is - pragma Unreferenced (Level); - - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - if Locking_Policy = 'C' then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_PROTECT); - pragma Assert (Result = 0); - - Result := pthread_mutexattr_setprioceiling - (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); - pragma Assert (Result = 0); - end if; - - Result := pthread_mutex_init (L, Attributes'Access); - - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Attributes'Access); - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0); - end Finalize_Lock; - - procedure Finalize_Lock (L : access RTS_Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0); - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_lock (L); - Ceiling_Violation := Result = EINVAL; - - -- Assumes the cause of EINVAL is a priority ceiling violation - - pragma Assert (Result = 0 or else Result = EINVAL); - end Write_Lock; - - procedure Write_Lock - (L : access RTS_Lock; - Global_Lock : Boolean := False) - is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_lock (L); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - procedure Write_Lock (T : Task_ID) is - Result : Interfaces.C.int; - begin - if not Single_Lock then - Result := pthread_mutex_lock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - begin - Write_Lock (L, Ceiling_Violation); - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); - end Unlock; - - procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is - Result : Interfaces.C.int; - - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); - end if; - end Unlock; - - procedure Unlock (T : Task_ID) is - Result : Interfaces.C.int; - - begin - if not Single_Lock then - Result := pthread_mutex_unlock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Unlock; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : ST.Task_ID; - Reason : System.Tasking.Task_States) - is - pragma Unreferenced (Reason); - - Result : Interfaces.C.int; - - begin - if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; - - -- EINTR is not considered a failure. - - pragma Assert (Result = 0 or else Result = EINTR); - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - procedure Timed_Sleep - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Unreferenced (Reason); - - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - Timedout := True; - Yielded := False; - - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; - - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); - - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; - - if Single_Lock then - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, - Request'Access); - - else - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, - Request'Access); - end if; - - exit when Abs_Time <= Monotonic_Clock; - - if Result = 0 or else errno = EINTR then - Timedout := False; - exit; - end if; - end loop; - end if; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - -- This is for use in implementing delay statements, so - -- we assume the caller is abort-deferred but is holding - -- no locks. - - procedure Timed_Delay - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes) - is - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - -- Only the little window between deferring abort and - -- locking Self_ID is the reason we need to - -- check for pending abort and priority change below! :( - - SSL.Abort_Defer.all; - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - - if Mode = Relative then - Abs_Time := Time + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; - - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); - Self_ID.Common.State := Delay_Sleep; - - loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Request'Access); - exit when Abs_Time <= Monotonic_Clock; - - pragma Assert (Result = 0 - or else Result = ETIMEDOUT - or else Result = EINTR); - end loop; - - Self_ID.Common.State := Runnable; - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - Yield; - SSL.Abort_Undefer.all; - end Timed_Delay; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration is - TS : aliased timespec; - Result : Interfaces.C.int; - begin - Result := clock_gettime (Real_Time_Clock_Id, TS'Unchecked_Access); - pragma Assert (Result = 0); - return To_Duration (TS); - end Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - begin - -- The clock_getres (Real_Time_Clock_Id) function appears to return - -- the interrupt resolution of the realtime clock and not the actual - -- resolution of reading the clock. Even though this last value is - -- only guaranteed to be 100 Hz, at least the Origin 200 appears to - -- have a microsecond resolution or better. - -- ??? We should figure out a method to return the right value on - -- all SGI hardware. - - return 0.000_001; -- Assume microsecond resolution of clock - end RT_Resolution; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup (T : ST.Task_ID; Reason : System.Tasking.Task_States) is - pragma Unreferenced (Reason); - Result : Interfaces.C.int; - begin - Result := pthread_cond_signal (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Wakeup; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - Result : Interfaces.C.int; - pragma Unreferenced (Result); - begin - if Do_Yield then - Result := sched_yield; - end if; - end Yield; - - ------------------ - -- Set_Priority -- - ------------------ - - procedure Set_Priority - (T : Task_ID; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) - is - pragma Unreferenced (Loss_Of_Inheritance); - - Result : Interfaces.C.int; - Param : aliased struct_sched_param; - Sched_Policy : Interfaces.C.int; - - use type System.Task_Info.Task_Info_Type; - - function To_Int is new Unchecked_Conversion - (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int); - - begin - T.Common.Current_Priority := Prio; - Param.sched_priority := Interfaces.C.int (Prio); - - if T.Common.Task_Info /= null then - Sched_Policy := To_Int (T.Common.Task_Info.Policy); - else - Sched_Policy := SCHED_FIFO; - end if; - - Result := pthread_setschedparam (T.Common.LL.Thread, Sched_Policy, - Param'Access); - pragma Assert (Result = 0); - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_ID) return System.Any_Priority is - begin - return T.Common.Current_Priority; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (Self_ID : Task_ID) is - Result : Interfaces.C.int; - - function To_Int is new Unchecked_Conversion - (System.Task_Info.CPU_Number, Interfaces.C.int); - - use System.Task_Info; - - begin - Self_ID.Common.LL.Thread := pthread_self; - Specific.Set (Self_ID); - - if Self_ID.Common.Task_Info /= null - and then Self_ID.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM - and then Self_ID.Common.Task_Info.Runon_CPU /= ANY_CPU - then - Result := pthread_setrunon_np - (To_Int (Self_ID.Common.Task_Info.Runon_CPU)); - pragma Assert (Result = 0); - end if; - - Lock_RTS; - - for J in Known_Tasks'Range loop - if Known_Tasks (J) = null then - Known_Tasks (J) := Self_ID; - Self_ID.Known_Tasks_Index := J; - exit; - end if; - end loop; - - Unlock_RTS; - end Enter_Task; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_ID is - begin - if Is_Valid_Task then - return Self; - else - return Register_Foreign_Thread (pthread_self); - end if; - end Register_Foreign_Thread; - - -------------------- - -- Initialize_TCB -- - -------------------- - - procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is - Result : Interfaces.C.int; - Cond_Attr : aliased pthread_condattr_t; - - begin - if not Single_Lock then - Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); - end if; - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result = 0 then - Succeeded := True; - else - if not Single_Lock then - Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Succeeded := False; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_ID; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - use System.Task_Info; - - Attributes : aliased pthread_attr_t; - Sched_Param : aliased struct_sched_param; - Adjusted_Stack_Size : Interfaces.C.size_t; - Result : Interfaces.C.int; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - function To_Int is new Unchecked_Conversion - (System.Task_Info.Thread_Scheduling_Scope, Interfaces.C.int); - function To_Int is new Unchecked_Conversion - (System.Task_Info.Thread_Scheduling_Inheritance, Interfaces.C.int); - function To_Int is new Unchecked_Conversion - (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int); - - begin - if Stack_Size = System.Parameters.Unspecified_Size then - Adjusted_Stack_Size := - Interfaces.C.size_t (System.Program_Info.Default_Task_Stack); - - elsif Stack_Size < Size_Type (Minimum_Stack_Size) then - Adjusted_Stack_Size := - Interfaces.C.size_t (Minimum_Stack_Size); - - else - Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); - end if; - - Result := pthread_attr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_attr_setdetachstate - (Attributes'Access, PTHREAD_CREATE_DETACHED); - pragma Assert (Result = 0); - - Result := pthread_attr_setstacksize - (Attributes'Access, Adjusted_Stack_Size); - pragma Assert (Result = 0); - - if T.Common.Task_Info /= null then - Result := pthread_attr_setscope - (Attributes'Access, To_Int (T.Common.Task_Info.Scope)); - pragma Assert (Result = 0); - - Result := pthread_attr_setinheritsched - (Attributes'Access, To_Int (T.Common.Task_Info.Inheritance)); - pragma Assert (Result = 0); - - Result := pthread_attr_setschedpolicy - (Attributes'Access, To_Int (T.Common.Task_Info.Policy)); - pragma Assert (Result = 0); - - Sched_Param.sched_priority := - Interfaces.C.int (T.Common.Task_Info.Priority); - - Result := pthread_attr_setschedparam - (Attributes'Access, Sched_Param'Access); - pragma Assert (Result = 0); - end if; - - -- Since the initial signal mask of a thread is inherited from the - -- creator, and the Environment task has all its signals masked, we - -- do not need to manipulate caller's signal mask at this point. - -- All tasks in RTS will have All_Tasks_Mask initially. - - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); - - if Result /= 0 - and then T.Common.Task_Info /= null - and then T.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM - then - -- The pthread_create call may have failed because we - -- asked for a system scope pthread and none were - -- available (probably because the program was not executed - -- by the superuser). Let's try for a process scope pthread - -- instead of raising Tasking_Error. - - System.IO.Put_Line - ("Request for PTHREAD_SCOPE_SYSTEM in Task_Info pragma for task"); - System.IO.Put (""""); - System.IO.Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len)); - System.IO.Put_Line (""" could not be honored. "); - System.IO.Put_Line ("Scope changed to PTHREAD_SCOPE_PROCESS"); - - T.Common.Task_Info.Scope := PTHREAD_SCOPE_PROCESS; - Result := pthread_attr_setscope - (Attributes'Access, To_Int (T.Common.Task_Info.Scope)); - pragma Assert (Result = 0); - - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); - end if; - - pragma Assert (Result = 0 or else Result = EAGAIN); - - Succeeded := Result = 0; - - -- The following needs significant commenting ??? - - if T.Common.Task_Info /= null then - T.Common.Base_Priority := T.Common.Task_Info.Priority; - Set_Priority (T, T.Common.Task_Info.Priority); - else - Set_Priority (T, Priority); - end if; - - Result := pthread_attr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_ID) is - Result : Interfaces.C.int; - Tmp : Task_ID := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); - - begin - if not Single_Lock then - Result := pthread_mutex_destroy (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_cond_destroy (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - procedure Exit_Task is - begin - Specific.Set (null); - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_ID) is - Result : Interfaces.C.int; - - begin - Result := pthread_kill (T.Common.LL.Thread, - Signal (System.Interrupt_Management.Abort_Task_Interrupt)); - pragma Assert (Result = 0); - end Abort_Task; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy version - - function Check_Exit (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - - begin - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - - begin - return True; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_ID is - begin - return Environment_Task_ID; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean - is - pragma Unreferenced (T); - pragma Unreferenced (Thread_Self); - - begin - return False; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean - is - pragma Unreferenced (T); - pragma Unreferenced (Thread_Self); - - begin - return False; - end Resume_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_ID) is - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - Tmp_Set : aliased sigset_t; - Result : Interfaces.C.int; - - function State (Int : System.Interrupt_Management.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: - - 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 - Environment_Task_ID := Environment_Task; - - -- Initialize the lock used to synchronize chain of all ATCBs. - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - - Specific.Initialize (Environment_Task); - - Enter_Task (Environment_Task); - - -- Install the abort-signal handler - - if State (System.Interrupt_Management.Abort_Task_Interrupt) - /= Default - then - act.sa_flags := 0; - act.sa_handler := Abort_Handler'Address; - - Result := sigemptyset (Tmp_Set'Access); - pragma Assert (Result = 0); - act.sa_mask := Tmp_Set; - - Result := - sigaction ( - Signal (System.Interrupt_Management.Abort_Task_Interrupt), - act'Unchecked_Access, - old_act'Unchecked_Access); - pragma Assert (Result = 0); - end if; - end Initialize; - -begin - declare - Result : Interfaces.C.int; - - begin - -- Mask Environment task for all signals. The original mask of the - -- Environment task will be recovered by Interrupt_Server task - -- during the elaboration of s-interr.adb. - - System.Interrupt_Management.Operations.Set_Interrupt_Mask - (System.Interrupt_Management.Operations.All_Tasks_Mask'Access); - - -- Prepare the set of signals that should unblocked in all tasks - - Result := sigemptyset (Unblocked_Signal_Mask'Access); - pragma Assert (Result = 0); - - for J in Interrupt_Management.Interrupt_ID loop - if System.Interrupt_Management.Keep_Unmasked (J) then - Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); - pragma Assert (Result = 0); - end if; - end loop; - - -- Pick the highest resolution Clock for Clock_Realtime - -- ??? This code currently doesn't work (see c94007[ab] for example) - -- - -- if syssgi (SGI_CYCLECNTR_SIZE) = 64 then - -- Real_Time_Clock_Id := CLOCK_SGI_CYCLE; - -- else - -- Real_Time_Clock_Id := CLOCK_REALTIME; - -- end if; - end; -end System.Task_Primitives.Operations; diff --git a/gcc/ada/5ftasinf.ads b/gcc/ada/5ftasinf.ads deleted file mode 100644 index 2954f8ee66c..00000000000 --- a/gcc/ada/5ftasinf.ads +++ /dev/null @@ -1,136 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T A S K _ I N F O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2003 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 contains the definitions and routines associated with the --- implementation and use of the Task_Info pragma. It is specialized --- appropriately for targets that make use of this pragma. - --- Note: the compiler generates direct calls to this interface, via Rtsfind. --- Any changes to this interface may require corresponding compiler changes. - --- This unit may be used directly from an application program by providing --- an appropriate WITH, and the interface can be expected to remain stable. - --- This is the IRIX (kernel threads) version of this package - -with Interfaces.C; -with System.OS_Interface; - -package System.Task_Info is - pragma Elaborate_Body; - -- To ensure that a body is allowed - - package OSI renames System.OS_Interface; - - ----------------------------------------- - -- Implementation of Task_Info Feature -- - ----------------------------------------- - - -- Pragma Task_Info allows an application to set the underlying - -- pthread scheduling attributes for a specific task. - - ------------------ - -- Declarations -- - ------------------ - - type Thread_Scheduling_Scope is - (PTHREAD_SCOPE_PROCESS, PTHREAD_SCOPE_SYSTEM); - - for Thread_Scheduling_Scope'Size use Interfaces.C.int'Size; - - type Thread_Scheduling_Inheritance is - (PTHREAD_EXPLICIT_SCHED, PTHREAD_INHERIT_SCHED); - - for Thread_Scheduling_Inheritance'Size use Interfaces.C.int'Size; - - type Thread_Scheduling_Policy is - (SCHED_FIFO, -- The first-in-first-out real-time policy - SCHED_RR, -- The round-robin real-time scheduling policy - SCHED_TS); -- The timeshare earnings based scheduling policy - - for Thread_Scheduling_Policy'Size use Interfaces.C.int'Size; - for Thread_Scheduling_Policy use - (SCHED_FIFO => 1, - SCHED_RR => 2, - SCHED_TS => 3); - - function SCHED_OTHER return Thread_Scheduling_Policy renames SCHED_TS; - - No_Specified_Priority : constant := -1; - - subtype Thread_Scheduling_Priority is Integer range - No_Specified_Priority .. 255; - - function Min (Policy : Interfaces.C.int) return Interfaces.C.int - renames OSI.sched_get_priority_min; - - function Max (Policy : Interfaces.C.int) return Interfaces.C.int - renames OSI.sched_get_priority_max; - - subtype FIFO_Priority is Thread_Scheduling_Priority range - Thread_Scheduling_Priority (Min (OSI.SCHED_FIFO)) .. - Thread_Scheduling_Priority (Max (OSI.SCHED_FIFO)); - - subtype RR_Priority is Thread_Scheduling_Priority range - Thread_Scheduling_Priority (Min (OSI.SCHED_RR)) .. - Thread_Scheduling_Priority (Max (OSI.SCHED_RR)); - - subtype TS_Priority is Thread_Scheduling_Priority range - Thread_Scheduling_Priority (Min (OSI.SCHED_TS)) .. - Thread_Scheduling_Priority (Max (OSI.SCHED_TS)); - - subtype OTHER_Priority is Thread_Scheduling_Priority range - Thread_Scheduling_Priority (Min (OSI.SCHED_OTHER)) .. - Thread_Scheduling_Priority (Max (OSI.SCHED_OTHER)); - - subtype CPU_Number is Integer range -1 .. Integer'Last; - ANY_CPU : constant CPU_Number := CPU_Number'First; - - type Thread_Attributes is record - Scope : Thread_Scheduling_Scope := PTHREAD_SCOPE_PROCESS; - Inheritance : Thread_Scheduling_Inheritance := PTHREAD_EXPLICIT_SCHED; - Policy : Thread_Scheduling_Policy := SCHED_RR; - Priority : Thread_Scheduling_Priority := No_Specified_Priority; - Runon_CPU : CPU_Number := ANY_CPU; - end record; - - Default_Thread_Attributes : constant Thread_Attributes := - (PTHREAD_SCOPE_PROCESS, PTHREAD_EXPLICIT_SCHED, SCHED_RR, - No_Specified_Priority, ANY_CPU); - - type Task_Info_Type is access all Thread_Attributes; - - Unspecified_Task_Info : constant Task_Info_Type := null; - -- Value passed to task in the absence of a Task_Info pragma - -end System.Task_Info; diff --git a/gcc/ada/5ginterr.adb b/gcc/ada/5ginterr.adb deleted file mode 100644 index 4ee53e00b09..00000000000 --- a/gcc/ada/5ginterr.adb +++ /dev/null @@ -1,682 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . I N T E R R U P T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2004 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 the IRIX & NT version of this package. - -with Ada.Task_Identification; --- used for Task_Id - -with Ada.Exceptions; --- used for Raise_Exception - -with System.OS_Interface; --- used for intr_attach - -with System.Storage_Elements; --- used for To_Address --- To_Integer - -with System.Task_Primitives.Operations; --- used for Self --- Sleep --- Wakeup --- Write_Lock --- Unlock - -with System.Tasking.Utilities; --- used for Make_Independent - -with System.Tasking.Rendezvous; --- used for Call_Simple - -with System.Tasking.Initialization; --- used for Defer_Abort --- Undefer_Abort - -with System.Interrupt_Management; - -with System.Parameters; --- used for Single_Lock - -with Interfaces.C; --- used for int - -with Unchecked_Conversion; - -package body System.Interrupts is - - use Parameters; - use Tasking; - use Ada.Exceptions; - use System.OS_Interface; - use Interfaces.C; - - package STPO renames System.Task_Primitives.Operations; - package IMNG renames System.Interrupt_Management; - - subtype int is Interfaces.C.int; - - function To_System is new Unchecked_Conversion - (Ada.Task_Identification.Task_Id, Task_ID); - - type Handler_Kind is (Unknown, Task_Entry, Protected_Procedure); - - type Handler_Desc is record - Kind : Handler_Kind := Unknown; - T : Task_ID; - E : Task_Entry_Index; - H : Parameterless_Handler; - Static : Boolean := False; - end record; - - task type Server_Task (Interrupt : Interrupt_ID) is - pragma Interrupt_Priority (System.Interrupt_Priority'Last); - end Server_Task; - - type Server_Task_Access is access Server_Task; - - Attached_Interrupts : array (Interrupt_ID) of Boolean; - Handlers : array (Interrupt_ID) of Task_ID; - Descriptors : array (Interrupt_ID) of Handler_Desc; - Interrupt_Count : array (Interrupt_ID) of Integer := (others => 0); - - pragma Volatile_Components (Interrupt_Count); - - procedure Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean); - -- This internal procedure is needed to finalize protected objects - -- that contain interrupt handlers. - - procedure Signal_Handler (Sig : Interrupt_ID); - -- This procedure is used to handle all the signals. - - -- Type and Head, Tail of the list containing Registered Interrupt - -- Handlers. These definitions are used to register the handlers - -- specified by the pragma Interrupt_Handler. - - -- - -- Handler Registration: - -- - - type Registered_Handler; - type R_Link is access all Registered_Handler; - - type Registered_Handler is record - H : System.Address := System.Null_Address; - Next : R_Link := null; - end record; - - Registered_Handlers : R_Link := null; - - function Is_Registered (Handler : Parameterless_Handler) return Boolean; - -- See if the Handler has been "pragma"ed using Interrupt_Handler. - -- Always consider a null handler as registered. - - type Handler_Ptr is access procedure (Sig : Interrupt_ID); - - function TISR is new Unchecked_Conversion (Handler_Ptr, isr_address); - - procedure Signal_Handler (Sig : Interrupt_ID) is - Handler : Task_ID renames Handlers (Sig); - begin - if Intr_Attach_Reset and then - intr_attach (int (Sig), TISR (Signal_Handler'Access)) = FUNC_ERR - then - raise Program_Error; - end if; - - if Handler /= null then - Interrupt_Count (Sig) := Interrupt_Count (Sig) + 1; - STPO.Wakeup (Handler, Interrupt_Server_Idle_Sleep); - end if; - end Signal_Handler; - - ----------------- - -- Is_Reserved -- - ----------------- - - function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is - begin - return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt)); - end Is_Reserved; - - ----------------------- - -- Is_Entry_Attached -- - ----------------------- - - function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is - begin - if Is_Reserved (Interrupt) then - Raise_Exception (Program_Error'Identity, "Interrupt" & - Interrupt_ID'Image (Interrupt) & " is reserved"); - end if; - - return Descriptors (Interrupt).T /= Null_Task; - end Is_Entry_Attached; - - ------------------------- - -- Is_Handler_Attached -- - ------------------------- - - function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is - begin - if Is_Reserved (Interrupt) then - Raise_Exception (Program_Error'Identity, "Interrupt" & - Interrupt_ID'Image (Interrupt) & " is reserved"); - end if; - - return Descriptors (Interrupt).Kind /= Unknown; - end Is_Handler_Attached; - - ---------------- - -- Is_Ignored -- - ---------------- - - function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is - begin - raise Program_Error; - return False; - end Is_Ignored; - - ------------------ - -- Unblocked_By -- - ------------------ - - function Unblocked_By (Interrupt : Interrupt_ID) return Task_ID is - begin - raise Program_Error; - return Null_Task; - end Unblocked_By; - - ---------------------- - -- Ignore_Interrupt -- - ---------------------- - - procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is - begin - raise Program_Error; - end Ignore_Interrupt; - - ------------------------ - -- Unignore_Interrupt -- - ------------------------ - - procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is - begin - raise Program_Error; - end Unignore_Interrupt; - - ------------------------------------- - -- Has_Interrupt_Or_Attach_Handler -- - ------------------------------------- - - function Has_Interrupt_Or_Attach_Handler - (Object : access Dynamic_Interrupt_Protection) return Boolean - is - pragma Unreferenced (Object); - begin - return True; - end Has_Interrupt_Or_Attach_Handler; - - ---------------- - -- Finalize -- - ---------------- - - procedure Finalize (Object : in out Static_Interrupt_Protection) is - begin - -- ??? loop to be executed only when we're not doing library level - -- finalization, since in this case all interrupt tasks are gone. - - for N in reverse Object.Previous_Handlers'Range loop - Attach_Handler - (New_Handler => Object.Previous_Handlers (N).Handler, - Interrupt => Object.Previous_Handlers (N).Interrupt, - Static => Object.Previous_Handlers (N).Static, - Restoration => True); - end loop; - - Tasking.Protected_Objects.Entries.Finalize - (Tasking.Protected_Objects.Entries.Protection_Entries (Object)); - end Finalize; - - ------------------------------------- - -- Has_Interrupt_Or_Attach_Handler -- - ------------------------------------- - - function Has_Interrupt_Or_Attach_Handler - (Object : access Static_Interrupt_Protection) return Boolean - is - pragma Unreferenced (Object); - begin - return True; - end Has_Interrupt_Or_Attach_Handler; - - ---------------------- - -- Install_Handlers -- - ---------------------- - - procedure Install_Handlers - (Object : access Static_Interrupt_Protection; - New_Handlers : New_Handler_Array) - is - begin - for N in New_Handlers'Range loop - - -- We need a lock around this ??? - - Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt; - Object.Previous_Handlers (N).Static := Descriptors - (New_Handlers (N).Interrupt).Static; - - -- We call Exchange_Handler and not directly Interrupt_Manager. - -- Exchange_Handler so we get the Is_Reserved check. - - Exchange_Handler - (Old_Handler => Object.Previous_Handlers (N).Handler, - New_Handler => New_Handlers (N).Handler, - Interrupt => New_Handlers (N).Interrupt, - Static => True); - end loop; - end Install_Handlers; - - --------------------- - -- Current_Handler -- - --------------------- - - function Current_Handler - (Interrupt : Interrupt_ID) return Parameterless_Handler - is - begin - if Is_Reserved (Interrupt) then - raise Program_Error; - end if; - - if Descriptors (Interrupt).Kind = Protected_Procedure then - return Descriptors (Interrupt).H; - else - return null; - end if; - end Current_Handler; - - -------------------- - -- Attach_Handler -- - -------------------- - - procedure Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean := False) is - begin - Attach_Handler (New_Handler, Interrupt, Static, False); - end Attach_Handler; - - procedure Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean) - is - New_Task : Server_Task_Access; - - begin - if Is_Reserved (Interrupt) then - raise Program_Error; - end if; - - if not Restoration and then not Static - - -- Tries to overwrite a static Interrupt Handler with a - -- dynamic Handler - - and then (Descriptors (Interrupt).Static - - -- The new handler is not specified as an - -- Interrupt Handler by a pragma. - - or else not Is_Registered (New_Handler)) - then - Raise_Exception (Program_Error'Identity, - "Trying to overwrite a static Interrupt Handler with a " & - "dynamic Handler"); - end if; - - if Handlers (Interrupt) = null then - New_Task := new Server_Task (Interrupt); - Handlers (Interrupt) := To_System (New_Task.all'Identity); - end if; - - if intr_attach (int (Interrupt), - TISR (Signal_Handler'Access)) = FUNC_ERR - then - raise Program_Error; - end if; - - if New_Handler = null then - - -- The null handler means we are detaching the handler. - - Attached_Interrupts (Interrupt) := False; - Descriptors (Interrupt) := - (Kind => Unknown, T => null, E => 0, H => null, Static => False); - - else - Descriptors (Interrupt).Kind := Protected_Procedure; - Descriptors (Interrupt).H := New_Handler; - Descriptors (Interrupt).Static := Static; - Attached_Interrupts (Interrupt) := True; - end if; - end Attach_Handler; - - ---------------------- - -- Exchange_Handler -- - ---------------------- - - procedure Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean := False) is - begin - if Is_Reserved (Interrupt) then - raise Program_Error; - end if; - - if Descriptors (Interrupt).Kind = Task_Entry then - - -- In case we have an Interrupt Entry already installed. - -- raise a program error. (propagate it to the caller). - - Raise_Exception (Program_Error'Identity, - "An interrupt is already installed"); - end if; - - Old_Handler := Current_Handler (Interrupt); - Attach_Handler (New_Handler, Interrupt, Static); - end Exchange_Handler; - - -------------------- - -- Detach_Handler -- - -------------------- - - procedure Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean := False) is - begin - if Is_Reserved (Interrupt) then - raise Program_Error; - end if; - - if Descriptors (Interrupt).Kind = Task_Entry then - Raise_Exception (Program_Error'Identity, - "Trying to detach an Interrupt Entry"); - end if; - - if not Static and then Descriptors (Interrupt).Static then - Raise_Exception (Program_Error'Identity, - "Trying to detach a static Interrupt Handler"); - end if; - - Attached_Interrupts (Interrupt) := False; - Descriptors (Interrupt) := - (Kind => Unknown, T => null, E => 0, H => null, Static => False); - - if intr_attach (int (Interrupt), null) = FUNC_ERR then - raise Program_Error; - end if; - end Detach_Handler; - - --------------- - -- Reference -- - --------------- - - function Reference (Interrupt : Interrupt_ID) return System.Address is - Signal : constant System.Address := - System.Storage_Elements.To_Address - (System.Storage_Elements.Integer_Address (Interrupt)); - - begin - if Is_Reserved (Interrupt) then - - -- Only usable Interrupts can be used for binding it to an Entry - - raise Program_Error; - end if; - - return Signal; - end Reference; - - -------------------------------- - -- Register_Interrupt_Handler -- - -------------------------------- - - procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is - begin - Registered_Handlers := - new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers); - end Register_Interrupt_Handler; - - ------------------- - -- Is_Registered -- - ------------------- - - -- See if the Handler has been "pragma"ed using Interrupt_Handler. - -- Always consider a null handler as registered. - - function Is_Registered (Handler : Parameterless_Handler) return Boolean is - Ptr : R_Link := Registered_Handlers; - - type Fat_Ptr is record - Object_Addr : System.Address; - Handler_Addr : System.Address; - end record; - - function To_Fat_Ptr is new Unchecked_Conversion - (Parameterless_Handler, Fat_Ptr); - - Fat : Fat_Ptr; - - begin - if Handler = null then - return True; - end if; - - Fat := To_Fat_Ptr (Handler); - - while Ptr /= null loop - - if Ptr.H = Fat.Handler_Addr then - return True; - end if; - - Ptr := Ptr.Next; - end loop; - - return False; - end Is_Registered; - - ----------------------------- - -- Bind_Interrupt_To_Entry -- - ----------------------------- - - procedure Bind_Interrupt_To_Entry - (T : Task_ID; - E : Task_Entry_Index; - Int_Ref : System.Address) - is - Interrupt : constant Interrupt_ID := - Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); - - New_Task : Server_Task_Access; - - begin - if Is_Reserved (Interrupt) then - raise Program_Error; - end if; - - if Descriptors (Interrupt).Kind /= Unknown then - Raise_Exception (Program_Error'Identity, - "A binding for this interrupt is already present"); - end if; - - if Handlers (Interrupt) = null then - New_Task := new Server_Task (Interrupt); - Handlers (Interrupt) := To_System (New_Task.all'Identity); - end if; - - if intr_attach (int (Interrupt), - TISR (Signal_Handler'Access)) = FUNC_ERR - then - raise Program_Error; - end if; - - Descriptors (Interrupt).Kind := Task_Entry; - Descriptors (Interrupt).T := T; - Descriptors (Interrupt).E := E; - - -- Indicate the attachment of Interrupt Entry in ATCB. - -- This is need so that when an Interrupt Entry task terminates - -- the binding can be cleaned. The call to unbinding must be - -- make by the task before it terminates. - - T.Interrupt_Entry := True; - - Attached_Interrupts (Interrupt) := True; - end Bind_Interrupt_To_Entry; - - ------------------------------ - -- Detach_Interrupt_Entries -- - ------------------------------ - - procedure Detach_Interrupt_Entries (T : Task_ID) is - begin - for I in Interrupt_ID loop - if not Is_Reserved (I) then - if Descriptors (I).Kind = Task_Entry and then - Descriptors (I).T = T then - Attached_Interrupts (I) := False; - Descriptors (I).Kind := Unknown; - - if intr_attach (int (I), null) = FUNC_ERR then - raise Program_Error; - end if; - end if; - end if; - end loop; - - -- Indicate in ATCB that no Interrupt Entries are attached. - - T.Interrupt_Entry := True; - end Detach_Interrupt_Entries; - - --------------------- - -- Block_Interrupt -- - --------------------- - - procedure Block_Interrupt (Interrupt : Interrupt_ID) is - begin - raise Program_Error; - end Block_Interrupt; - - ----------------------- - -- Unblock_Interrupt -- - ----------------------- - - procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is - begin - raise Program_Error; - end Unblock_Interrupt; - - ---------------- - -- Is_Blocked -- - ---------------- - - function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is - begin - raise Program_Error; - return False; - end Is_Blocked; - - task body Server_Task is - Desc : Handler_Desc renames Descriptors (Interrupt); - Self_Id : constant Task_ID := STPO.Self; - Temp : Parameterless_Handler; - - begin - Utilities.Make_Independent; - - loop - while Interrupt_Count (Interrupt) > 0 loop - Interrupt_Count (Interrupt) := Interrupt_Count (Interrupt) - 1; - begin - case Desc.Kind is - when Unknown => - null; - when Task_Entry => - Rendezvous.Call_Simple (Desc.T, Desc.E, Null_Address); - when Protected_Procedure => - Temp := Desc.H; - Temp.all; - end case; - exception - when others => null; - end; - end loop; - - Initialization.Defer_Abort (Self_Id); - - if Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Self_Id); - Self_Id.Common.State := Interrupt_Server_Idle_Sleep; - STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep); - Self_Id.Common.State := Runnable; - STPO.Unlock (Self_Id); - - if Single_Lock then - STPO.Unlock_RTS; - end if; - - Initialization.Undefer_Abort (Self_Id); - - -- Undefer abort here to allow a window for this task - -- to be aborted at the time of system shutdown. - - end loop; - end Server_Task; - -end System.Interrupts; diff --git a/gcc/ada/5gintman.adb b/gcc/ada/5gintman.adb deleted file mode 100644 index 57771303f16..00000000000 --- a/gcc/ada/5gintman.adb +++ /dev/null @@ -1,184 +0,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) 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 an Irix (old pthread library) version of this package. - --- PLEASE DO NOT add any dependences on other packages. --- This package is designed to work with or without tasking support. - --- Make a careful study of all signals available under the OS, --- to see which need to be reserved, kept always unmasked, --- or kept always unmasked. - --- Be on the lookout for special signals that --- may be used by the thread library. - -with System.OS_Interface; --- used for various Constants, Signal and types - -with Interfaces.C; --- used for "int" -package body System.Interrupt_Management is - - use System.OS_Interface; - - type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID; - - Exception_Interrupts : constant Interrupt_List := - (SIGILL, - SIGABRT, - SIGFPE, - SIGSEGV, - SIGBUS); - - Reserved_Interrupts : constant Interrupt_List := - (0, - SIGTRAP, - SIGKILL, - SIGSYS, - SIGALRM, - SIGSTOP, - SIGPTINTR, - SIGPTRESCHED); - - Abort_Signal : constant := 48; - -- - -- Serious MOJO: The SGI pthreads library only supports the - -- unnamed signal number 48 for pthread_kill! - -- - - Unreserve_All_Interrupts : Interfaces.C.int; - pragma Import - (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); - - ---------------------- - -- Notify_Exception -- - ---------------------- - - -- This function identifies the Ada exception to be raised using the - -- information when the system received a synchronous signal. - -- Since this function is machine and OS dependent, different code has to - -- be provided for different target. - -- On SGI, the signal handling is done is a-init.c, even when tasking is - -- involved. - - --------------------------- - -- Initialize_Interrupts -- - --------------------------- - - -- Nothing needs to be done on this platform. - - procedure Initialize_Interrupts is - begin - null; - end Initialize_Interrupts; - -begin - declare - 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) - - use Interfaces.C; - - begin - Abort_Task_Interrupt := Abort_Signal; - - 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; - 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's - -- not in "User" state. Check for Unreserve_All_Interrupts last - - if State (SIGINT) /= User then - Keep_Unmasked (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 target-specific reserved signals - - for J in Reserved_Interrupts'Range loop - Reserve (Interrupt_ID (Reserved_Interrupts (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 not existing 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; diff --git a/gcc/ada/5gmastop.adb b/gcc/ada/5gmastop.adb deleted file mode 100644 index 6c85ce54f1a..00000000000 --- a/gcc/ada/5gmastop.adb +++ /dev/null @@ -1,444 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- SYSTEM.MACHINE_STATE_OPERATIONS -- --- -- --- B o d y -- --- (Version for IRIX/MIPS) -- --- -- --- Copyright (C) 1999-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 version of Ada.Exceptions.Machine_State_Operations is for use on --- SGI Irix systems. By means of compile time conditional calculations, it --- can handle both n32/n64 and o32 modes. - -with System.Machine_Code; use System.Machine_Code; -with System.Memory; -with System.Soft_Links; use System.Soft_Links; -with Unchecked_Conversion; - -package body System.Machine_State_Operations is - - use System.Storage_Elements; - use System.Exceptions; - - -- The exc_unwind function in libexc operats on a Sigcontext - - -- Type sigcontext_t is defined in /usr/include/sys/signal.h. - -- We define an equivalent Ada type here. From the comments in - -- signal.h: - - -- sigcontext is not part of the ABI - so this version is used to - -- handle 32 and 64 bit applications - it is a constant size regardless - -- of compilation mode, and always returns 64 bit register values - - type Uns32 is mod 2 ** 32; - type Uns64 is mod 2 ** 64; - - type Uns32_Ptr is access all Uns32; - type Uns64_Array is array (Integer range <>) of Uns64; - - type Reg_Array is array (0 .. 31) of Uns64; - - type Sigcontext is record - SC_Regmask : Uns32; -- 0 - SC_Status : Uns32; -- 4 - SC_PC : Uns64; -- 8 - SC_Regs : Reg_Array; -- 16 - SC_Fpregs : Reg_Array; -- 272 - SC_Ownedfp : Uns32; -- 528 - SC_Fpc_Csr : Uns32; -- 532 - SC_Fpc_Eir : Uns32; -- 536 - SC_Ssflags : Uns32; -- 540 - SC_Mdhi : Uns64; -- 544 - SC_Mdlo : Uns64; -- 552 - SC_Cause : Uns64; -- 560 - SC_Badvaddr : Uns64; -- 568 - SC_Triggersave : Uns64; -- 576 - SC_Sigset : Uns64; -- 584 - SC_Fp_Rounded_Result : Uns64; -- 592 - SC_Pancake : Uns64_Array (0 .. 5); - SC_Pad : Uns64_Array (0 .. 26); - end record; - - type Sigcontext_Ptr is access all Sigcontext; - - SC_Regs_Pos : constant String := "16"; - SC_Fpregs_Pos : constant String := "272"; - -- Byte offset of the Integer and Floating Point register save areas - -- within the Sigcontext. - - function To_Sigcontext_Ptr is - new Unchecked_Conversion (Machine_State, Sigcontext_Ptr); - - type Addr_Int is mod 2 ** Long_Integer'Size; - -- An unsigned integer type whose size is the same as System.Address. - -- We rely on the fact that Long_Integer'Size = System.Address'Size in - -- all ABIs. Type Addr_Int can be converted to Uns64. - - function To_Code_Loc is new Unchecked_Conversion (Addr_Int, Code_Loc); - function To_Addr_Int is new Unchecked_Conversion (System.Address, Addr_Int); - function To_Uns32_Ptr is new Unchecked_Conversion (Addr_Int, Uns32_Ptr); - - -------------------------------- - -- ABI-Dependent Declarations -- - -------------------------------- - - o32 : constant Boolean := System.Word_Size = 32; - n32 : constant Boolean := System.Word_Size = 64; - o32n : constant Natural := Boolean'Pos (o32); - n32n : constant Natural := Boolean'Pos (n32); - -- Flags to indicate which ABI is in effect for this compilation. For the - -- purposes of this unit, the n32 and n64 ABI's are identical. - - LSC : constant Character := Character'Val (o32n * Character'Pos ('w') + - n32n * Character'Pos ('d')); - -- This is 'w' for o32, and 'd' for n32/n64, used for constructing the - -- load/store instructions used to save/restore machine instructions. - - Roff : constant Character := Character'Val (o32n * Character'Pos ('4') + - n32n * Character'Pos ('0')); - -- Offset from first byte of a __uint64 register save location where - -- the register value is stored. For n32/64 we store the entire 64 - -- bit register into the uint64. For o32, only 32 bits are stored - -- at an offset of 4 bytes. - - procedure Update_GP (Scp : Sigcontext_Ptr); - - --------------- - -- Update_GP -- - --------------- - - procedure Update_GP (Scp : Sigcontext_Ptr) is - - type F_op is mod 2 ** 6; - type F_reg is mod 2 ** 5; - type F_imm is new Short_Integer; - - type I_Type is record - op : F_op; - rs : F_reg; - rt : F_reg; - imm : F_imm; - end record; - - pragma Pack (I_Type); - for I_Type'Size use 32; - - type I_Type_Ptr is access all I_Type; - - LW : constant F_op := 2#100011#; - Reg_GP : constant := 28; - - type Address_Int is mod 2 ** Standard'Address_Size; - function To_I_Type_Ptr is new - Unchecked_Conversion (Address_Int, I_Type_Ptr); - - Ret_Ins : constant I_Type_Ptr := To_I_Type_Ptr (Address_Int (Scp.SC_PC)); - GP_Ptr : Uns32_Ptr; - - begin - if Ret_Ins.op = LW and then Ret_Ins.rt = Reg_GP then - GP_Ptr := To_Uns32_Ptr - (Addr_Int (Scp.SC_Regs (Integer (Ret_Ins.rs))) - + Addr_Int (Ret_Ins.imm)); - Scp.SC_Regs (Reg_GP) := Uns64 (GP_Ptr.all); - end if; - end Update_GP; - - ---------------------------- - -- Allocate_Machine_State -- - ---------------------------- - - function Allocate_Machine_State return Machine_State is - begin - return Machine_State - (Memory.Alloc (Sigcontext'Max_Size_In_Storage_Elements)); - end Allocate_Machine_State; - - ------------------- - -- Enter_Handler -- - ------------------- - - procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is - pragma Warnings (Off, M); - pragma Warnings (Off, Handler); - - LOADI : constant String (1 .. 2) := 'l' & LSC; - -- This is "lw" in o32 mode, and "ld" in n32/n64 mode - - LOADF : constant String (1 .. 4) := 'l' & LSC & "c1"; - -- This is "lwc1" in o32 mode and "ldc1" in n32/n64 mode - - begin - -- Restore integer registers from machine state. Note that we know - -- that $4 points to M, and $5 points to Handler, since this is - -- the standard calling sequence - - Asm (LOADI & " $16, 16*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $17, 17*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $18, 18*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $19, 19*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $20, 20*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $21, 21*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $22, 22*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $23, 23*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $24, 24*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $25, 25*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $26, 26*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $27, 27*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $28, 28*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $29, 29*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $30, 30*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (LOADI & " $31, 31*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - - -- Restore floating-point registers from machine state - - Asm (LOADF & " $f16, 16*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f17, 17*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f18, 18*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f19, 19*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f20, 20*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f21, 21*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f22, 22*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f23, 23*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f24, 24*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f25, 25*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f26, 26*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f27, 27*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f28, 28*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f29, 29*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f30, 30*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (LOADF & " $f31, 31*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - - -- Jump directly to the handler - - Asm ("jr $5"); - end Enter_Handler; - - ---------------- - -- Fetch_Code -- - ---------------- - - function Fetch_Code (Loc : Code_Loc) return Code_Loc is - begin - return Loc; - end Fetch_Code; - - ------------------------ - -- Free_Machine_State -- - ------------------------ - - procedure Free_Machine_State (M : in out Machine_State) is - begin - Memory.Free (Address (M)); - M := Machine_State (Null_Address); - end Free_Machine_State; - - ------------------ - -- Get_Code_Loc -- - ------------------ - - function Get_Code_Loc (M : Machine_State) return Code_Loc is - SC : constant Sigcontext_Ptr := To_Sigcontext_Ptr (M); - begin - return To_Code_Loc (Addr_Int (SC.SC_PC)); - end Get_Code_Loc; - - -------------------------- - -- Machine_State_Length -- - -------------------------- - - function Machine_State_Length return Storage_Offset is - begin - return Sigcontext'Max_Size_In_Storage_Elements; - end Machine_State_Length; - - --------------- - -- Pop_Frame -- - --------------- - - procedure Pop_Frame - (M : Machine_State; - Info : Subprogram_Info_Type) - is - pragma Warnings (Off, Info); - - Scp : constant Sigcontext_Ptr := To_Sigcontext_Ptr (M); - - procedure Exc_Unwind (Scp : Sigcontext_Ptr; Fde : Long_Integer := 0); - pragma Import (C, Exc_Unwind, "exc_unwind"); - - -- ??? Calling exc_unwind in the current setup does not work and - -- triggers the emission of system warning messages. Why it does - -- not work remains to be investigated. Part of the problem is - -- probably a section naming issue (e.g. .eh_frame/.debug_frame). - - -- Instead of letting the call take place for nothing and emit - -- messages we don't expect, we just arrange things to pretend it - -- occurred and failed. - - -- ??? Until this is fixed, we shall document that the backtrace - -- computation facility does not work, and we inhibit the pragma below - -- because we arrange for the call not to be emitted and the linker - -- complains when a library is linked in but resolves nothing. - - -- pragma Linker_Options ("-lexc"); - - begin - -- exc_unwind is apparently not thread-safe under IRIX, so protect it - -- against race conditions within the GNAT run time. - -- ??? Note that we might want to use a fine grained lock here since - -- Lock_Task is used in many other places. - - Lock_Task.all; - - if False then - Exc_Unwind (Scp); - else - Scp.SC_PC := 0; - end if; - - Unlock_Task.all; - - if Scp.SC_PC = 0 or else Scp.SC_PC = 1 then - - -- A return value of 0 or 1 means exc_unwind couldn't find a parent - -- frame. Propagate_Exception expects a zero return address to - -- indicate TOS. - - Scp.SC_PC := 0; - - else - -- Set the GP to restore to the caller value (not callee value) - -- This is done only in o32 mode. In n32/n64 mode, GP is a normal - -- callee save register - - if o32 then - Update_GP (Scp); - end if; - - -- Adjust the return address to the call site, not the - -- instruction following the branch delay slot. This may - -- be necessary if the last instruction of a pragma No_Return - -- subprogram is a call. The first instruction following the - -- delay slot may be the start of another subprogram. We back - -- off the address by 8, which points safely into the middle - -- of the generated subprogram code, avoiding end effects. - - Scp.SC_PC := Scp.SC_PC - 8; - end if; - end Pop_Frame; - - ----------------------- - -- Set_Machine_State -- - ----------------------- - - procedure Set_Machine_State (M : Machine_State) is - - STOREI : constant String (1 .. 2) := 's' & LSC; - -- This is "sw" in o32 mode, and "sd" in n32 mode - - STOREF : constant String (1 .. 4) := 's' & LSC & "c1"; - -- This is "swc1" in o32 mode and "sdc1" in n32 mode - - Scp : Sigcontext_Ptr; - - begin - -- Save the integer registers. Note that we know that $4 points - -- to M, since that is where the first parameter is passed. - -- Restore integer registers from machine state. Note that we know - -- that $4 points to M since this is the standard calling sequence - - <> - - Asm (STOREI & " $16, 16*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (STOREI & " $17, 17*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (STOREI & " $18, 18*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (STOREI & " $19, 19*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (STOREI & " $20, 20*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (STOREI & " $21, 21*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (STOREI & " $22, 22*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (STOREI & " $23, 23*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (STOREI & " $24, 24*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (STOREI & " $25, 25*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (STOREI & " $26, 26*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (STOREI & " $27, 27*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (STOREI & " $28, 28*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (STOREI & " $29, 29*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (STOREI & " $30, 30*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - Asm (STOREI & " $31, 31*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); - - -- Restore floating-point registers from machine state - - Asm (STOREF & " $f16, 16*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (STOREF & " $f17, 17*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (STOREF & " $f18, 18*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (STOREF & " $f19, 19*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (STOREF & " $f20, 20*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (STOREF & " $f21, 21*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (STOREF & " $f22, 22*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (STOREF & " $f23, 23*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (STOREF & " $f24, 24*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (STOREF & " $f25, 25*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (STOREF & " $f26, 26*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (STOREF & " $f27, 27*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (STOREF & " $f28, 28*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (STOREF & " $f29, 29*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (STOREF & " $f30, 30*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - Asm (STOREF & " $f31, 31*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); - - -- Set the PC value for the context to a location after the - -- prolog has been executed. - - Scp := To_Sigcontext_Ptr (M); - Scp.SC_PC := Uns64 (To_Addr_Int (Past_Prolog'Address)); - - -- We saved the state *inside* this routine, but what we want is - -- the state at the call site. So we need to do one pop operation. - -- This pop operation will properly set the PC value in the machine - -- state, so there is no need to save PC in the above code. - - Pop_Frame (M, Set_Machine_State'Address); - end Set_Machine_State; - - ------------------------------ - -- Set_Signal_Machine_State -- - ------------------------------ - - procedure Set_Signal_Machine_State - (M : Machine_State; - Context : System.Address) - is - pragma Warnings (Off, M); - pragma Warnings (Off, Context); - - begin - null; - end Set_Signal_Machine_State; - -end System.Machine_State_Operations; diff --git a/gcc/ada/5gml-tgt.adb b/gcc/ada/5gml-tgt.adb deleted file mode 100644 index c18819918dd..00000000000 --- a/gcc/ada/5gml-tgt.adb +++ /dev/null @@ -1,363 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T -- --- (IRIX Version) -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2004, 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. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a set of target dependent routines to build --- static, dynamic and shared libraries. - --- This is the IRIX version of the body. - -with MLib.Fil; -with MLib.Utl; -with Namet; use Namet; -with Opt; -with Output; use Output; -with Prj.Com; -with System; - -package body MLib.Tgt is - - No_Arguments : aliased Argument_List := (1 .. 0 => null); - Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; - - Wl_Init_String : aliased String := "-Wl,-init"; - Wl_Init : constant String_Access := Wl_Init_String'Access; - Wl_Fini_String : aliased String := "-Wl,-fini"; - Wl_Fini : constant String_Access := Wl_Fini_String'Access; - - Init_Fini_List : constant Argument_List_Access := - new Argument_List'(1 => Wl_Init, - 2 => null, - 3 => Wl_Fini, - 4 => null); - -- Used to put switches for automatic elaboration/finalization - - --------------------- - -- Archive_Builder -- - --------------------- - - function Archive_Builder return String is - begin - return "ar"; - end Archive_Builder; - - ----------------------------- - -- Archive_Builder_Options -- - ----------------------------- - - function Archive_Builder_Options return String_List_Access is - begin - return new String_List'(1 => new String'("cr")); - end Archive_Builder_Options; - - ----------------- - -- Archive_Ext -- - ----------------- - - function Archive_Ext return String is - begin - return "a"; - end Archive_Ext; - - --------------------- - -- Archive_Indexer -- - --------------------- - - function Archive_Indexer return String is - begin - return "ranlib"; - end Archive_Indexer; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Foreign : Argument_List; - Afiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Address : String := ""; - Lib_Version : String := ""; - Relocatable : Boolean := False; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Foreign); - pragma Unreferenced (Afiles); - pragma Unreferenced (Interfaces); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Lib_Address); - pragma Unreferenced (Relocatable); - - Lib_File : constant String := - Lib_Dir & Directory_Separator & "lib" & - MLib.Fil.Ext_To (Lib_Filename, DLL_Ext); - - Version_Arg : String_Access; - Symbolic_Link_Needed : Boolean := False; - - Init_Fini : Argument_List_Access := Empty_Argument_List; - - begin - if Opt.Verbose_Mode then - Write_Str ("building relocatable shared library "); - Write_Line (Lib_File); - end if; - - -- If specified, add automatic elaboration/finalization - if Auto_Init then - Init_Fini := Init_Fini_List; - Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init"); - Init_Fini (4) := new String'("-Wl," & Lib_Filename & "final"); - end if; - - if Lib_Version = "" then - MLib.Utl.Gcc - (Output_File => Lib_File, - Objects => Ofiles, - Options => Options & Init_Fini.all, - Driver_Name => Driver_Name); - - else - Version_Arg := new String'("-Wl,-soname," & Lib_Version); - - if Is_Absolute_Path (Lib_Version) then - MLib.Utl.Gcc - (Output_File => Lib_Version, - Objects => Ofiles, - Options => Options & Version_Arg & Init_Fini.all, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := Lib_Version /= Lib_File; - - else - MLib.Utl.Gcc - (Output_File => Lib_Dir & Directory_Separator & Lib_Version, - Objects => Ofiles, - Options => Options & Version_Arg & Init_Fini.all, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := - Lib_Dir & Directory_Separator & Lib_Version /= Lib_File; - end if; - - if Symbolic_Link_Needed then - declare - Success : Boolean; - Oldpath : String (1 .. Lib_Version'Length + 1); - Newpath : String (1 .. Lib_File'Length + 1); - - Result : Integer; - pragma Unreferenced (Result); - - function Symlink - (Oldpath : System.Address; - Newpath : System.Address) - return Integer; - pragma Import (C, Symlink, "__gnat_symlink"); - - begin - Oldpath (1 .. Lib_Version'Length) := Lib_Version; - Oldpath (Oldpath'Last) := ASCII.NUL; - Newpath (1 .. Lib_File'Length) := Lib_File; - Newpath (Newpath'Last) := ASCII.NUL; - - Delete_File (Lib_File, Success); - - Result := Symlink (Oldpath'Address, Newpath'Address); - end; - end if; - end if; - end Build_Dynamic_Library; - - ------------------------- - -- Default_DLL_Address -- - ------------------------- - - function Default_DLL_Address return String is - begin - return ""; - end Default_DLL_Address; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return "so"; - end DLL_Ext; - - -------------------- - -- Dynamic_Option -- - -------------------- - - function Dynamic_Option return String is - begin - return "-shared"; - end Dynamic_Option; - - ------------------- - -- Is_Object_Ext -- - ------------------- - - function Is_Object_Ext (Ext : String) return Boolean is - begin - return Ext = ".o"; - end Is_Object_Ext; - - -------------- - -- Is_C_Ext -- - -------------- - - function Is_C_Ext (Ext : String) return Boolean is - begin - return Ext = ".c"; - end Is_C_Ext; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".a" or else Ext = ".so"; - end Is_Archive_Ext; - - ------------- - -- Libgnat -- - ------------- - - function Libgnat return String is - begin - return "libgnat.a"; - end Libgnat; - - ------------------------ - -- Library_Exists_For -- - ------------------------ - - function Library_Exists_For (Project : Project_Id) return Boolean is - begin - if not Projects.Table (Project).Library then - Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & - "for non library project"); - return False; - - else - declare - Lib_Dir : constant String := - Get_Name_String (Projects.Table (Project).Library_Dir); - Lib_Name : constant String := - Get_Name_String (Projects.Table (Project).Library_Name); - - begin - if Projects.Table (Project).Library_Kind = Static then - return Is_Regular_File - (Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - return Is_Regular_File - (Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - end; - end if; - end Library_Exists_For; - - --------------------------- - -- Library_File_Name_For -- - --------------------------- - - function Library_File_Name_For (Project : Project_Id) return Name_Id is - begin - if not Projects.Table (Project).Library then - Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & - "for non library project"); - return No_Name; - - else - declare - Lib_Name : constant String := - Get_Name_String (Projects.Table (Project).Library_Name); - - begin - Name_Len := 3; - Name_Buffer (1 .. Name_Len) := "lib"; - - if Projects.Table (Project).Library_Kind = Static then - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - - return Name_Find; - end; - end if; - end Library_File_Name_For; - - ---------------- - -- Object_Ext -- - ---------------- - - function Object_Ext return String is - begin - return "o"; - end Object_Ext; - - ---------------- - -- PIC_Option -- - ---------------- - - function PIC_Option return String is - begin - return "-fPIC"; - end PIC_Option; - - ----------------------------------------------- - -- Standalone_Library_Auto_Init_Is_Supported -- - ----------------------------------------------- - - function Standalone_Library_Auto_Init_Is_Supported return Boolean is - begin - return True; - end Standalone_Library_Auto_Init_Is_Supported; - - --------------------------- - -- Support_For_Libraries -- - --------------------------- - - function Support_For_Libraries return Library_Support is - begin - return Full; - end Support_For_Libraries; - -end MLib.Tgt; diff --git a/gcc/ada/5gosinte.ads b/gcc/ada/5gosinte.ads deleted file mode 100644 index e6df06813d7..00000000000 --- a/gcc/ada/5gosinte.ads +++ /dev/null @@ -1,699 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 an Irix (old pthread library) version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces; -with Interfaces.C; -with Interfaces.C.Strings; -with Unchecked_Conversion; - -package System.OS_Interface is - - pragma Preelaborate; - - pragma Linker_Options ("-lathread"); - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - subtype chars_ptr is Interfaces.C.Strings.chars_ptr; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EINTR : constant := 4; -- interrupted system call - EAGAIN : constant := 11; -- No more processes - ENOMEM : constant := 12; -- Not enough core - EINVAL : constant := 22; -- Invalid argument - ETIMEDOUT : constant := 145; -- Connection timed out - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 64; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the - -- future - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGUSR1 : constant := 16; -- user defined signal 1 - SIGUSR2 : constant := 17; -- user defined signal 2 - SIGCLD : constant := 18; -- alias for SIGCHLD - SIGCHLD : constant := 18; -- child status change - SIGPWR : constant := 19; -- power-fail restart - SIGWINCH : constant := 20; -- window size change - SIGURG : constant := 21; -- urgent condition on IO channel - SIGPOLL : constant := 22; -- pollable event occurred - SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias) - SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 24; -- user stop requested from tty - SIGCONT : constant := 25; -- stopped process has been continued - SIGTTIN : constant := 26; -- background tty read attempted - SIGTTOU : constant := 27; -- background tty write attempted - SIGVTALRM : constant := 28; -- virtual timer expired - SIGPROF : constant := 29; -- profiling timer expired - SIGXCPU : constant := 30; -- CPU time limit exceeded - SIGXFSZ : constant := 31; -- filesize limit exceeded - SIGK32 : constant := 32; -- reserved for kernel (IRIX) - SIGCKPT : constant := 33; -- Checkpoint warning - SIGRESTART : constant := 34; -- Restart warning - SIGUME : constant := 35; -- Uncorrectable memory error - -- Signals defined for Posix 1003.1c. - SIGPTINTR : constant := 47; - SIGPTRESCHED : constant := 48; - -- Posix 1003.1b signals - SIGRTMIN : constant := 49; -- Posix 1003.1b signals - SIGRTMAX : constant := 64; -- Posix 1003.1b signals - - type sigset_t is private; - type sigset_t_ptr is access all sigset_t; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type siginfo_t is record - si_signo : int; - si_code : int; - si_errno : int; - bit_field_substitute_1 : String (1 .. 116); - end record; - pragma Convention (C, siginfo_t); - - type array_type_2 is array (Integer range 0 .. 1) of int; - type struct_sigaction is record - sa_flags : int; - sa_handler : System.Address; - sa_mask : sigset_t; - sa_resv : array_type_2; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - SIG_BLOCK : constant := 1; - SIG_UNBLOCK : constant := 2; - SIG_SETMASK : constant := 3; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr := null) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - type time_t is new int; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - type timespec_ptr is access all timespec; - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type timer_t is new Integer; - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - CLOCK_SGI_FAST : constant clockid_t; - CLOCK_SGI_CYCLE : constant clockid_t; - - SGI_CYCLECNTR_SIZE : constant := 165; - function syssgi (request : Interfaces.C.int) return Interfaces.C.ptrdiff_t; - - pragma Import (C, syssgi, "syssgi"); - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; - pragma Import (C, clock_gettime, "clock_gettime"); - - function clock_getres - (clock_id : clockid_t; tp : access timespec) return int; - pragma Import (C, clock_getres, "clock_getres"); - - type struct_timeval is record - tv_sec : time_t; - tv_usec : time_t; - end record; - pragma Convention (C, struct_timeval); - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - function gettimeofday - (tv : access struct_timeval; - tz : System.Address := System.Null_Address) return int; - pragma Import (C, gettimeofday, "gettimeofday"); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 0; - SCHED_RR : constant := 0; - SCHED_OTHER : constant := 0; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - procedure pthread_init; - pragma Inline (pthread_init); - -- This is a dummy procedure to share some GNULLI files - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; -- thread identifier - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is private; -- mutex identifier - type pthread_cond_t is private; -- cond identifier - type pthread_attr_t is private; -- pthread attributes - type pthread_mutexattr_t is private; -- mutex attributes - type pthread_condattr_t is private; -- mutex attributes - type sem_t is private; -- semaphore identifier - type pthread_key_t is private; -- per thread key - - subtype pthread_once_t is int; -- dynamic package initialization - subtype resource_t is long; -- sproc. resource info. - type start_addr is access function (arg : Address) return Address; - type sproc_start_addr is access function (arg : Address) return int; - type callout_addr is - access function (arg : Address; arg1 : Address) return Address; - - -- SGI specific types - - subtype sproc_t is Address; -- sproc identifier - subtype sproc_attr_t is Address; -- sproc attributes - - subtype spcb_p is Address; - subtype ptcb_p is Address; - - -- Pthread Error Types - - FUNC_OK : constant := 0; - FUNC_ERR : constant := -1; - - -- pthread run-time initialization data structure - - type pthread_init_struct is record - conf_initsize : int; -- shared area size - max_sproc_count : int; -- maximum number of sprocs - sproc_stack_size : size_t; -- sproc stack size - os_default_priority : int; -- default IRIX pri for main process - os_sched_signal : int; -- default OS scheduling signal - guard_pages : int; -- number of guard pages per stack - init_sproc_count : int; -- initial number of sprocs - end record; - - -- - -- Pthread Attribute Initialize / Destroy - -- - - function pthread_attr_init (attr : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "pthread_attr_init"); - - function pthread_attr_destroy (attr : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); - - -- - -- Thread Attributes - -- - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; detachstate : int) return int; - pragma Import (C, pthread_attr_setdetachstate); - - function pthread_attr_setname - (attr : access pthread_attr_t; name : chars_ptr) return int; - pragma Import (C, pthread_attr_setname, "pthread_attr_setname"); - - -- - -- Thread Scheduling Attributes - -- - - function pthread_attr_setscope - (attr : access pthread_attr_t; contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; inherit : int) return int; - pragma Import - (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched"); - - function pthread_attr_setsched - (attr : access pthread_attr_t; scheduler : int) return int; - pragma Import (C, pthread_attr_setsched, "pthread_attr_setsched"); - - function pthread_attr_setprio - (attr : access pthread_attr_t; priority : int) return int; - pragma Import (C, pthread_attr_setprio, "pthread_attr_setprio"); - - -- - -- SGI Extensions to Thread Attributes - -- - - -- Bound to sproc attribute values - - PTHREAD_BOUND : constant := 1; - PTHREAD_NOT_BOUND : constant := 0; - - function pthread_attr_setresources - (attr : access pthread_attr_t; resources : resource_t) return int; - pragma Import (C, pthread_attr_setresources, "pthread_attr_setresources"); - - function pthread_attr_set_boundtosproc - (attr : access pthread_attr_t; bound_to_sproc : int) return int; - pragma Import - (C, pthread_attr_set_boundtosproc, "pthread_attr_set_boundtosproc"); - - function pthread_attr_set_bsproc - (attr : access pthread_attr_t; bsproc : spcb_p) return int; - pragma Import (C, pthread_attr_set_bsproc, "pthread_attr_set_bsproc"); - - function pthread_attr_set_tslice - (attr : access pthread_attr_t; - ts_interval : access struct_timeval) return int; - pragma Import (C, pthread_attr_set_tslice, "pthread_attr_set_tslice"); - - -- - -- Thread Creation & Management - -- - - function pthread_create - (thread : access pthread_t; - attr : access pthread_attr_t; - start_routine : start_addr; - arg : Address) return int; - pragma Import (C, pthread_create, "pthread_create"); - - procedure pthread_exit (status : Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - procedure pthread_yield (arg : Address := System.Null_Address); - pragma Import (C, pthread_yield, "pthread_yield"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - function pthread_kill (thread : pthread_t; sig : int) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - -- - -- SGI Extensions to POSIX thread operations - -- - - function pthread_setprio (thread : pthread_t; priority : int) return int; - pragma Import (C, pthread_setprio, "pthread_setprio"); - - function pthread_suspend (thread : pthread_t) return int; - pragma Import (C, pthread_suspend, "pthread_suspend"); - - function pthread_resume (thread : pthread_t) return int; - pragma Import (C, pthread_resume, "pthread_resume"); - - function pthread_get_current_ada_tcb return Address; - pragma Import (C, pthread_get_current_ada_tcb); - - function pthread_set_ada_tcb - (thread : pthread_t; data : Address) return int; - pragma Import (C, pthread_set_ada_tcb, "pthread_set_ada_tcb"); - - -- Mutex Initialization / Destruction - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutexattr_setqueueorder - (attr : access pthread_mutexattr_t; order : int) return int; - pragma Import (C, pthread_mutexattr_setqueueorder); - - function pthread_mutexattr_setceilingprio - (attr : access pthread_mutexattr_t; priority : int) return int; - pragma Import (C, pthread_mutexattr_setceilingprio); - - -- Mutex Attributes - - -- Threads queueing order - - MUTEX_PRIORITY : constant := 0; -- wait in priority order - MUTEX_FIFO : constant := 1; -- first-in-first-out - MUTEX_PRIORITY_INHERIT : constant := 2; -- priority inhertance mutex - MUTEX_PRIORITY_CEILING : constant := 3; -- priority ceiling mutex - - -- Mutex debugging options - - MUTEX_NO_DEBUG : constant := 0; -- no debugging on mutex - MUTEX_DEBUG : constant := 1; -- debugging is on - - -- Mutex spin on lock operations - - MUTEX_NO_SPIN : constant := 0; -- no spin, try once only - MUTEX_SPIN_ONLY : constant := -1; -- spin forever - -- cnt > 0, limited spin - -- Mutex sharing attributes - - MUTEX_SHARED : constant := 0; -- shared between processes - MUTEX_NOTSHARED : constant := 1; -- not shared between processes - - -- Mutex Operations - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy - (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock - (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); - - function pthread_mutex_unlock - (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); - - -- Condition Initialization / Destruction - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); - - -- Condition Attributes - - COND_PRIORITY : constant := 0; -- wait in priority order - COND_FIFO : constant := 1; -- first-in-first-out - - -- Condition debugging options - - COND_NO_DEBUG : constant := 0; -- no debugging on mutex - COND_DEBUG : constant := 1; -- debugging is on - - -- Condition sharing attributes - - COND_SHARED : constant := 0; -- shared between processes - COND_NOTSHARED : constant := 1; -- not shared between processes - - -- Condition Operations - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "pthread_cond_init"); - - function pthread_cond_destroy - (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access struct_timeval) return int; - pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); - - -- Thread-Specific Data - - type foo_h_proc_1 is access procedure (value : Address); - - function pthread_key_create - (key : access pthread_key_t; destructor : foo_h_proc_1) return int; - pragma Import (C, pthread_key_create, "pthread_key_create"); - - function pthread_setspecific - (key : pthread_key_t; value : Address) return int; - pragma Import (C, pthread_setspecific, "pthread_setspecific"); - - function pthread_getspecific - (key : pthread_key_t; value : access Address) return int; - pragma Import (C, pthread_getspecific, "pthread_getspecific"); - - type foo_h_proc_2 is access procedure; - - function pthread_exec_begin (init : access pthread_init_struct) return int; - pragma Import (C, pthread_exec_begin, "pthread_exec_begin"); - - function sproc_create - (sproc_id : access sproc_t; - attr : access sproc_attr_t; - start_routine : sproc_start_addr; - arg : Address) return int; - pragma Import (C, sproc_create, "sproc_create"); - - function sproc_self return sproc_t; - pragma Import (C, sproc_self, "sproc_self"); - - -- if equal fast TRUE is returned - common case - -- if not equal thread resource must NOT be null in order to compare bits - - -- - -- Sproc attribute initialize / destroy - -- - - function sproc_attr_init (attr : access sproc_attr_t) return int; - pragma Import (C, sproc_attr_init, "sproc_attr_init"); - - function sproc_attr_destroy (attr : access sproc_attr_t) return int; - pragma Import (C, sproc_attr_destroy, "sproc_attr_destroy"); - - function sproc_attr_setresources - (attr : access sproc_attr_t; resources : resource_t) return int; - pragma Import (C, sproc_attr_setresources, "sproc_attr_setresources"); - - function sproc_attr_getresources - (attr : access sproc_attr_t; - resources : access resource_t) return int; - pragma Import (C, sproc_attr_getresources, "sproc_attr_getresources"); - - function sproc_attr_setcpu - (attr : access sproc_attr_t; cpu_num : int) return int; - pragma Import (C, sproc_attr_setcpu, "sproc_attr_setcpu"); - - function sproc_attr_getcpu - (attr : access sproc_attr_t; cpu_num : access int) return int; - pragma Import (C, sproc_attr_getcpu, "sproc_attr_getcpu"); - - function sproc_attr_setresident - (attr : access sproc_attr_t; resident : int) return int; - pragma Import (C, sproc_attr_setresident, "sproc_attr_setresident"); - - function sproc_attr_getresident - (attr : access sproc_attr_t; resident : access int) return int; - pragma Import (C, sproc_attr_getresident, "sproc_attr_getresident"); - - function sproc_attr_setname - (attr : access sproc_attr_t; name : chars_ptr) return int; - pragma Import (C, sproc_attr_setname, "sproc_attr_setname"); - - function sproc_attr_getname - (attr : access sproc_attr_t; name : chars_ptr) return int; - pragma Import (C, sproc_attr_getname, "sproc_attr_getname"); - - function sproc_attr_setstacksize - (attr : access sproc_attr_t; stacksize : size_t) return int; - pragma Import (C, sproc_attr_setstacksize, "sproc_attr_setstacksize"); - - function sproc_attr_getstacksize - (attr : access sproc_attr_t; stacksize : access size_t) return int; - pragma Import (C, sproc_attr_getstacksize, "sproc_attr_getstacksize"); - - function sproc_attr_setprio - (attr : access sproc_attr_t; priority : int) return int; - pragma Import (C, sproc_attr_setprio, "sproc_attr_setprio"); - - function sproc_attr_getprio - (attr : access sproc_attr_t; priority : access int) return int; - pragma Import (C, sproc_attr_getprio, "sproc_attr_getprio"); - - function sproc_attr_setbthread - (attr : access sproc_attr_t; bthread : ptcb_p) return int; - pragma Import (C, sproc_attr_setbthread, "sproc_attr_setbthread"); - - function sproc_attr_getbthread - (attr : access sproc_attr_t; bthread : access ptcb_p) return int; - pragma Import (C, sproc_attr_getbthread, "sproc_attr_getbthread"); - - SPROC_NO_RESOURCES : constant := 0; - SPROC_ANY_CPU : constant := -1; - SPROC_MY_PRIORITY : constant := -1; - SPROC_SWAPPED : constant := 0; - SPROC_RESIDENT : constant := 1; - - type isr_address is access procedure; - - function intr_attach (sig : int; isr : isr_address) return int; - pragma Import (C, intr_attach, "intr_attach"); - - Intr_Attach_Reset : constant Boolean := False; - -- True if intr_attach is reset after an interrupt handler is called - - function intr_exchange - (sig : int; - isr : isr_address; - oisr : access isr_address) return int; - pragma Import (C, intr_exchange, "intr_exchange"); - - function intr_current_isr - (sig : int; - oisr : access isr_address) - return int; - pragma Import (C, intr_current_isr, "intr_current_isr"); - -private - - type clockid_t is new int; - - CLOCK_REALTIME : constant clockid_t := 1; - CLOCK_SGI_CYCLE : constant clockid_t := 2; - CLOCK_SGI_FAST : constant clockid_t := 3; - - type pthread_t is new Address; -- thread identifier - type pthread_mutex_t is new Address; -- mutex identifier - type pthread_cond_t is new Address; -- cond identifier - type pthread_attr_t is new Address; -- pthread attributes - type pthread_mutexattr_t is new Address; -- mutex attributes - type pthread_condattr_t is new Address; -- mutex attributes - type sem_t is new Address; -- semaphore identifier - type pthread_key_t is new Address; -- per thread key - - type sigbits_t is array (Integer range 0 .. 3) of unsigned; - type sigset_t is record - sigbits : sigbits_t; - end record; - pragma Convention (C, sigset_t); - - type pid_t is new long; - -end System.OS_Interface; diff --git a/gcc/ada/5gproinf.adb b/gcc/ada/5gproinf.adb deleted file mode 100644 index 3e6bbc9557d..00000000000 --- a/gcc/ada/5gproinf.adb +++ /dev/null @@ -1,221 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P R O G R A M _ I N F O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-1999 Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is an Irix (old pthread library) version of this package. - --- This package contains the parameters used by the run-time system at --- program startup. These parameters are isolated in this package body to --- facilitate replacement by the end user. --- --- To replace the default values, copy this source file into your build --- directory, edit the file to reflect your desired behavior, and recompile --- with the command: --- --- % gcc -c -O2 -gnatpg s-proinf.adb --- --- then relink your application as usual. --- - -with GNAT.OS_Lib; - -package body System.Program_Info is - - Kbytes : constant := 1024; - - Default_Initial_Sproc_Count : constant := 0; - Default_Max_Sproc_Count : constant := 128; - Default_Sproc_Stack_Size : constant := 16#4000#; - Default_Stack_Guard_Pages : constant := 1; - Default_Default_Time_Slice : constant := 0.0; - Default_Default_Task_Stack : constant := 12 * Kbytes; - Default_Pthread_Sched_Signal : constant := 35; - Default_Pthread_Arena_Size : constant := 16#40000#; - Default_Os_Default_Priority : constant := 0; - - ------------------------- - -- Initial_Sproc_Count -- - ------------------------- - - function Initial_Sproc_Count return Integer is - - function sysmp (P1 : Integer) return Integer; - pragma Import (C, sysmp, "sysmp", "sysmp"); - - MP_NPROCS : constant := 1; -- # processor in complex - - Pthread_Sproc_Count : constant GNAT.OS_Lib.String_Access := - GNAT.OS_Lib.Getenv ("PTHREAD_SPROC_COUNT"); - - begin - if Pthread_Sproc_Count.all'Length = 0 then - return Default_Initial_Sproc_Count; - - elsif Pthread_Sproc_Count.all = "AUTO" then - return sysmp (MP_NPROCS); - - else - return Integer'Value (Pthread_Sproc_Count.all); - end if; - exception - when others => - return Default_Initial_Sproc_Count; - end Initial_Sproc_Count; - - --------------------- - -- Max_Sproc_Count -- - --------------------- - - function Max_Sproc_Count return Integer is - Pthread_Max_Sproc_Count : constant GNAT.OS_Lib.String_Access := - GNAT.OS_Lib.Getenv ("PTHREAD_MAX_SPROC_COUNT"); - - begin - if Pthread_Max_Sproc_Count.all'Length = 0 then - return Default_Max_Sproc_Count; - else - return Integer'Value (Pthread_Max_Sproc_Count.all); - end if; - exception - when others => - return Default_Max_Sproc_Count; - end Max_Sproc_Count; - - ---------------------- - -- Sproc_Stack_Size -- - ---------------------- - - function Sproc_Stack_Size return Integer is - begin - return Default_Sproc_Stack_Size; - end Sproc_Stack_Size; - - ------------------------ - -- Default_Time_Slice -- - ------------------------ - - function Default_Time_Slice return Duration is - Pthread_Time_Slice_Sec : constant GNAT.OS_Lib.String_Access := - GNAT.OS_Lib.Getenv ("PTHREAD_TIME_SLICE_SEC"); - Pthread_Time_Slice_Usec : constant GNAT.OS_Lib.String_Access := - GNAT.OS_Lib.Getenv ("PTHREAD_TIME_SLICE_USEC"); - - Val_Sec, Val_Usec : Integer := 0; - - begin - if Pthread_Time_Slice_Sec.all'Length /= 0 or - Pthread_Time_Slice_Usec.all'Length /= 0 - then - if Pthread_Time_Slice_Sec.all'Length /= 0 then - Val_Sec := Integer'Value (Pthread_Time_Slice_Sec.all); - end if; - - if Pthread_Time_Slice_Usec.all'Length /= 0 then - Val_Usec := Integer'Value (Pthread_Time_Slice_Usec.all); - end if; - - return Duration (Val_Sec) + Duration (Val_Usec) / 1000.0; - else - return Default_Default_Time_Slice; - end if; - - exception - when others => - return Default_Default_Time_Slice; - end Default_Time_Slice; - - ------------------------ - -- Default_Task_Stack -- - ------------------------ - - function Default_Task_Stack return Integer is - begin - return Default_Default_Task_Stack; - end Default_Task_Stack; - - ----------------------- - -- Stack_Guard_Pages -- - ----------------------- - - function Stack_Guard_Pages return Integer is - Pthread_Stack_Guard_Pages : constant GNAT.OS_Lib.String_Access := - GNAT.OS_Lib.Getenv ("PTHREAD_STACK_GUARD_PAGES"); - - begin - if Pthread_Stack_Guard_Pages.all'Length /= 0 then - return Integer'Value (Pthread_Stack_Guard_Pages.all); - else - return Default_Stack_Guard_Pages; - end if; - exception - when others => - return Default_Stack_Guard_Pages; - end Stack_Guard_Pages; - - -------------------------- - -- Pthread_Sched_Signal -- - -------------------------- - - function Pthread_Sched_Signal return Integer is - begin - return Default_Pthread_Sched_Signal; - end Pthread_Sched_Signal; - - ------------------------ - -- Pthread_Arena_Size -- - ------------------------ - - function Pthread_Arena_Size return Integer is - Pthread_Arena_Size : constant GNAT.OS_Lib.String_Access := - GNAT.OS_Lib.Getenv ("PTHREAD_ARENA_SIZE"); - - begin - if Pthread_Arena_Size.all'Length = 0 then - return Default_Pthread_Arena_Size; - else - return Integer'Value (Pthread_Arena_Size.all); - end if; - exception - when others => - return Default_Pthread_Arena_Size; - end Pthread_Arena_Size; - - ------------------------- - -- Os_Default_Priority -- - ------------------------- - - function Os_Default_Priority return Integer is - begin - return Default_Os_Default_Priority; - end Os_Default_Priority; - -end System.Program_Info; diff --git a/gcc/ada/5gproinf.ads b/gcc/ada/5gproinf.ads deleted file mode 100644 index a4259c3c916..00000000000 --- a/gcc/ada/5gproinf.ads +++ /dev/null @@ -1,96 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P R O G R A M _ I N F O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1997-2003 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 contains the definitions and routines used as parameters --- to the run-time system at program startup for the SGI implementation. - -package System.Program_Info is - - function Initial_Sproc_Count return Integer; - -- - -- The number of sproc created at program startup for scheduling - -- threads. - -- - - function Max_Sproc_Count return Integer; - -- - -- The maximum number of sprocs that can be created by the program - -- for servicing threads. This limit includes both the pre-created - -- sprocs and those explicitly created under program control. - -- - - function Sproc_Stack_Size return Integer; - -- - -- The size, in bytes, of the sproc's initial stack. - -- - - function Default_Time_Slice return Duration; - -- - -- The default time quanta for round-robin scheduling of threads of - -- equal priority. This default value can be overridden on a per-task - -- basis by specifying an alternate value via the implementation-defined - -- Task_Info pragma. See s-tasinf.ads for more information. - -- - - function Default_Task_Stack return Integer; - -- - -- The default stack size for each created thread. This default value - -- can be overriden on a per-task basis by the language-defined - -- Storage_Size pragma. - -- - - function Stack_Guard_Pages return Integer; - -- - -- The number of non-writable, guard pages to append to the bottom of - -- each thread's stack. - -- - - function Pthread_Sched_Signal return Integer; - -- - -- The signal used by the Pthreads library to affect scheduling actions - -- in remote sprocs. - -- - - function Pthread_Arena_Size return Integer; - -- - -- The size of the shared arena from which pthread locks are allocated. - -- See the usinit(3p) man page for more information on shared arenas. - -- - - function Os_Default_Priority return Integer; - -- - -- The default Irix Non-Degrading priority for each sproc created to - -- service threads. - -- - -end System.Program_Info; diff --git a/gcc/ada/5gsystem.ads b/gcc/ada/5gsystem.ads deleted file mode 100644 index 2a2c5f4f026..00000000000 --- a/gcc/ada/5gsystem.ads +++ /dev/null @@ -1,153 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (SGI Irix, n32 ABI) -- --- -- --- 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 := 0.01; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 64; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := False; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := True; - 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 := False; - 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 := True; - - -- Note: Denorm is False because denormals are not supported on the - -- R10000, and we want the code to be valid for this processor. - -end System; diff --git a/gcc/ada/5gtaprop.adb b/gcc/ada/5gtaprop.adb deleted file mode 100644 index 3c70a347ef2..00000000000 --- a/gcc/ada/5gtaprop.adb +++ /dev/null @@ -1,955 +0,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 . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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 an Irix (old athread library) version of this package - --- This package contains all the GNULL primitives that interface directly --- with the underlying OS. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with Interfaces.C; --- used for int --- size_t - -with System.Tasking.Debug; --- used for Known_Tasks - -with System.Task_Info; - -with System.Interrupt_Management; --- used for Keep_Unmasked --- Abort_Task_Interrupt --- Interrupt_ID - -with System.Parameters; --- used for Size_Type - -with System.Tasking; --- used for Ada_Task_Control_Block --- Task_ID - -with System.Program_Info; --- used for Default_Task_Stack --- Default_Time_Slice --- Stack_Guard_Pages --- Pthread_Sched_Signal --- Pthread_Arena_Size - -with System.Soft_Links; --- used for Defer/Undefer_Abort - --- Note that we do not use System.Tasking.Initialization directly since --- this is a higher level package that we shouldn't depend on. For example --- when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Initialization - -with System.OS_Primitives; --- used for Delay_Modes - -with System.Storage_Elements; --- used for To_Address - -with Unchecked_Conversion; -with Unchecked_Deallocation; - -package body System.Task_Primitives.Operations is - - use System.Tasking.Debug; - use System.Tasking; - use Interfaces.C; - use System.OS_Interface; - use System.Parameters; - use System.OS_Primitives; - - package SSL renames System.Soft_Links; - - ----------------- - -- Local Data -- - ----------------- - - -- The followings are logically constants, but need to be initialized - -- at run time. - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - - Environment_Task_ID : Task_ID; - -- A variable to hold Task_ID for the environment task. - - Locking_Policy : Character; - pragma Import (C, Locking_Policy, "__gl_locking_policy"); - - Clock_Address : constant System.Address := - System.Storage_Elements.To_Address (16#200F90#); - - RT_Clock_Id : clockid_t; - for RT_Clock_Id'Address use Clock_Address; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Initialize_Athread_Library; - - function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID); - - function To_Address is new Unchecked_Conversion (Task_ID, System.Address); - - ------------------- - -- Stack_Guard -- - ------------------- - - -- The underlying thread system sets a guard page at the - -- bottom of a thread stack, so nothing is needed. - -- ??? Check the comment above - - procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is - pragma Unreferenced (T); - pragma Unreferenced (On); - begin - null; - end Stack_Guard; - - -------------------- - -- Get_Thread_Id -- - -------------------- - - function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_ID is - begin - return To_Task_ID (pthread_get_current_ada_tcb); - end Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Initialize_TCB and the Storage_Error is - -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) - -- used in RTS is initialized before any status change of RTS. - -- Therefore rasing Storage_Error in the following routines - -- should be able to be handled safely. - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : access Lock) - is - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - - if Result = FUNC_ERR then - raise Storage_Error; - end if; - - if Locking_Policy = 'C' then - - Result := pthread_mutexattr_setqueueorder - (Attributes'Access, MUTEX_PRIORITY_CEILING); - - pragma Assert (Result /= FUNC_ERR); - - Result := pthread_mutexattr_setceilingprio - (Attributes'Access, Interfaces.C.int (Prio)); - - pragma Assert (Result /= FUNC_ERR); - end if; - - Result := pthread_mutex_init (L, Attributes'Access); - - if Result = FUNC_ERR then - Result := pthread_mutexattr_destroy (Attributes'Access); - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - end Initialize_Lock; - - procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is - pragma Unreferenced (Level); - - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - - if Result = FUNC_ERR then - raise Storage_Error; - end if; - - if Locking_Policy = 'C' then - Result := pthread_mutexattr_setqueueorder - (Attributes'Access, MUTEX_PRIORITY_CEILING); - pragma Assert (Result /= FUNC_ERR); - - Result := pthread_mutexattr_setceilingprio - (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); - pragma Assert (Result /= FUNC_ERR); - end if; - - Result := pthread_mutex_init (L, Attributes'Access); - - if Result = FUNC_ERR then - Result := pthread_mutexattr_destroy (Attributes'Access); - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0); - end Finalize_Lock; - - procedure Finalize_Lock (L : access RTS_Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0); - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_lock (L); - Ceiling_Violation := Result = FUNC_ERR and then errno = EINVAL; - pragma Assert (Result /= FUNC_ERR); - end Write_Lock; - - procedure Write_Lock - (L : access RTS_Lock; Global_Lock : Boolean := False) - is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_lock (L); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - procedure Write_Lock (T : Task_ID) is - Result : Interfaces.C.int; - begin - if not Single_Lock then - Result := pthread_mutex_lock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - begin - Write_Lock (L, Ceiling_Violation); - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); - end Unlock; - - procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); - end if; - end Unlock; - - procedure Unlock (T : Task_ID) is - Result : Interfaces.C.int; - begin - if not Single_Lock then - Result := pthread_mutex_unlock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Unlock; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : ST.Task_ID; - Reason : System.Tasking.Task_States) - is - pragma Unreferenced (Reason); - - Result : Interfaces.C.int; - - begin - if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; - - -- EINTR is not considered a failure. - - pragma Assert (Result = 0 or else Result = EINTR); - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - procedure Timed_Sleep - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : System.Tasking.Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Unreferenced (Reason); - - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased struct_timeval; - Result : Interfaces.C.int; - - begin - Timedout := True; - Yielded := False; - - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; - - if Abs_Time > Check_Time then - Request := To_Timeval (Abs_Time); - - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; - - if Single_Lock then - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, - Request'Access); - - else - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, - Request'Access); - end if; - - exit when Abs_Time <= Monotonic_Clock; - - if Result = 0 or Result = EINTR then - -- somebody may have called Wakeup for us - Timedout := False; - exit; - end if; - - pragma Assert (Result = ETIMEDOUT - or else (Result = -1 and then errno = EAGAIN)); - end loop; - end if; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes) - is - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased struct_timeval; - Result : Interfaces.C.int; - - begin - -- Only the little window between deferring abort and - -- locking Self_ID is the reason we need to - -- check for pending abort and priority change below! - - SSL.Abort_Defer.all; - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - - if Mode = Relative then - Abs_Time := Time + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; - - if Abs_Time > Check_Time then - Request := To_Timeval (Abs_Time); - Self_ID.Common.State := Delay_Sleep; - - loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - if Single_Lock then - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, Request'Access); - else - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Request'Access); - end if; - - exit when Abs_Time <= Monotonic_Clock; - - pragma Assert (Result = 0 or else - Result = ETIMEDOUT or else - (Result = -1 and then errno = EAGAIN) or else - Result = EINTR); - end loop; - - Self_ID.Common.State := Runnable; - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - pthread_yield; - SSL.Abort_Undefer.all; - end Timed_Delay; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration is - type timeval is record - tv_sec : Integer; - tv_usec : Integer; - end record; - pragma Convention (C, timeval); - - tv : aliased timeval; - - procedure gettimeofday (tp : access timeval); - pragma Import (C, gettimeofday, "gettimeofday", "gettimeofday"); - - begin - gettimeofday (tv'Access); - return Duration (tv.tv_sec) + Duration (tv.tv_usec) / 1_000_000.0; - end Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - begin - return 10#1.0#E-6; - end RT_Resolution; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup - (T : ST.Task_ID; - Reason : System.Tasking.Task_States) - is - pragma Unreferenced (Reason); - Result : Interfaces.C.int; - begin - Result := pthread_cond_signal (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Wakeup; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - begin - if Do_Yield then - pthread_yield; - end if; - end Yield; - - ------------------ - -- Set_Priority -- - ------------------ - - procedure Set_Priority - (T : Task_ID; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) - is - pragma Unreferenced (Loss_Of_Inheritance); - - Result : Interfaces.C.int; - - begin - T.Common.Current_Priority := Prio; - Result := pthread_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio)); - pragma Assert (Result /= FUNC_ERR); - - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_ID) return System.Any_Priority is - begin - return T.Common.Current_Priority; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (Self_ID : Task_ID) is - Result : Interfaces.C.int; - - begin - Self_ID.Common.LL.Thread := pthread_self; - Self_ID.Common.LL.LWP := sproc_self; - - Result := - pthread_set_ada_tcb (Self_ID.Common.LL.Thread, To_Address (Self_ID)); - - pragma Assert (Result = 0); - - Lock_RTS; - - for J in Known_Tasks'Range loop - if Known_Tasks (J) = null then - Known_Tasks (J) := Self_ID; - Self_ID.Known_Tasks_Index := J; - exit; - end if; - end loop; - - Unlock_RTS; - end Enter_Task; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean is - begin - return False; - end Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_ID is - begin - return null; - end Register_Foreign_Thread; - - ---------------------- - -- Initialize_TCB -- - ---------------------- - - procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is - Result : Interfaces.C.int; - Cond_Attr : aliased pthread_condattr_t; - - begin - if not Single_Lock then - Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); - end if; - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result = 0 then - Succeeded := True; - else - if not Single_Lock then - Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Succeeded := False; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_ID; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - Attributes : aliased pthread_attr_t; - Adjusted_Stack_Size : Interfaces.C.size_t; - Result : Interfaces.C.int; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, start_addr); - - function To_Resource_T is new Unchecked_Conversion - (System.Task_Info.Resource_Vector_T, System.OS_Interface.resource_t); - - use System.Task_Info; - - begin - if Stack_Size = Unspecified_Size then - Adjusted_Stack_Size := - Interfaces.C.size_t (System.Program_Info.Default_Task_Stack); - - elsif Stack_Size < Minimum_Stack_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); - - else - Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); - end if; - - Result := pthread_attr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_attr_setdetachstate (Attributes'Access, 1); - pragma Assert (Result = 0); - - Result := pthread_attr_setstacksize - (Attributes'Access, Adjusted_Stack_Size); - pragma Assert (Result = 0); - - if T.Common.Task_Info /= null then - Result := pthread_attr_setresources - (Attributes'Access, - To_Resource_T (T.Common.Task_Info.Thread_Resources)); - pragma Assert (Result /= FUNC_ERR); - - if T.Common.Task_Info.Thread_Timeslice /= 0.0 then - declare - use System.OS_Interface; - - Tv : aliased struct_timeval := To_Timeval - (T.Common.Task_Info.Thread_Timeslice); - begin - Result := pthread_attr_set_tslice - (Attributes'Access, Tv'Access); - end; - end if; - - if T.Common.Task_Info.Bound_To_Sproc then - Result := pthread_attr_set_boundtosproc - (Attributes'Access, PTHREAD_BOUND); - Result := pthread_attr_set_bsproc - (Attributes'Access, T.Common.Task_Info.Sproc); - end if; - - end if; - - -- Since the initial signal mask of a thread is inherited from the - -- creator, and the Environment task has all its signals masked, we - -- do not need to manipulate caller's signal mask at this point. - -- All tasks in RTS will have All_Tasks_Mask initially. - - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); - pragma Assert (Result = 0 or else Result = EAGAIN); - - Succeeded := Result = 0; - - Set_Priority (T, Priority); - - Result := pthread_attr_destroy (Attributes'Access); - pragma Assert (Result /= FUNC_ERR); - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_ID) is - procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); - - Result : Interfaces.C.int; - Tmp : Task_ID := T; - - begin - if not Single_Lock then - Result := pthread_mutex_destroy (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_cond_destroy (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - Free (Tmp); - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - procedure Exit_Task is - Result : Interfaces.C.int; - begin - Result := pthread_set_ada_tcb (pthread_self, System.Null_Address); - pragma Assert (Result = 0); - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_ID) is - Result : Interfaces.C.int; - begin - Result := - pthread_kill (T.Common.LL.Thread, - Interfaces.C.int - (System.Interrupt_Management.Abort_Task_Interrupt)); - pragma Assert (Result = 0); - end Abort_Task; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy version - - function Check_Exit (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - - begin - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - begin - return True; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_ID is - begin - return Environment_Task_ID; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) return Boolean - is - begin - if T.Common.LL.Thread /= Thread_Self then - return pthread_suspend (T.Common.LL.Thread) = 0; - else - return True; - end if; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) return Boolean - is - begin - if T.Common.LL.Thread /= Thread_Self then - return pthread_resume (T.Common.LL.Thread) = 0; - else - return True; - end if; - end Resume_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_ID) is - begin - Environment_Task_ID := Environment_Task; - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - -- Initialize the lock used to synchronize chain of all ATCBs. - - Enter_Task (Environment_Task); - - Set_Priority (Environment_Task, - Environment_Task.Common.Current_Priority); - end Initialize; - - -------------------------------- - -- Initialize_Athread_Library -- - -------------------------------- - - procedure Initialize_Athread_Library is - Result : Interfaces.C.int; - Init : aliased pthread_init_struct; - - package PINF renames System.Program_Info; - package C renames Interfaces.C; - - begin - Init.conf_initsize := C.int (PINF.Pthread_Arena_Size); - Init.max_sproc_count := C.int (PINF.Max_Sproc_Count); - Init.sproc_stack_size := C.size_t (PINF.Sproc_Stack_Size); - Init.os_default_priority := C.int (PINF.Os_Default_Priority); - Init.os_sched_signal := C.int (PINF.Pthread_Sched_Signal); - Init.guard_pages := C.int (PINF.Stack_Guard_Pages); - Init.init_sproc_count := C.int (PINF.Initial_Sproc_Count); - - Result := pthread_exec_begin (Init'Access); - pragma Assert (Result /= FUNC_ERR); - - if Result = FUNC_ERR then - raise Storage_Error; -- Insufficient resources. - end if; - end Initialize_Athread_Library; - --- Package initialization - -begin - Initialize_Athread_Library; -end System.Task_Primitives.Operations; diff --git a/gcc/ada/5gtasinf.adb b/gcc/ada/5gtasinf.adb deleted file mode 100644 index 5413ebf8830..00000000000 --- a/gcc/ada/5gtasinf.adb +++ /dev/null @@ -1,312 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T A S K _ I N F O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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 package body contains the routines associated with the implementation --- of the Task_Info pragma. - --- This is the SGI specific version of this module. - -with Interfaces.C; -with System.OS_Interface; -with System; -with Unchecked_Conversion; - -package body System.Task_Info is - - use System.OS_Interface; - use type Interfaces.C.int; - - function To_Resource_T is new - Unchecked_Conversion (Resource_Vector_T, resource_t); - - MP_NPROCS : constant := 1; - - function Sysmp (Cmd : Integer) return Integer; - pragma Import (C, Sysmp); - - function Num_Processors (Cmd : Integer := MP_NPROCS) return Integer - renames Sysmp; - - function Geteuid return Integer; - pragma Import (C, Geteuid); - - Locking_Map : constant array (Page_Locking) of Interfaces.C.int := - (NOLOCK => 0, - PROCLOCK => 1, - TXTLOCK => 2, - DATLOCK => 4); - - ------------------------------- - -- Resource_Vector_Functions -- - ------------------------------- - - package body Resource_Vector_Functions is - - --------- - -- "+" -- - --------- - - function "+" (R : Resource_T) return Resource_Vector_T is - Result : Resource_Vector_T := NO_RESOURCES; - begin - Result (Resource_T'Pos (R)) := True; - return Result; - end "+"; - - function "+" (R1, R2 : Resource_T) return Resource_Vector_T is - Result : Resource_Vector_T := NO_RESOURCES; - begin - Result (Resource_T'Pos (R1)) := True; - Result (Resource_T'Pos (R2)) := True; - return Result; - end "+"; - - function "+" - (R : Resource_T; - S : Resource_Vector_T) return Resource_Vector_T - is - Result : Resource_Vector_T := S; - begin - Result (Resource_T'Pos (R)) := True; - return Result; - end "+"; - - function "+" - (S : Resource_Vector_T; - R : Resource_T) return Resource_Vector_T - is - Result : Resource_Vector_T := S; - begin - Result (Resource_T'Pos (R)) := True; - return Result; - end "+"; - - function "+" (S1, S2 : Resource_Vector_T) return Resource_Vector_T is - Result : Resource_Vector_T; - begin - Result := S1 or S2; - return Result; - end "+"; - - function "-" - (S : Resource_Vector_T; - R : Resource_T) return Resource_Vector_T - is - Result : Resource_Vector_T := S; - begin - Result (Resource_T'Pos (R)) := False; - return Result; - end "-"; - - end Resource_Vector_Functions; - - --------------- - -- New_Sproc -- - --------------- - - function New_Sproc (Attr : Sproc_Attributes) return sproc_t is - Sproc_Attr : aliased sproc_attr_t; - Sproc : aliased sproc_t; - Status : int; - - begin - Status := sproc_attr_init (Sproc_Attr'Unrestricted_Access); - - if Status = 0 then - Status := sproc_attr_setresources - (Sproc_Attr'Unrestricted_Access, - To_Resource_T (Attr.Sproc_Resources)); - - if Attr.CPU /= ANY_CPU then - if Attr.CPU > Num_Processors then - raise Invalid_CPU_Number; - end if; - - Status := sproc_attr_setcpu - (Sproc_Attr'Unrestricted_Access, - int (Attr.CPU)); - end if; - - if Attr.Resident /= NOLOCK then - if Geteuid /= 0 then - raise Permission_Error; - end if; - - Status := sproc_attr_setresident - (Sproc_Attr'Unrestricted_Access, - Locking_Map (Attr.Resident)); - end if; - - if Attr.NDPRI /= NDP_NONE then - --- ??? why is this commented out, should it be removed ? --- if Geteuid /= 0 then --- raise Permission_Error; --- end if; - - Status := - sproc_attr_setprio - (Sproc_Attr'Unrestricted_Access, int (Attr.NDPRI)); - end if; - - Status := - sproc_create - (Sproc'Unrestricted_Access, - Sproc_Attr'Unrestricted_Access, - null, - System.Null_Address); - - if Status /= 0 then - Status := sproc_attr_destroy (Sproc_Attr'Unrestricted_Access); - raise Sproc_Create_Error; - end if; - - Status := sproc_attr_destroy (Sproc_Attr'Unrestricted_Access); - end if; - - if Status /= 0 then - raise Sproc_Create_Error; - end if; - - return Sproc; - end New_Sproc; - - --------------- - -- New_Sproc -- - --------------- - - function New_Sproc - (Sproc_Resources : Resource_Vector_T := NO_RESOURCES; - CPU : CPU_Number := ANY_CPU; - Resident : Page_Locking := NOLOCK; - NDPRI : Non_Degrading_Priority := NDP_NONE) return sproc_t - is - Attr : constant Sproc_Attributes := - (Sproc_Resources, CPU, Resident, NDPRI); - begin - return New_Sproc (Attr); - end New_Sproc; - - ------------------------------- - -- Unbound_Thread_Attributes -- - ------------------------------- - - function Unbound_Thread_Attributes - (Thread_Resources : Resource_Vector_T := NO_RESOURCES; - Thread_Timeslice : Duration := 0.0) return Thread_Attributes - is - begin - return (False, Thread_Resources, Thread_Timeslice); - end Unbound_Thread_Attributes; - - ----------------------------- - -- Bound_Thread_Attributes -- - ----------------------------- - - function Bound_Thread_Attributes - (Thread_Resources : Resource_Vector_T := NO_RESOURCES; - Thread_Timeslice : Duration := 0.0; - Sproc : sproc_t) - return Thread_Attributes - is - begin - return (True, Thread_Resources, Thread_Timeslice, Sproc); - end Bound_Thread_Attributes; - - ----------------------------- - -- Bound_Thread_Attributes -- - ----------------------------- - - function Bound_Thread_Attributes - (Thread_Resources : Resource_Vector_T := NO_RESOURCES; - Thread_Timeslice : Duration := 0.0; - Sproc_Resources : Resource_Vector_T := NO_RESOURCES; - CPU : CPU_Number := ANY_CPU; - Resident : Page_Locking := NOLOCK; - NDPRI : Non_Degrading_Priority := NDP_NONE) - return Thread_Attributes - is - Sproc : constant sproc_t := New_Sproc - (Sproc_Resources, CPU, Resident, NDPRI); - begin - return (True, Thread_Resources, Thread_Timeslice, Sproc); - end Bound_Thread_Attributes; - - ----------------------------------- - -- New_Unbound_Thread_Attributes -- - ----------------------------------- - - function New_Unbound_Thread_Attributes - (Thread_Resources : Resource_Vector_T := NO_RESOURCES; - Thread_Timeslice : Duration := 0.0) return Task_Info_Type - is - begin - return new Thread_Attributes' - (False, Thread_Resources, Thread_Timeslice); - end New_Unbound_Thread_Attributes; - - --------------------------------- - -- New_Bound_Thread_Attributes -- - --------------------------------- - - function New_Bound_Thread_Attributes - (Thread_Resources : Resource_Vector_T := NO_RESOURCES; - Thread_Timeslice : Duration := 0.0; - Sproc : sproc_t) return Task_Info_Type - is - begin - return new Thread_Attributes' - (True, Thread_Resources, Thread_Timeslice, Sproc); - end New_Bound_Thread_Attributes; - - --------------------------------- - -- New_Bound_Thread_Attributes -- - --------------------------------- - - function New_Bound_Thread_Attributes - (Thread_Resources : Resource_Vector_T := NO_RESOURCES; - Thread_Timeslice : Duration := 0.0; - Sproc_Resources : Resource_Vector_T := NO_RESOURCES; - CPU : CPU_Number := ANY_CPU; - Resident : Page_Locking := NOLOCK; - NDPRI : Non_Degrading_Priority := NDP_NONE) - return Task_Info_Type - is - Sproc : constant sproc_t := New_Sproc - (Sproc_Resources, CPU, Resident, NDPRI); - begin - return new Thread_Attributes' - (True, Thread_Resources, Thread_Timeslice, Sproc); - end New_Bound_Thread_Attributes; - -end System.Task_Info; diff --git a/gcc/ada/5gtasinf.ads b/gcc/ada/5gtasinf.ads deleted file mode 100644 index f986bf934af..00000000000 --- a/gcc/ada/5gtasinf.ads +++ /dev/null @@ -1,274 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T A S K _ I N F O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-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 package contains the definitions and routines associated with the --- implementation and use of the Task_Info pragma. It is specialized --- appropriately for targets that make use of this pragma. - --- Note: the compiler generates direct calls to this interface, via Rtsfind. --- Any changes to this interface may require corresponding compiler changes. - --- This unit may be used directly from an application program by providing --- an appropriate WITH, and the interface can be expected to remain stable. - --- This is the SGI (libathread) specific version of this module. - -with System.OS_Interface; - -package System.Task_Info is - pragma Elaborate_Body; - -- To ensure that a body is allowed - - --------------------------------------------------------- - -- Binding of Tasks to sprocs and sprocs to processors -- - --------------------------------------------------------- - - -- The SGI implementation of the GNU Low-Level Interface (GNULLI) - -- implements each Ada task as a Posix thread (Pthread). The SGI - -- Pthread library distributes threads across one or more processes - -- that are members of a common share group. Irix distributes - -- processes across the available CPUs on a given machine. The - -- pragma Task_Info provides the mechanism to control the distribution - -- of tasks to sprocs, and sprocs to processors. - - -- Each thread has a number of attributes that dictate it's scheduling. - -- These attributes are: - - -- Bound_To_Sproc: whether the thread is bound to a specific sproc - -- for its entire lifetime. - - -- Timeslice: Amount of time that a thread is allowed to execute - -- before the system yeilds control to another thread - -- of equal priority. - - -- Resource_Vector: A bitmask used to control the binding of threads - -- to sprocs. - -- - - -- Each share group process (sproc) - - -- The Task_Info pragma: - - -- pragma Task_Info (EXPRESSION); - - -- allows the specification on a task by task basis of a value of type - -- System.Task_Info.Task_Info_Type to be passed to a task when it is - -- created. The specification of this type, and the effect on the task - -- that is created is target dependent. - - -- The Task_Info pragma appears within a task definition (compare the - -- definition and implementation of pragma Priority). If no such pragma - -- appears, then the value Task_Info_Unspecified is passed. If a pragma - -- is present, then it supplies an alternative value. If the argument of - -- the pragma is a discriminant reference, then the value can be set on - -- a task by task basis by supplying the appropriate discriminant value. - - -- Note that this means that the type used for Task_Info_Type must be - -- suitable for use as a discriminant (i.e. a scalar or access type). - - ---------------------- - -- Resource Vectors -- - ---------------------- - - -- - - type Resource_Vector_T is array (0 .. 31) of Boolean; - pragma Pack (Resource_Vector_T); - - NO_RESOURCES : constant Resource_Vector_T := (others => False); - - generic - type Resource_T is (<>); - -- Discrete type up to 32 entries - - package Resource_Vector_Functions is - function "+" - (R : Resource_T) return Resource_Vector_T; - - function "+" - (R1 : Resource_T; - R2 : Resource_T) return Resource_Vector_T; - - function "+" - (R : Resource_T; - S : Resource_Vector_T) return Resource_Vector_T; - - function "+" - (S : Resource_Vector_T; - R : Resource_T) return Resource_Vector_T; - - function "+" - (S1 : Resource_Vector_T; - S2 : Resource_Vector_T) return Resource_Vector_T; - - function "-" - (S : Resource_Vector_T; - R : Resource_T) return Resource_Vector_T; - end Resource_Vector_Functions; - - ---------------------- - -- Sproc Attributes -- - ---------------------- - - subtype sproc_t is System.OS_Interface.sproc_t; - - subtype CPU_Number is Integer range -1 .. Integer'Last; - - ANY_CPU : constant CPU_Number := CPU_Number'First; - - type Non_Degrading_Priority is range 0 .. 255; - -- Specification of IRIX Non Degrading Priorities. - -- - -- WARNING: IRIX priorities have the reverse meaning of Ada priorities. - -- The lower the priority value, the greater the greater the - -- scheduling preference. - -- - -- See the schedctl(2) man page for a complete discussion of non-degrading - -- priorities. - - NDPHIMAX : constant Non_Degrading_Priority := 30; - NDPHIMIN : constant Non_Degrading_Priority := 39; - -- These priorities are higher than ALL normal user process priorities - - subtype NDP_High is Non_Degrading_Priority range NDPHIMAX .. NDPHIMIN; - - NDPNORMMAX : constant Non_Degrading_Priority := 40; - NDPNORMMIN : constant Non_Degrading_Priority := 127; - -- These priorities overlap normal user process priorities - - subtype NDP_Norm is Non_Degrading_Priority range NDPNORMMAX .. NDPNORMMIN; - - NDPLOMAX : constant Non_Degrading_Priority := 128; - NDPLOMIN : constant Non_Degrading_Priority := 254; - -- These priorities are below ALL normal user process priorities - - NDP_NONE : constant Non_Degrading_Priority := 255; - - subtype NDP_LOW is Non_Degrading_Priority range NDPLOMAX .. NDPLOMIN; - - type Page_Locking is - (NOLOCK, -- Do not lock pages in memory - PROCLOCK, -- Lock text and data segments into memory (process lock) - TXTLOCK, -- Lock text segment into memory (text lock) - DATLOCK -- Lock data segment into memory (data lock) - ); - - type Sproc_Attributes is record - Sproc_Resources : Resource_Vector_T := NO_RESOURCES; - CPU : CPU_Number := ANY_CPU; - Resident : Page_Locking := NOLOCK; - NDPRI : Non_Degrading_Priority := NDP_NONE; --- ??? why is that commented out, should it be removed ? --- Sproc_Slice : Duration := 0.0; --- Deadline_Period : Duration := 0.0; --- Deadline_Alloc : Duration := 0.0; - end record; - - Default_Sproc_Attributes : constant Sproc_Attributes := - (NO_RESOURCES, ANY_CPU, NOLOCK, NDP_NONE); - - function New_Sproc (Attr : Sproc_Attributes) return sproc_t; - function New_Sproc - (Sproc_Resources : Resource_Vector_T := NO_RESOURCES; - CPU : CPU_Number := ANY_CPU; - Resident : Page_Locking := NOLOCK; - NDPRI : Non_Degrading_Priority := NDP_NONE) return sproc_t; - -- Allocates a sproc_t control structure and creates the - -- corresponding sproc. - - Invalid_CPU_Number : exception; - Permission_Error : exception; - Sproc_Create_Error : exception; - - ----------------------- - -- Thread Attributes -- - ----------------------- - - type Thread_Attributes (Bound_To_Sproc : Boolean) is record - Thread_Resources : Resource_Vector_T := NO_RESOURCES; - - Thread_Timeslice : Duration := 0.0; - - case Bound_To_Sproc is - when False => - null; - when True => - Sproc : sproc_t; - end case; - end record; - - Default_Thread_Attributes : constant Thread_Attributes := - (False, NO_RESOURCES, 0.0); - - function Unbound_Thread_Attributes - (Thread_Resources : Resource_Vector_T := NO_RESOURCES; - Thread_Timeslice : Duration := 0.0) return Thread_Attributes; - - function Bound_Thread_Attributes - (Thread_Resources : Resource_Vector_T := NO_RESOURCES; - Thread_Timeslice : Duration := 0.0; - Sproc : sproc_t) return Thread_Attributes; - - function Bound_Thread_Attributes - (Thread_Resources : Resource_Vector_T := NO_RESOURCES; - Thread_Timeslice : Duration := 0.0; - Sproc_Resources : Resource_Vector_T := NO_RESOURCES; - CPU : CPU_Number := ANY_CPU; - Resident : Page_Locking := NOLOCK; - NDPRI : Non_Degrading_Priority := NDP_NONE) - return Thread_Attributes; - - type Task_Info_Type is access all Thread_Attributes; - - function New_Unbound_Thread_Attributes - (Thread_Resources : Resource_Vector_T := NO_RESOURCES; - Thread_Timeslice : Duration := 0.0) - return Task_Info_Type; - - function New_Bound_Thread_Attributes - (Thread_Resources : Resource_Vector_T := NO_RESOURCES; - Thread_Timeslice : Duration := 0.0; - Sproc : sproc_t) return Task_Info_Type; - - function New_Bound_Thread_Attributes - (Thread_Resources : Resource_Vector_T := NO_RESOURCES; - Thread_Timeslice : Duration := 0.0; - Sproc_Resources : Resource_Vector_T := NO_RESOURCES; - CPU : CPU_Number := ANY_CPU; - Resident : Page_Locking := NOLOCK; - NDPRI : Non_Degrading_Priority := NDP_NONE) - return Task_Info_Type; - - Unspecified_Task_Info : constant Task_Info_Type := null; - -end System.Task_Info; diff --git a/gcc/ada/5gtpgetc.adb b/gcc/ada/5gtpgetc.adb deleted file mode 100644 index 6b36c9d54f8..00000000000 --- a/gcc/ada/5gtpgetc.adb +++ /dev/null @@ -1,207 +0,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 "); - 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; diff --git a/gcc/ada/5hml-tgt.adb b/gcc/ada/5hml-tgt.adb deleted file mode 100644 index 4eb2934cb51..00000000000 --- a/gcc/ada/5hml-tgt.adb +++ /dev/null @@ -1,368 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T -- --- (HP-UX Version) -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2004, 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. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a set of target dependent routines to build --- libraries (static only on HP-UX). - --- This is the HP-UX version of the body. - -with MLib.Fil; -with MLib.Utl; -with Namet; use Namet; -with Opt; -with Output; use Output; -with Prj.Com; -with System; - -package body MLib.Tgt is - - No_Arguments : aliased Argument_List := (1 .. 0 => null); - Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; - - Wl_Init_String : aliased String := "-Wl,+init"; - Wl_Init : constant String_Access := Wl_Init_String'Access; - Wl_Fini_String : aliased String := "-Wl,+fini"; - Wl_Fini : constant String_Access := Wl_Fini_String'Access; - - Init_Fini_List : constant Argument_List_Access := - new Argument_List'(1 => Wl_Init, - 2 => null, - 3 => Wl_Fini, - 4 => null); - -- Used to put switches for automatic elaboration/finalization - --------------------- - -- Archive_Builder -- - --------------------- - - function Archive_Builder return String is - begin - return "ar"; - end Archive_Builder; - - ----------------------------- - -- Archive_Builder_Options -- - ----------------------------- - - function Archive_Builder_Options return String_List_Access is - begin - return new String_List'(1 => new String'("cr")); - end Archive_Builder_Options; - - ----------------- - -- Archive_Ext -- - ----------------- - - function Archive_Ext return String is - begin - return "a"; - end Archive_Ext; - - --------------------- - -- Archive_Indexer -- - --------------------- - - function Archive_Indexer return String is - begin - return "ranlib"; - end Archive_Indexer; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Foreign : Argument_List; - Afiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Address : String := ""; - Lib_Version : String := ""; - Relocatable : Boolean := False; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Foreign); - pragma Unreferenced (Afiles); - pragma Unreferenced (Interfaces); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Lib_Address); - pragma Unreferenced (Relocatable); - - Lib_File : constant String := - Lib_Dir & Directory_Separator & "lib" & - MLib.Fil.Ext_To (Lib_Filename, DLL_Ext); - - Version_Arg : String_Access; - Symbolic_Link_Needed : Boolean := False; - - Init_Fini : Argument_List_Access := Empty_Argument_List; - - Common_Options : constant Argument_List := - Options & new String'(PIC_Option); - -- Common set of options to the gcc command performing the link. - -- On HPUX, this command eventually resorts to collect2, which may - -- generate a C file and compile it on the fly. This compilation shall - -- also generate position independant code for the final link to - -- succeed. - begin - if Opt.Verbose_Mode then - Write_Str ("building relocatable shared library "); - Write_Line (Lib_File); - end if; - - -- If specified, add automatic elaboration/finalization - if Auto_Init then - Init_Fini := Init_Fini_List; - Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init"); - Init_Fini (4) := new String'("-Wl," & Lib_Filename & "final"); - end if; - - if Lib_Version = "" then - MLib.Utl.Gcc - (Output_File => Lib_File, - Objects => Ofiles, - Options => Common_Options & Init_Fini.all, - Driver_Name => Driver_Name); - - else - Version_Arg := new String'("-Wl,+h," & Lib_Version); - - if Is_Absolute_Path (Lib_Version) then - MLib.Utl.Gcc - (Output_File => Lib_Version, - Objects => Ofiles, - Options => Common_Options & Version_Arg & Init_Fini.all, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := Lib_Version /= Lib_File; - - else - MLib.Utl.Gcc - (Output_File => Lib_Dir & Directory_Separator & Lib_Version, - Objects => Ofiles, - Options => Common_Options & Version_Arg & Init_Fini.all, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := - Lib_Dir & Directory_Separator & Lib_Version /= Lib_File; - end if; - - if Symbolic_Link_Needed then - declare - Success : Boolean; - Oldpath : String (1 .. Lib_Version'Length + 1); - Newpath : String (1 .. Lib_File'Length + 1); - - Result : Integer; - pragma Unreferenced (Result); - - function Symlink - (Oldpath : System.Address; - Newpath : System.Address) return Integer; - pragma Import (C, Symlink, "__gnat_symlink"); - - begin - Oldpath (1 .. Lib_Version'Length) := Lib_Version; - Oldpath (Oldpath'Last) := ASCII.NUL; - Newpath (1 .. Lib_File'Length) := Lib_File; - Newpath (Newpath'Last) := ASCII.NUL; - - Delete_File (Lib_File, Success); - - Result := Symlink (Oldpath'Address, Newpath'Address); - end; - end if; - end if; - end Build_Dynamic_Library; - - ------------------------- - -- Default_DLL_Address -- - ------------------------- - - function Default_DLL_Address return String is - begin - return ""; - end Default_DLL_Address; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return "sl"; - end DLL_Ext; - - -------------------- - -- Dynamic_Option -- - -------------------- - - function Dynamic_Option return String is - begin - return "-shared"; - end Dynamic_Option; - - ------------------- - -- Is_Object_Ext -- - ------------------- - - function Is_Object_Ext (Ext : String) return Boolean is - begin - return Ext = ".o"; - end Is_Object_Ext; - - -------------- - -- Is_C_Ext -- - -------------- - - function Is_C_Ext (Ext : String) return Boolean is - begin - return Ext = ".c"; - end Is_C_Ext; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".a" or else Ext = ".so"; - end Is_Archive_Ext; - - ------------- - -- Libgnat -- - ------------- - - function Libgnat return String is - begin - return "libgnat.a"; - end Libgnat; - - ------------------------ - -- Library_Exists_For -- - ------------------------ - - function Library_Exists_For (Project : Project_Id) return Boolean is - begin - if not Projects.Table (Project).Library then - Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & - "for non library project"); - return False; - - else - declare - Lib_Dir : constant String := - Get_Name_String (Projects.Table (Project).Library_Dir); - Lib_Name : constant String := - Get_Name_String (Projects.Table (Project).Library_Name); - - begin - if Projects.Table (Project).Library_Kind = Static then - return Is_Regular_File - (Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - return Is_Regular_File - (Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - end; - end if; - end Library_Exists_For; - - --------------------------- - -- Library_File_Name_For -- - --------------------------- - - function Library_File_Name_For (Project : Project_Id) return Name_Id is - begin - if not Projects.Table (Project).Library then - Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & - "for non library project"); - return No_Name; - - else - declare - Lib_Name : constant String := - Get_Name_String (Projects.Table (Project).Library_Name); - - begin - Name_Len := 3; - Name_Buffer (1 .. Name_Len) := "lib"; - - if Projects.Table (Project).Library_Kind = Static then - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - - return Name_Find; - end; - end if; - end Library_File_Name_For; - - ---------------- - -- Object_Ext -- - ---------------- - - function Object_Ext return String is - begin - return "o"; - end Object_Ext; - - ---------------- - -- PIC_Option -- - ---------------- - - function PIC_Option return String is - begin - return "-fPIC"; - end PIC_Option; - - ----------------------------------------------- - -- Standalone_Library_Auto_Init_Is_Supported -- - ----------------------------------------------- - - function Standalone_Library_Auto_Init_Is_Supported return Boolean is - begin - return True; - end Standalone_Library_Auto_Init_Is_Supported; - - --------------------------- - -- Support_For_Libraries -- - --------------------------- - - function Support_For_Libraries return Library_Support is - begin - return Full; - end Support_For_Libraries; - -end MLib.Tgt; diff --git a/gcc/ada/5hosinte.adb b/gcc/ada/5hosinte.adb deleted file mode 100644 index dcd169ccf62..00000000000 --- a/gcc/ada/5hosinte.adb +++ /dev/null @@ -1,564 +0,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 DCE version of this package. --- Currently HP-UX and SNI use this file - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - -with Interfaces.C; use Interfaces.C; - -package body System.OS_Interface is - - ----------------- - -- 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; - - ----------------- - -- To_Timespec -- - ----------------- - - function To_Timespec (D : Duration) return timespec is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return timespec'(tv_sec => S, - tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); - end To_Timespec; - - function To_Duration (TV : struct_timeval) return Duration is - begin - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end To_Duration; - - function To_Timeval (D : Duration) return struct_timeval is - S : time_t; - F : Duration; - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return - struct_timeval' - (tv_sec => S, - tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); - end To_Timeval; - - --------------------------- - -- POSIX.1c Section 3 -- - --------------------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) - return int - is - Result : int; - - begin - Result := sigwait (set); - - if Result = -1 then - sig.all := 0; - return errno; - end if; - - sig.all := Signal (Result); - return 0; - end sigwait; - - -- DCE_THREADS does not have pthread_kill. Instead, we just ignore it. - - function pthread_kill (thread : pthread_t; sig : Signal) return int is - pragma Unreferenced (thread, sig); - begin - return 0; - end pthread_kill; - - ---------------------------- - -- POSIX.1c Section 11 -- - ---------------------------- - - -- For all the following functions, DCE Threads has a non standard - -- behavior: it sets errno but the standard Posix requires it to be - -- returned. - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) - return int - is - function pthread_mutexattr_create - (attr : access pthread_mutexattr_t) - return int; - pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create"); - - begin - if pthread_mutexattr_create (attr) /= 0 then - return errno; - else - return 0; - end if; - end pthread_mutexattr_init; - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) - return int - is - function pthread_mutexattr_delete - (attr : access pthread_mutexattr_t) - return int; - pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete"); - - begin - if pthread_mutexattr_delete (attr) /= 0 then - return errno; - else - return 0; - end if; - end pthread_mutexattr_destroy; - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) - return int - is - function pthread_mutex_init_base - (mutex : access pthread_mutex_t; - attr : pthread_mutexattr_t) - return int; - pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init"); - - begin - if pthread_mutex_init_base (mutex, attr.all) /= 0 then - return errno; - else - return 0; - end if; - end pthread_mutex_init; - - function pthread_mutex_destroy - (mutex : access pthread_mutex_t) - return int - is - function pthread_mutex_destroy_base - (mutex : access pthread_mutex_t) - return int; - pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy"); - - begin - if pthread_mutex_destroy_base (mutex) /= 0 then - return errno; - else - return 0; - end if; - end pthread_mutex_destroy; - - 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"); - - begin - if pthread_mutex_lock_base (mutex) /= 0 then - return errno; - else - return 0; - end if; - end pthread_mutex_lock; - - 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"); - - begin - if pthread_mutex_unlock_base (mutex) /= 0 then - return errno; - else - return 0; - end if; - end pthread_mutex_unlock; - - function pthread_condattr_init - (attr : access pthread_condattr_t) - return int - is - function pthread_condattr_create - (attr : access pthread_condattr_t) - return int; - pragma Import (C, pthread_condattr_create, "pthread_condattr_create"); - - begin - if pthread_condattr_create (attr) /= 0 then - return errno; - else - return 0; - end if; - end pthread_condattr_init; - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) - return int - is - function pthread_condattr_delete - (attr : access pthread_condattr_t) - return int; - pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete"); - - begin - if pthread_condattr_delete (attr) /= 0 then - return errno; - else - return 0; - end if; - end pthread_condattr_destroy; - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) - return int - is - function pthread_cond_init_base - (cond : access pthread_cond_t; - attr : pthread_condattr_t) - return int; - pragma Import (C, pthread_cond_init_base, "pthread_cond_init"); - - begin - if pthread_cond_init_base (cond, attr.all) /= 0 then - return errno; - else - return 0; - end if; - end pthread_cond_init; - - function pthread_cond_destroy - (cond : access pthread_cond_t) - return int - is - function pthread_cond_destroy_base - (cond : access pthread_cond_t) - return int; - pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy"); - - begin - if pthread_cond_destroy_base (cond) /= 0 then - return errno; - else - return 0; - end if; - end pthread_cond_destroy; - - function pthread_cond_signal - (cond : access pthread_cond_t) - return int - is - function pthread_cond_signal_base - (cond : access pthread_cond_t) - return int; - pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal"); - - begin - if pthread_cond_signal_base (cond) /= 0 then - return errno; - else - return 0; - end if; - end pthread_cond_signal; - - 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"); - - begin - if pthread_cond_wait_base (cond, mutex) /= 0 then - return errno; - else - return 0; - end if; - end pthread_cond_wait; - - 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"); - - begin - if pthread_cond_timedwait_base (cond, mutex, abstime) /= 0 then - if errno = EAGAIN then - return ETIMEDOUT; - else - return errno; - end if; - else - return 0; - end if; - end pthread_cond_timedwait; - - ---------------------------- - -- POSIX.1c Section 13 -- - ---------------------------- - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int - is - function pthread_setscheduler - (thread : pthread_t; - policy : int; - priority : int) - return int; - pragma Import (C, pthread_setscheduler, "pthread_setscheduler"); - - begin - if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then - return errno; - else - return 0; - end if; - end pthread_setschedparam; - - function sched_yield return int is - procedure pthread_yield; - pragma Import (C, pthread_yield, "pthread_yield"); - begin - pthread_yield; - return 0; - end sched_yield; - - ----------------------------- - -- P1003.1c - Section 16 -- - ----------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int - is - function pthread_attr_create - (attributes : access pthread_attr_t) - return int; - pragma Import (C, pthread_attr_create, "pthread_attr_create"); - - begin - if pthread_attr_create (attributes) /= 0 then - return errno; - else - return 0; - end if; - end pthread_attr_init; - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int - is - function pthread_attr_delete - (attributes : access pthread_attr_t) - return int; - pragma Import (C, pthread_attr_delete, "pthread_attr_delete"); - - begin - if pthread_attr_delete (attributes) /= 0 then - return errno; - else - return 0; - end if; - end pthread_attr_destroy; - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int - is - function pthread_attr_setstacksize_base - (attr : access pthread_attr_t; - stacksize : size_t) - return int; - pragma Import (C, pthread_attr_setstacksize_base, - "pthread_attr_setstacksize"); - - begin - if pthread_attr_setstacksize_base (attr, stacksize) /= 0 then - return errno; - else - return 0; - end if; - end pthread_attr_setstacksize; - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int - is - function pthread_create_base - (thread : access pthread_t; - attributes : pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) - return int; - pragma Import (C, pthread_create_base, "pthread_create"); - - begin - if pthread_create_base - (thread, attributes.all, start_routine, arg) /= 0 - then - return errno; - else - return 0; - end if; - end pthread_create; - - ---------------------------- - -- POSIX.1c Section 17 -- - ---------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int - is - function pthread_setspecific_base - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific_base, "pthread_setspecific"); - - begin - if pthread_setspecific_base (key, value) /= 0 then - return errno; - else - return 0; - end if; - end pthread_setspecific; - - 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"); - Addr : aliased System.Address; - - begin - if pthread_getspecific_base (key, Addr'Access) /= 0 then - return System.Null_Address; - else - return Addr; - end if; - end pthread_getspecific; - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int - is - function pthread_keycreate - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_keycreate, "pthread_keycreate"); - - begin - if pthread_keycreate (key, destructor) /= 0 then - return errno; - else - return 0; - end if; - end pthread_key_create; - - function Get_Stack_Base (thread : pthread_t) return Address is - pragma Warnings (Off, thread); - - begin - return Null_Address; - end Get_Stack_Base; - - procedure pthread_init is - begin - null; - end pthread_init; - - function intr_attach (sig : int; handler : isr_address) return long is - function c_signal (sig : int; handler : isr_address) return long; - pragma Import (C, c_signal, "signal"); - - begin - return c_signal (sig, handler); - end intr_attach; - -end System.OS_Interface; diff --git a/gcc/ada/5hosinte.ads b/gcc/ada/5hosinte.ads deleted file mode 100644 index 18de527be15..00000000000 --- a/gcc/ada/5hosinte.ads +++ /dev/null @@ -1,495 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 HP-UX version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-lcma"); - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 11; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIME : constant := 52; - ETIMEDOUT : constant := 238; - - FUNC_ERR : constant := -1; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 44; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGUSR1 : constant := 16; -- user defined signal 1 - SIGUSR2 : constant := 17; -- user defined signal 2 - SIGCLD : constant := 18; -- alias for SIGCHLD - SIGCHLD : constant := 18; -- child status change - SIGPWR : constant := 19; -- power-fail restart - SIGVTALRM : constant := 20; -- virtual timer alarm - SIGPROF : constant := 21; -- profiling timer alarm - SIGIO : constant := 22; -- asynchronous I/O - SIGPOLL : constant := 22; -- pollable event occurred - SIGWINCH : constant := 23; -- window size change - SIGSTOP : constant := 24; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 25; -- user stop requested from tty - SIGCONT : constant := 26; -- stopped process has been continued - SIGTTIN : constant := 27; -- background tty read attempted - SIGTTOU : constant := 28; -- background tty write attempted - SIGURG : constant := 29; -- urgent condition on IO channel - SIGLOST : constant := 30; -- remote lock lost (NFS) - SIGDIL : constant := 32; -- DIL signal - SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit) - SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit) - - SIGADAABORT : constant := SIGABRT; - -- Note: on other targets, we usually use SIGABRT, but on HP/UX, it - -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM. - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := - (SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP); - - Reserved : constant Signal_Set := (SIGKILL, SIGSTOP); - - type sigset_t is private; - - type isr_address is access procedure (sig : int); - - function intr_attach (sig : int; handler : isr_address) return long; - - Intr_Attach_Reset : constant Boolean := True; - -- True if intr_attach is reset after an interrupt handler is called - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type Signal_Handler is access procedure (signo : Signal); - - type struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : int; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - SA_RESTART : constant := 16#40#; - SA_SIGINFO : constant := 16#10#; - - SIG_BLOCK : constant := 0; - SIG_UNBLOCK : constant := 1; - SIG_SETMASK : constant := 2; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - SIG_ERR : constant := -1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - type timespec is private; - - function nanosleep (rqtp, rmtp : access timespec) return int; - pragma Import (C, nanosleep); - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - - function Clock_Gettime - (Clock_Id : clockid_t; Tp : access timespec) return int; - pragma Import (C, Clock_Gettime); - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timeval is private; - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 0; - SCHED_RR : constant := 1; - SCHED_OTHER : constant := 2; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - ----------- - -- Stack -- - ----------- - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- This is a dummy procedure to share some GNULLI files - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - procedure pthread_init; - pragma Inline (pthread_init); - -- This is a dummy procedure to share some GNULLI files - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait (set : access sigset_t) return int; - pragma Import (C, sigwait, "cma_sigwait"); - - function sigwait - (set : access sigset_t; - sig : access Signal) return int; - pragma Inline (sigwait); - -- DCE_THREADS has a nonstandard sigwait - - function pthread_kill - (thread : pthread_t; - sig : Signal) return int; - pragma Inline (pthread_kill); - -- DCE_THREADS doesn't have pthread_kill - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - -- DCE THREADS does not have pthread_sigmask. Instead, it uses - -- sigprocmask to do the signal handling when the thread library is - -- sucked in. - pragma Import (C, pthread_sigmask, "sigprocmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - -- DCE_THREADS has a nonstandard pthread_mutexattr_init. - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - -- DCE_THREADS has a nonstandard pthread_mutexattr_destroy - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - -- DCE_THREADS has a nonstandard pthread_mutex_init - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - -- DCE_THREADS has a nonstandard pthread_mutex_destroy - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Inline (pthread_mutex_lock); - -- DCE_THREADS has nonstandard pthread_mutex_lock - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Inline (pthread_mutex_unlock); - -- DCE_THREADS has nonstandard pthread_mutex_lock - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - -- DCE_THREADS has nonstandard pthread_condattr_init - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - -- DCE_THREADS has nonstandard pthread_condattr_destroy - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - -- DCE_THREADS has nonstandard pthread_cond_init - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - -- DCE_THREADS has nonstandard pthread_cond_destroy - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Inline (pthread_cond_signal); - -- DCE_THREADS has nonstandard pthread_cond_signal - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Inline (pthread_cond_wait); - -- DCE_THREADS has a nonstandard pthread_cond_wait - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - pragma Inline (pthread_cond_timedwait); - -- DCE_THREADS has a nonstandard pthread_cond_timedwait - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Inline (pthread_setschedparam); - -- DCE_THREADS has a nonstandard pthread_setschedparam - - function sched_yield return int; - pragma Inline (sched_yield); - -- DCE_THREADS has a nonstandard sched_yield - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Inline (pthread_attr_init); - -- DCE_THREADS has a nonstandard pthread_attr_init - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Inline (pthread_attr_destroy); - -- DCE_THREADS has a nonstandard pthread_attr_destroy - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Inline (pthread_attr_setstacksize); - -- DCE_THREADS has a nonstandard pthread_attr_setstacksize - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Inline (pthread_create); - -- DCE_THREADS has a nonstandard pthread_create - - procedure pthread_detach (thread : access pthread_t); - pragma Import (C, pthread_detach); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Inline (pthread_setspecific); - -- DCE_THREADS has a nonstandard pthread_setspecific - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Inline (pthread_getspecific); - -- DCE_THREADS has a nonstandard pthread_getspecific - - type destructor_pointer is access procedure (arg : System.Address); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Inline (pthread_key_create); - -- DCE_THREADS has a nonstandard pthread_key_create - -private - - type array_type_1 is array (Integer range 0 .. 7) of unsigned_long; - type sigset_t is record - X_X_sigbits : array_type_1; - end record; - pragma Convention (C, sigset_t); - - type pid_t is new int; - - type time_t is new long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 1; - - type struct_timeval is record - tv_sec : time_t; - tv_usec : time_t; - end record; - pragma Convention (C, struct_timeval); - - type cma_t_address is new System.Address; - - type cma_t_handle is record - field1 : cma_t_address; - field2 : Short_Integer; - field3 : Short_Integer; - end record; - for cma_t_handle'Size use 64; - - type pthread_attr_t is new cma_t_handle; - pragma Convention (C_Pass_By_Copy, pthread_attr_t); - - type pthread_condattr_t is new cma_t_handle; - pragma Convention (C_Pass_By_Copy, pthread_condattr_t); - - type pthread_mutexattr_t is new cma_t_handle; - pragma Convention (C_Pass_By_Copy, pthread_mutexattr_t); - - type pthread_t is new cma_t_handle; - pragma Convention (C_Pass_By_Copy, pthread_t); - - type pthread_mutex_t is new cma_t_handle; - pragma Convention (C_Pass_By_Copy, pthread_mutex_t); - - type pthread_cond_t is new cma_t_handle; - pragma Convention (C_Pass_By_Copy, pthread_cond_t); - - type pthread_key_t is new int; - -end System.OS_Interface; diff --git a/gcc/ada/5hparame.ads b/gcc/ada/5hparame.ads deleted file mode 100644 index 8be952a18c2..00000000000 --- a/gcc/ada/5hparame.ads +++ /dev/null @@ -1,202 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2003 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 HP version of this package --- Blank line intentional so that it lines up exactly with default. - --- This package defines some system dependent parameters for GNAT. These --- are values that are referenced by the runtime library and are therefore --- relevant to the target machine. - --- The parameters whose value is defined in the spec are not generally --- expected to be changed. If they are changed, it will be necessary to --- recompile the run-time library. - --- The parameters which are defined by functions can be changed by modifying --- the body of System.Parameters in file s-parame.adb. A change to this body --- requires only rebinding and relinking of the application. - --- Note: do not introduce any pragma Inline statements into this unit, since --- otherwise the relinking and rebinding capability would be deactivated. - -package System.Parameters is -pragma Pure (Parameters); - - --------------------------------------- - -- Task And Stack Allocation Control -- - --------------------------------------- - - type Task_Storage_Size is new Integer; - -- Type used in tasking units for task storage size - - type Size_Type is new Task_Storage_Size; - -- Type used to provide task storage size to runtime - - Unspecified_Size : constant Size_Type := Size_Type'First; - -- Value used to indicate that no size type is set - - subtype Ratio is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Ratio : constant Ratio := Dynamic; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - - function Default_Stack_Size return Size_Type; - -- Default task stack size used if none is specified - - function Minimum_Stack_Size return Size_Type; - -- Minimum task stack size permitted - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type; - -- Given the storage size stored in the TCB, return the Storage_Size - -- value required by the RM for the Storage_Size attribute. The - -- required adjustment is as follows: - -- - -- when Size = Unspecified_Size, return Default_Stack_Size - -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size - -- otherwise return given Size - - Default_Env_Stack_Size : constant Size_Type := 8_192_000; - -- Assumed size of the environment task, if no other information - -- is available. This value is used when stack checking is - -- enabled and no GNAT_STACK_LIMIT environment variable is set. - - Stack_Grows_Down : constant Boolean := False; - -- This constant indicates whether the stack grows up (False) or - -- down (True) in memory as functions are called. It is used for - -- proper implementation of the stack overflow check. - - ---------------------------------------------- - -- Characteristics of Types in Interfaces.C -- - ---------------------------------------------- - - long_bits : constant := Long_Integer'Size; - -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this is not true - -- of all targets. For example, in OpenVMS long /= Long_Integer. - - ---------------------------------------------- - -- Behavior of Pragma Finalize_Storage_Only -- - ---------------------------------------------- - - -- Garbage_Collected is a Boolean constant whose value indicates the - -- effect of the pragma Finalize_Storage_Entry on a controlled type. - - -- Garbage_Collected = False - - -- The system releases all storage on program termination only, - -- but not other garbage collection occurs, so finalization calls - -- are ommitted only for outer level onjects can be omitted if - -- pragma Finalize_Storage_Only is used. - - -- Garbage_Collected = True - - -- The system provides full garbage collection, so it is never - -- necessary to release storage for controlled objects for which - -- a pragma Finalize_Storage_Only is used. - - Garbage_Collected : constant Boolean := False; - -- The storage mode for this system (release on program exit) - - --------------------- - -- Tasking Profile -- - --------------------- - - -- In the following sections, constant parameters are defined to - -- allow some optimizations and fine tuning within the tasking run time - -- based on restrictions on the tasking features. - - ---------------------- - -- Locking Strategy -- - ---------------------- - - Single_Lock : constant Boolean := False; - -- Indicates whether a single lock should be used within the tasking - -- run-time to protect internal structures. If True, a single lock - -- will be used, meaning less locking/unlocking operations, but also - -- more global contention. In general, Single_Lock should be set to - -- True on single processor machines, and to False to multi-processor - -- systems, but this can vary from application to application and also - -- depends on the scheduling policy. - - ------------------- - -- Task Abortion -- - ------------------- - - No_Abort : constant Boolean := False; - -- This constant indicates whether abort statements and asynchronous - -- transfer of control (ATC) are disallowed. If set to True, it is - -- assumed that neither construct is used, and the run time does not - -- need to defer/undefer abort and check for pending actions at - -- completion points. A value of True for No_Abort corresponds to: - -- pragma Restrictions (No_Abort_Statements); - -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - - ---------------------- - -- Dynamic Priority -- - ---------------------- - - Dynamic_Priority_Support : constant Boolean := True; - -- This constant indicates whether dynamic changes of task priorities - -- are allowed (True means normal RM mode in which such changes are - -- allowed). In particular, if this is False, then we do not need to - -- poll for pending base priority changes at every abort completion - -- point. A value of False for Dynamic_Priority_Support corresponds - -- to pragma Restrictions (No_Dynamic_Priorities); - - --------------------- - -- Task Attributes -- - --------------------- - - Default_Attribute_Count : constant := 4; - -- Number of pre-allocated Address-sized task attributes stored in the - -- task control block. - - -------------------- - -- Runtime Traces -- - -------------------- - - Runtime_Traces : constant Boolean := False; - -- This constant indicates whether the runtime outputs traces to a - -- predefined output or not (True means that traces are output). - -- See System.Traces for more details. - -end System.Parameters; diff --git a/gcc/ada/5hsystem.ads b/gcc/ada/5hsystem.ads deleted file mode 100644 index 43e22cbaabc..00000000000 --- a/gcc/ada/5hsystem.ads +++ /dev/null @@ -1,226 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (HP-UX Version) -- --- -- --- 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 := 0.01; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := False; - 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 := False; - ZCX_By_Default : constant Boolean := False; - GCC_ZCX_Support : constant Boolean := True; - 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; - - -------------------------- - -- Underlying Priorities -- - --------------------------- - - -- Important note: this section of the file must come AFTER the - -- definition of the system implementation parameters to ensure - -- that the value of these parameters is available for analysis - -- of the declarations here (using Rtsfind at compile time). - - -- The underlying priorities table provides a generalized mechanism - -- for mapping from Ada priorities to system priorities. In some - -- cases a 1-1 mapping is not the convenient or optimal choice. - - -- For HP/UX DCE Threads, we use the full range of 31 priorities - -- in the Ada model, but map them by compression onto the more limited - -- range of priorities available in HP/UX. - -- For POSIX Threads, this table is ignored. - - -- To replace the default values of the Underlying_Priorities mapping, - -- copy this source file into your build directory, edit the file to - -- reflect your desired behavior, and recompile with the command: - - -- $ gcc -c -O2 -gnatpgn system.ads - - -- then recompile the run-time parts that depend on this package: - - -- $ gnatmake -a -gnatn -O2 - - -- then force rebuilding your application if you need different options: - - -- $ gnatmake -f - - type Priorities_Mapping is array (Any_Priority) of Integer; - pragma Suppress_Initialization (Priorities_Mapping); - -- Suppress initialization in case gnat.adc specifies Normalize_Scalars - - Underlying_Priorities : constant Priorities_Mapping := - - (Priority'First => 16, - - 1 => 17, - 2 => 18, - 3 => 18, - 4 => 18, - 5 => 18, - 6 => 19, - 7 => 19, - 8 => 19, - 9 => 20, - 10 => 20, - 11 => 21, - 12 => 21, - 13 => 22, - 14 => 23, - - Default_Priority => 24, - - 16 => 25, - 17 => 25, - 18 => 25, - 19 => 26, - 20 => 26, - 21 => 26, - 22 => 27, - 23 => 27, - 24 => 27, - 25 => 28, - 26 => 28, - 27 => 29, - 28 => 29, - 29 => 30, - - Priority'Last => 30, - - Interrupt_Priority => 31); - -end System; diff --git a/gcc/ada/5htaprop.adb b/gcc/ada/5htaprop.adb deleted file mode 100644 index 1aaf3c26c56..00000000000 --- a/gcc/ada/5htaprop.adb +++ /dev/null @@ -1,1061 +0,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 . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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 a HP-UX DCE threads (HPUX 10) version of this package - --- This package contains all the GNULL primitives that interface directly --- with the underlying OS. - -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.Tasking.Debug; --- used for Known_Tasks - -with Interfaces.C; --- used for int --- size_t - -with System.Interrupt_Management; --- used for Keep_Unmasked --- Abort_Task_Interrupt --- Interrupt_ID - -with System.Interrupt_Management.Operations; --- used for Set_Interrupt_Mask --- All_Tasks_Mask -pragma Elaborate_All (System.Interrupt_Management.Operations); - -with System.Parameters; --- used for Size_Type - -with System.Task_Primitives.Interrupt_Operations; --- used for Get_Interrupt_ID - -with System.Tasking; --- used for Ada_Task_Control_Block --- Task_ID - -with System.Soft_Links; --- used for Defer/Undefer_Abort - --- Note that we do not use System.Tasking.Initialization directly since --- this is a higher level package that we shouldn't depend on. For example --- when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Initialization - -with System.OS_Primitives; --- used for Delay_Modes - -with Unchecked_Conversion; -with Unchecked_Deallocation; - -package body System.Task_Primitives.Operations is - - use System.Tasking.Debug; - use System.Tasking; - use Interfaces.C; - use System.OS_Interface; - use System.Parameters; - use System.OS_Primitives; - - package PIO renames System.Task_Primitives.Interrupt_Operations; - package SSL renames System.Soft_Links; - - ------------------ - -- Local Data -- - ------------------ - - -- The followings are logically constants, but need to be initialized - -- at run time. - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_ID associated with a thread - - Environment_Task_ID : Task_ID; - -- A variable to hold Task_ID for the environment task. - - Unblocked_Signal_Mask : aliased sigset_t; - -- The set of signals that should unblocked in all tasks - - Time_Slice_Val : Integer; - pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - - Dispatching_Policy : Character; - pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - - -- Note: the reason that Locking_Policy is not needed is that this - -- is not implemented for DCE threads. The HPUX 10 port is at this - -- stage considered dead, and no further work is planned on it. - - FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; - -- Indicates whether FIFO_Within_Priorities is set. - - Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads). - - -------------------- - -- Local Packages -- - -------------------- - - package Specific is - - procedure Initialize (Environment_Task : Task_ID); - pragma Inline (Initialize); - -- Initialize various data needed by this package. - - function Is_Valid_Task return Boolean; - pragma Inline (Is_Valid_Task); - -- Does the executing thread have a TCB? - - procedure Set (Self_Id : Task_ID); - pragma Inline (Set); - -- Set the self id for the current task. - - function Self return Task_ID; - pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task. - - end Specific; - - package body Specific is separate; - -- The body of this package is target specific. - - --------------------------------- - -- Support for foreign threads -- - --------------------------------- - - function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; - -- Allocate and Initialize a new ATCB for the current Thread. - - function Register_Foreign_Thread - (Thread : Thread_Id) return Task_ID is separate; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Abort_Handler (Sig : Signal); - - function To_Address is new Unchecked_Conversion (Task_ID, System.Address); - - ------------------- - -- Abort_Handler -- - ------------------- - - procedure Abort_Handler (Sig : Signal) is - pragma Unreferenced (Sig); - - Self_Id : constant Task_ID := Self; - Result : Interfaces.C.int; - Old_Set : aliased sigset_t; - - begin - if Self_Id.Deferral_Level = 0 - and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level and then - not Self_Id.Aborting - then - Self_Id.Aborting := True; - - -- Make sure signals used for RTS internal purpose are unmasked - - Result := pthread_sigmask (SIG_UNBLOCK, - Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); - pragma Assert (Result = 0); - - raise Standard'Abort_Signal; - end if; - end Abort_Handler; - - ----------------- - -- Stack_Guard -- - ----------------- - - -- The underlying thread system sets a guard page at the - -- bottom of a thread stack, so nothing is needed. - -- ??? Check the comment above - - procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is - pragma Unreferenced (T, On); - begin - null; - end Stack_Guard; - - ------------------- - -- Get_Thread_Id -- - ------------------- - - function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_ID renames Specific.Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Initialize_TCB and the Storage_Error is - -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) - -- used in RTS is initialized before any status change of RTS. - -- Therefore rasing Storage_Error in the following routines - -- should be able to be handled safely. - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : access Lock) - is - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - L.Priority := Prio; - - Result := pthread_mutex_init (L.L'Access, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is - pragma Unreferenced (Level); - - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutex_init (L, Attributes'Access); - - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L.L'Access); - pragma Assert (Result = 0); - end Finalize_Lock; - - procedure Finalize_Lock (L : access RTS_Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0); - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - Result : Interfaces.C.int; - - begin - L.Owner_Priority := Get_Priority (Self); - - if L.Priority < L.Owner_Priority then - Ceiling_Violation := True; - return; - end if; - - Result := pthread_mutex_lock (L.L'Access); - pragma Assert (Result = 0); - Ceiling_Violation := False; - end Write_Lock; - - procedure Write_Lock - (L : access RTS_Lock; Global_Lock : Boolean := False) - is - Result : Interfaces.C.int; - - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_lock (L); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - procedure Write_Lock (T : Task_ID) is - Result : Interfaces.C.int; - - begin - if not Single_Lock then - Result := pthread_mutex_lock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - begin - Write_Lock (L, Ceiling_Violation); - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : access Lock) is - Result : Interfaces.C.int; - - begin - Result := pthread_mutex_unlock (L.L'Access); - pragma Assert (Result = 0); - end Unlock; - - procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); - end if; - end Unlock; - - procedure Unlock (T : Task_ID) is - Result : Interfaces.C.int; - - begin - if not Single_Lock then - Result := pthread_mutex_unlock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Unlock; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : Task_ID; - Reason : System.Tasking.Task_States) - is - pragma Unreferenced (Reason); - - Result : Interfaces.C.int; - begin - if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; - - -- EINTR is not considered a failure. - pragma Assert (Result = 0 or else Result = EINTR); - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - procedure Timed_Sleep - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : System.Tasking.Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Unreferenced (Reason); - - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - Timedout := True; - Yielded := False; - - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; - - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); - - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; - - if Single_Lock then - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, - Request'Access); - - else - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, - Request'Access); - end if; - - exit when Abs_Time <= Monotonic_Clock; - - if Result = 0 or Result = EINTR then - - -- Somebody may have called Wakeup for us - - Timedout := False; - exit; - end if; - - pragma Assert (Result = ETIMEDOUT); - end loop; - end if; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes) - is - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - -- Only the little window between deferring abort and - -- locking Self_ID is the reason we need to - -- check for pending abort and priority change below! :( - - SSL.Abort_Defer.all; - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - - if Mode = Relative then - Abs_Time := Time + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; - - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); - Self_ID.Common.State := Delay_Sleep; - - loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - if Single_Lock then - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, Request'Access); - else - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Request'Access); - end if; - - exit when Abs_Time <= Monotonic_Clock; - - pragma Assert (Result = 0 or else - Result = ETIMEDOUT or else - Result = EINTR); - end loop; - - Self_ID.Common.State := Runnable; - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - Result := sched_yield; - SSL.Abort_Undefer.all; - end Timed_Delay; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration is - TS : aliased timespec; - Result : Interfaces.C.int; - - begin - Result := Clock_Gettime (CLOCK_REALTIME, TS'Unchecked_Access); - pragma Assert (Result = 0); - return To_Duration (TS); - end Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - begin - return 10#1.0#E-6; - end RT_Resolution; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is - pragma Unreferenced (Reason); - - Result : Interfaces.C.int; - - begin - Result := pthread_cond_signal (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Wakeup; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - Result : Interfaces.C.int; - pragma Unreferenced (Result); - begin - if Do_Yield then - Result := sched_yield; - end if; - end Yield; - - ------------------ - -- Set_Priority -- - ------------------ - - type Prio_Array_Type is array (System.Any_Priority) of Integer; - pragma Atomic_Components (Prio_Array_Type); - - Prio_Array : Prio_Array_Type; - -- Global array containing the id of the currently running task for - -- each priority. - -- - -- Note: we assume that we are on a single processor with run-til-blocked - -- scheduling. - - procedure Set_Priority - (T : Task_ID; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) - is - Result : Interfaces.C.int; - Array_Item : Integer; - Param : aliased struct_sched_param; - - begin - Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); - - if Time_Slice_Val > 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_RR, Param'Access); - - elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_FIFO, Param'Access); - - else - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_OTHER, Param'Access); - end if; - - pragma Assert (Result = 0); - - if FIFO_Within_Priorities then - - -- Annex D requirement [RM D.2.2 par. 9]: - -- If the task drops its priority due to the loss of inherited - -- priority, it is added at the head of the ready queue for its - -- new active priority. - - if Loss_Of_Inheritance - and then Prio < T.Common.Current_Priority - then - Array_Item := Prio_Array (T.Common.Base_Priority) + 1; - Prio_Array (T.Common.Base_Priority) := Array_Item; - - loop - -- Let some processes a chance to arrive - - Yield; - - -- Then wait for our turn to proceed - - exit when Array_Item = Prio_Array (T.Common.Base_Priority) - or else Prio_Array (T.Common.Base_Priority) = 1; - end loop; - - Prio_Array (T.Common.Base_Priority) := - Prio_Array (T.Common.Base_Priority) - 1; - end if; - end if; - - T.Common.Current_Priority := Prio; - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_ID) return System.Any_Priority is - begin - return T.Common.Current_Priority; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (Self_ID : Task_ID) is - begin - Self_ID.Common.LL.Thread := pthread_self; - Specific.Set (Self_ID); - - Lock_RTS; - - for J in Known_Tasks'Range loop - if Known_Tasks (J) = null then - Known_Tasks (J) := Self_ID; - Self_ID.Known_Tasks_Index := J; - exit; - end if; - end loop; - - Unlock_RTS; - end Enter_Task; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_ID is - begin - if Is_Valid_Task then - return Self; - else - return Register_Foreign_Thread (pthread_self); - end if; - end Register_Foreign_Thread; - - -------------------- - -- Initialize_TCB -- - -------------------- - - procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is - Mutex_Attr : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - Cond_Attr : aliased pthread_condattr_t; - - begin - if not Single_Lock then - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, - Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result = 0 then - Succeeded := True; - else - if not Single_Lock then - Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Succeeded := False; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_ID; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - Attributes : aliased pthread_attr_t; - Adjusted_Stack_Size : Interfaces.C.size_t; - Result : Interfaces.C.int; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - begin - if Stack_Size = Unspecified_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size); - - elsif Stack_Size < Minimum_Stack_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); - - else - Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); - end if; - - Result := pthread_attr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_attr_setstacksize - (Attributes'Access, Adjusted_Stack_Size); - pragma Assert (Result = 0); - - -- Since the initial signal mask of a thread is inherited from the - -- creator, and the Environment task has all its signals masked, we - -- do not need to manipulate caller's signal mask at this point. - -- All tasks in RTS will have All_Tasks_Mask initially. - - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); - pragma Assert (Result = 0 or else Result = EAGAIN); - - Succeeded := Result = 0; - - pthread_detach (T.Common.LL.Thread'Access); - -- Detach the thread using pthread_detach, sinc DCE threads do not have - -- pthread_attr_set_detachstate. - - Result := pthread_attr_destroy (Attributes'Access); - pragma Assert (Result = 0); - - Set_Priority (T, Priority); - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_ID) is - Result : Interfaces.C.int; - Tmp : Task_ID := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); - - begin - if not Single_Lock then - Result := pthread_mutex_destroy (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_cond_destroy (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - procedure Exit_Task is - begin - Specific.Set (null); - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_ID) is - begin - -- - -- Interrupt Server_Tasks may be waiting on an "event" flag (signal) - -- - if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then - System.Interrupt_Management.Operations.Interrupt_Self_Process - (System.Interrupt_Management.Interrupt_ID - (PIO.Get_Interrupt_ID (T))); - end if; - end Abort_Task; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy versions. The only currently working versions is for solaris - -- (native). - - function Check_Exit (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - begin - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - begin - return True; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_ID is - begin - return Environment_Task_ID; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean - is - pragma Unreferenced (T); - pragma Unreferenced (Thread_Self); - - begin - return False; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean - is - pragma Unreferenced (T); - pragma Unreferenced (Thread_Self); - - begin - return False; - end Resume_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_ID) is - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - Tmp_Set : aliased sigset_t; - Result : Interfaces.C.int; - - function State (Int : System.Interrupt_Management.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: - - 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 - Environment_Task_ID := Environment_Task; - - -- Initialize the lock used to synchronize chain of all ATCBs. - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - - Specific.Initialize (Environment_Task); - - Enter_Task (Environment_Task); - - -- Install the abort-signal handler - - if State (System.Interrupt_Management.Abort_Task_Interrupt) - /= Default - then - act.sa_flags := 0; - act.sa_handler := Abort_Handler'Address; - - Result := sigemptyset (Tmp_Set'Access); - pragma Assert (Result = 0); - act.sa_mask := Tmp_Set; - - Result := - sigaction ( - Signal (System.Interrupt_Management.Abort_Task_Interrupt), - act'Unchecked_Access, - old_act'Unchecked_Access); - pragma Assert (Result = 0); - end if; - end Initialize; - - -- NOTE: Unlike other pthread implementations, we do *not* mask all - -- signals here since we handle signals using the process-wide primitive - -- signal, rather than using sigthreadmask and sigwait. The reason of - -- this difference is that sigwait doesn't work when some critical - -- signals (SIGABRT, SIGPIPE) are masked. - -end System.Task_Primitives.Operations; diff --git a/gcc/ada/5htaspri.ads b/gcc/ada/5htaspri.ads deleted file mode 100644 index 4f422c24271..00000000000 --- a/gcc/ada/5htaspri.ads +++ /dev/null @@ -1,89 +0,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-2000 Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a HP-UX version of this package. - --- This package provides low-level support for most tasking features. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with System.OS_Interface; --- used for pthread_mutex_t --- pthread_cond_t --- pthread_t - -package System.Task_Primitives is - - type Lock is limited private; - -- Should be used for implementation of protected objects. - - type RTS_Lock is limited private; - -- Should be used inside the runtime system. - -- The difference between Lock and the RTS_Lock is that the later - -- one serves only as a semaphore so that do not check for - -- ceiling violations. - - type Task_Body_Access is access procedure; - -- Pointer to the task body's entry point (or possibly a wrapper - -- declared local to the GNARL). - - type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task - -- basis. A component of this type is guaranteed to be included - -- in the Ada_Task_Control_Block. - -private - type Lock is record - L : aliased System.OS_Interface.pthread_mutex_t; - Priority : Integer; - Owner_Priority : Integer; - end record; - - type RTS_Lock is new System.OS_Interface.pthread_mutex_t; - type Private_Data is record - Thread : aliased System.OS_Interface.pthread_t; - pragma Atomic (Thread); - -- Thread field may be updated by two different threads of control. - -- (See, Enter_Task and Create_Task in s-taprop.adb). - -- They put the same value (thr_self value). We do not want to - -- use lock on those operations and the only thing we have to - -- make sure is that they are updated in atomic fashion. - - CV : aliased System.OS_Interface.pthread_cond_t; - L : aliased RTS_Lock; - -- protection for all components is lock L - end record; - -end System.Task_Primitives; diff --git a/gcc/ada/5htraceb.adb b/gcc/ada/5htraceb.adb deleted file mode 100644 index dce251a05a9..00000000000 --- a/gcc/ada/5htraceb.adb +++ /dev/null @@ -1,600 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K -- --- (HP/UX Version) -- --- -- --- 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. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -package body System.Traceback is - - -- This package implements the backtracing facility by way of a dedicated - -- HP library for stack unwinding described in the "Runtime Architecture - -- Document". - - pragma Linker_Options ("/usr/lib/libcl.a"); - - -- The library basically offers services to fetch information about a - -- "previous" frame based on information about a "current" one. - - type Current_Frame_Descriptor is record - cur_fsz : Address; -- Frame size of current routine. - cur_sp : Address; -- The current value of stack pointer. - cur_rls : Address; -- PC-space of the caller. - cur_rlo : Address; -- PC-offset of the caller. - cur_dp : Address; -- Data Pointer of the current routine. - top_rp : Address; -- Initial value of RP. - top_mrp : Address; -- Initial value of MRP. - top_sr0 : Address; -- Initial value of sr0. - top_sr4 : Address; -- Initial value of sr4. - top_r3 : Address; -- Initial value of gr3. - cur_r19 : Address; -- GR19 value of the calling routine. - top_r4 : Address; -- Initial value of gr4. - dummy : Address; -- Reserved. - out_rlo : Address; -- PC-offset of the caller after get_previous. - end record; - - type Previous_Frame_Descriptor is record - prev_fsz : Address; -- frame size of calling routine. - prev_sp : Address; -- SP of calling routine. - prev_rls : Address; -- PC_space of calling routine's caller. - prev_rlo : Address; -- PC_offset of calling routine's caller. - prev_dp : Address; -- DP of calling routine. - udescr0 : Address; -- low word of calling routine's unwind desc. - udescr1 : Address; -- high word of calling routine's unwind desc. - ustart : Address; -- start of the unwind region. - uend : Address; -- end of the unwind region. - uw_index : Address; -- index into the unwind table. - prev_r19 : Address; -- GR19 value of the caller's caller. - top_r3 : Address; -- Caller's initial gr3. - top_r4 : Address; -- Caller's initial gr4. - end record; - - -- Provide useful shortcuts for the names - - subtype CFD is Current_Frame_Descriptor; - subtype PFD is Previous_Frame_Descriptor; - - -- Frames with dynamic stack allocation are handled using the associated - -- frame pointer, but HP compilers and GCC setup this pointer differently. - -- HP compilers set it to point at the top (highest address) of the static - -- part of the frame, wheras GCC sets it to point at the bottom of this - -- region. We have to fake the unwinder to compensate for this difference, - -- for which we'll need to access some subprograms unwind descriptors. - - type Bits_2_Value is mod 2 ** 2; - for Bits_2_Value'Size use 2; - - type Bits_4_Value is mod 2 ** 4; - for Bits_4_Value'Size use 4; - - type Bits_5_Value is mod 2 ** 5; - for Bits_5_Value'Size use 5; - - type Bits_27_Value is mod 2 ** 27; - for Bits_27_Value'Size use 27; - - type Unwind_Descriptor is record - cannot_unwind : Boolean; - mcode : Boolean; - mcode_save_restore : Boolean; - region_desc : Bits_2_Value; - reserved0 : Boolean; - entry_sr : Boolean; - entry_fr : Bits_4_Value; - entry_gr : Bits_5_Value; - - args_stored : Boolean; - variable_frame : Boolean; - separate_package_body : Boolean; - frame_extension_mcode : Boolean; - - stack_overflow_check : Boolean; - two_steps_sp_adjust : Boolean; - sr4_export : Boolean; - cxx_info : Boolean; - - cxx_try_catch : Boolean; - sched_entry_seq : Boolean; - reserved1 : Boolean; - save_sp : Boolean; - - save_rp : Boolean; - save_mrp : Boolean; - save_r19 : Boolean; - cleanups : Boolean; - - hpe_interrupt_marker : Boolean; - hpux_interrupt_marker : Boolean; - large_frame : Boolean; - alloca_frame : Boolean; - - reserved2 : Boolean; - frame_size : Bits_27_Value; - end record; - - for Unwind_Descriptor'Size use 64; - - for Unwind_Descriptor use record - cannot_unwind at 0 range 0 .. 0; - mcode at 0 range 1 .. 1; - mcode_save_restore at 0 range 2 .. 2; - region_desc at 0 range 3 .. 4; - reserved0 at 0 range 5 .. 5; - entry_sr at 0 range 6 .. 6; - entry_fr at 0 range 7 .. 10; - - entry_gr at 1 range 3 .. 7; - - args_stored at 2 range 0 .. 0; - variable_frame at 2 range 1 .. 1; - separate_package_body at 2 range 2 .. 2; - frame_extension_mcode at 2 range 3 .. 3; - stack_overflow_check at 2 range 4 .. 4; - two_steps_sp_adjust at 2 range 5 .. 5; - sr4_export at 2 range 6 .. 6; - cxx_info at 2 range 7 .. 7; - - cxx_try_catch at 3 range 0 .. 0; - sched_entry_seq at 3 range 1 .. 1; - reserved1 at 3 range 2 .. 2; - save_sp at 3 range 3 .. 3; - save_rp at 3 range 4 .. 4; - save_mrp at 3 range 5 .. 5; - save_r19 at 3 range 6 .. 6; - cleanups at 3 range 7 .. 7; - - hpe_interrupt_marker at 4 range 0 .. 0; - hpux_interrupt_marker at 4 range 1 .. 1; - large_frame at 4 range 2 .. 2; - alloca_frame at 4 range 3 .. 3; - - reserved2 at 4 range 4 .. 4; - frame_size at 4 range 5 .. 31; - end record; - - subtype UWD is Unwind_Descriptor; - type UWD_Ptr is access all UWD; - - function To_UWD_Access is new Ada.Unchecked_Conversion (Address, UWD_Ptr); - - -- The descriptor associated with a given code location is retrieved - -- using functions imported from the HP library, requiring the definition - -- of additional structures. - - type Unwind_Table_Region is record - Table_Start : Address; - Table_End : Address; - end record; - -- An Unwind Table region, which is a memory area containing Unwind - -- Descriptors. - - subtype UWT is Unwind_Table_Region; - - -- The subprograms imported below are provided by the HP library - - function U_get_unwind_table return UWT; - pragma Import (C, U_get_unwind_table, "U_get_unwind_table"); - -- Get the unwind table region associated with the current executable. - -- This function is actually documented as having an argument, but which - -- is only used for the MPE/iX targets. - - function U_get_shLib_unwind_table (r19 : Address) return UWT; - pragma Import (C, U_get_shLib_unwind_table, "U_get_shLib_unw_tbl"); - -- Return the unwind table region associated with a possible shared - -- library, as determined by the provided r19 value. - - function U_get_shLib_text_addr (r19 : Address) return Address; - pragma Import (C, U_get_shLib_text_addr, "U_get_shLib_text_addr"); - -- Return the address at which the code for a shared library begins, or - -- -1 if the value provided for r19 does not identify shared library code. - - function U_get_unwind_entry - (Pc : Address; - Space : Address; - Table_Start : Address; - Table_End : Address) return Address; - pragma Import (C, U_get_unwind_entry, "U_get_unwind_entry"); - -- Given the bounds of an unwind table, return the address of the - -- unwind descriptor associated with a code location/space. In the case - -- of shared library code, the offset from the beginning of the library - -- is expected as Pc. - - procedure U_init_frame_record (Frame : access CFD); - pragma Import (C, U_init_frame_record, "U_init_frame_record"); - - procedure U_prep_frame_rec_for_unwind (Frame : access CFD); - pragma Import (C, U_prep_frame_rec_for_unwind, - "U_prep_frame_rec_for_unwind"); - - -- Fetch the description data of the frame in which these two procedures - -- are called. - - function U_get_u_rlo (Cur : access CFD; Prev : access PFD) return Integer; - pragma Import (C, U_get_u_rlo, "U_IS_STUB_OR_CALLX"); - -- From a complete current frame with a return location possibly located - -- into a linker generated stub, and basic information about the previous - -- frame, place the first non stub return location into the current frame. - -- Return -1 if something went wrong during the computation. - - function U_is_shared_pc (rlo : Address; r19 : Address) return Address; - pragma Import (C, U_is_shared_pc, "U_is_shared_pc"); - -- Return 0 if the provided return location does not correspond to code - -- in a shared library, or something non null otherwise. - - function U_get_previous_frame_x - (current_frame : access CFD; - previous_frame : access PFD; - previous_size : Integer) return Integer; - pragma Import (C, U_get_previous_frame_x, "U_get_previous_frame_x"); - -- Fetch the data describing the "previous" frame relatively to the - -- "current" one. "previous_size" should be the size of the "previous" - -- frame descriptor provided. - -- - -- The library provides a simpler interface without the size parameter - -- but it is not usable when frames with dynamically allocated space are - -- on the way. - - ------------------ - -- 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; - - ---------------- - -- 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 System.Address; - pragma Suppress_Initialization (Tracebacks_Array); - - -- The code location returned by the unwinder is a return location but - -- what we need is a call point. Under HP-UX call instructions are 4 - -- bytes long and the return point they specify is 4 bytes beyond the - -- next instruction because of the delay slot. - - Call_Size : constant := 4; - DSlot_Size : constant := 4; - Rlo_Offset : constant := Call_Size + DSlot_Size; - - -- Moreover, the return point is passed via a register which two least - -- significant bits specify a privilege level that we will have to mask. - - Priv_Mask : constant := 16#00000003#; - - Frame : aliased CFD; - Code : System.Address; - J : Natural := 1; - Pop_Success : Boolean; - Trace : Tracebacks_Array; - for Trace'Address use Traceback; - - -- The backtracing process needs a set of subprograms : - - function UWD_For_RLO_Of (Frame : access CFD) return UWD_Ptr; - -- Return an access to the unwind descriptor for the caller of - -- a given frame, using only the provided return location. - - function UWD_For_Caller_Of (Frame : access CFD) return UWD_Ptr; - -- Return an access to the unwind descriptor for the user code caller - -- of a given frame, or null if the information is not available. - - function Pop_Frame (Frame : access CFD) return Boolean; - -- Update the provided machine state structure so that it reflects - -- the state one call frame "above" the initial one. - -- - -- Return True if the operation has been successful, False otherwise. - -- Failure typically occurs when the top of the call stack has been - -- reached. - - function Prepare_For_Unwind_Of (Frame : access CFD) return Boolean; - -- Perform the necessary adaptations to the machine state before - -- calling the unwinder. Currently used for the specific case of - -- dynamically sized previous frames. - -- - -- Return True if everything went fine, or False otherwise. - - Program_UWT : constant UWT := U_get_unwind_table; - - --------------- - -- Pop_Frame -- - --------------- - - function Pop_Frame (Frame : access CFD) return Boolean is - Up_Frame : aliased PFD; - State_Ready : Boolean; - - begin - -- Check/adapt the state before calling the unwinder and return - -- if anything went wrong. - - State_Ready := Prepare_For_Unwind_Of (Frame); - - if not State_Ready then - return False; - end if; - - -- Now, safely call the unwinder and use the results. - - if U_get_previous_frame_x (Frame, - Up_Frame'Access, - Up_Frame'Size) /= 0 - then - return False; - end if; - - -- In case a stub is on the way, the usual previous return location - -- (the one in prev_rlo) is the one in the stub and the "real" one - -- is placed in the "current" record, so let's take this one into - -- account. - - Frame.out_rlo := Frame.cur_rlo; - - Frame.cur_fsz := Up_Frame.prev_fsz; - Frame.cur_sp := Up_Frame.prev_sp; - Frame.cur_rls := Up_Frame.prev_rls; - Frame.cur_rlo := Up_Frame.prev_rlo; - Frame.cur_dp := Up_Frame.prev_dp; - Frame.cur_r19 := Up_Frame.prev_r19; - Frame.top_r3 := Up_Frame.top_r3; - Frame.top_r4 := Up_Frame.top_r4; - - return True; - end Pop_Frame; - - --------------------------------- - -- Prepare_State_For_Unwind_Of -- - --------------------------------- - - function Prepare_For_Unwind_Of (Frame : access CFD) return Boolean - is - Caller_UWD : UWD_Ptr; - FP_Adjustment : Integer; - - begin - -- No need to bother doing anything if the stack is already fully - -- unwound. - - if Frame.cur_rlo = 0 then - return False; - end if; - - -- When ALLOCA_FRAME is set in an unwind descriptor, the unwinder - -- uses the value provided in current.top_r3 or current.top_r4 as - -- a frame pointer to compute the size of the frame. What decides - -- between r3 or r4 is the unwind descriptor LARGE_FRAME bit, with - -- r4 chosen if the bit is set. - - -- The size computed by the unwinder is STATIC_PART + (SP - FP), - -- which is correct with HP's frame pointer convention, but not - -- with GCC's one since we end up with the static part accounted - -- for twice. - - -- We have to compute r4 when it is required because the unwinder - -- has looked for it at a place where it was not if we went through - -- GCC frames. - - -- The size of the static part of a frame can be found in the - -- associated unwind descriptor. - - Caller_UWD := UWD_For_Caller_Of (Frame); - - -- If we cannot get it, we are unable to compute the potentially - -- necessary adjustments. We'd better not try to go on then. - - if Caller_UWD = null then - return False; - end if; - - -- If the caller frame is a GCC one, r3 is its frame pointer and - -- points to the bottom of the frame. The value to provide for r4 - -- can then be computed directly from the one of r3, compensating - -- for the static part of the frame. - - -- If the caller frame is an HP one, r3 is used to locate the - -- previous frame marker, that is it also points to the bottom of - -- the frame (this is why r3 cannot be used as the frame pointer in - -- the HP sense for large frames). The value to provide for r4 can - -- then also be computed from the one of r3 with the compensation - -- for the static part of the frame. - - FP_Adjustment := Integer (Caller_UWD.frame_size * 8); - Frame.top_r4 := Address (Integer (Frame.top_r3) + FP_Adjustment); - - return True; - end Prepare_For_Unwind_Of; - - ----------------------- - -- UWD_For_Caller_Of -- - ----------------------- - - function UWD_For_Caller_Of (Frame : access CFD) return UWD_Ptr - is - UWD_Access : UWD_Ptr; - - begin - -- First try the most direct path, using the return location data - -- associated with the frame. - - UWD_Access := UWD_For_RLO_Of (Frame); - - if UWD_Access /= null then - return UWD_Access; - end if; - - -- If we did not get a result, we might face an in-stub return - -- address. In this case U_get_previous_frame can tell us what the - -- first not-in-stub return point is. We cannot call it directly, - -- though, because we haven't computed the potentially necessary - -- frame pointer adjustments, which might lead to SEGV in some - -- circumstances. Instead, we directly call the libcl routine which - -- is called by U_get_previous_frame and which only requires few - -- information. Take care, however, that the information is provided - -- in the "current" argument, so we need to work on a copy to avoid - -- disturbing our caller. - - declare - U_Current : aliased CFD := Frame.all; - U_Previous : aliased PFD; - - begin - U_Previous.prev_dp := U_Current.cur_dp; - U_Previous.prev_rls := U_Current.cur_rls; - U_Previous.prev_sp := U_Current.cur_sp - U_Current.cur_fsz; - - if U_get_u_rlo (U_Current'Access, U_Previous'Access) /= -1 then - UWD_Access := UWD_For_RLO_Of (U_Current'Access); - end if; - end; - - return UWD_Access; - end UWD_For_Caller_Of; - - -------------------- - -- UWD_For_RLO_Of -- - -------------------- - - function UWD_For_RLO_Of (Frame : access CFD) return UWD_Ptr - is - UWD_Address : Address; - - -- The addresses returned by the library point to full descriptors - -- including the frame information bits but also the applicable PC - -- range. We need to account for this. - - Frame_Info_Offset : constant := 8; - - begin - -- First try to locate the descriptor in the program's unwind table. - - UWD_Address := U_get_unwind_entry (Frame.cur_rlo, - Frame.cur_rls, - Program_UWT.Table_Start, - Program_UWT.Table_End); - - -- If we did not get it, we might have a frame from code in a - -- stub or shared library. For code in stub we would have to - -- compute the first non-stub return location but this is not - -- the role of this subprogram, so let's just try to see if we - -- can get a result from the tables in shared libraries. - - if UWD_Address = -1 - and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0 - then - declare - Shlib_UWT : constant UWT := - U_get_shLib_unwind_table (Frame.cur_r19); - Shlib_Start : constant Address := - U_get_shLib_text_addr (Frame.cur_r19); - Rlo_Offset : constant Address := - Frame.cur_rlo - Shlib_Start; - begin - UWD_Address := U_get_unwind_entry (Rlo_Offset, - Frame.cur_rls, - Shlib_UWT.Table_Start, - Shlib_UWT.Table_End); - end; - end if; - - if UWD_Address /= -1 then - return To_UWD_Access (UWD_Address + Frame_Info_Offset); - else - return null; - end if; - end UWD_For_RLO_Of; - - -- Start of processing for Call_Chain - - begin - -- Fetch the state for this subprogram's frame and pop it so that we - -- start with an initial out_rlo "here". - - U_init_frame_record (Frame'Access); - Frame.top_sr0 := 0; - Frame.top_sr4 := 0; - - U_prep_frame_rec_for_unwind (Frame'Access); - - Pop_Success := Pop_Frame (Frame'Access); - - -- Skip the requested number of frames. - - for I in 1 .. Skip_Frames loop - Pop_Success := Pop_Frame (Frame'Access); - end loop; - - -- Loop popping frames and storing locations until either a problem - -- occurs, or the top of the call chain is reached, or the provided - -- array is full. - - loop - -- We have to test some conditions against the return location - -- as it is returned, so get it as is first. - - Code := Frame.out_rlo; - - exit when not Pop_Success or else Code = 0 or else J = Max_Len + 1; - - -- Compute the call point from the retrieved return location : - -- Mask the privilege bits and account for the delta between the - -- call site and the return point. - - Code := (Code and not Priv_Mask) - Rlo_Offset; - - if Code < Exclude_Min or else Code > Exclude_Max then - Trace (J) := Code; - J := J + 1; - end if; - - Pop_Success := Pop_Frame (Frame'Access); - end loop; - - Len := J - 1; - end Call_Chain; - -end System.Traceback; diff --git a/gcc/ada/5iosinte.adb b/gcc/ada/5iosinte.adb deleted file mode 100644 index 36c082c86aa..00000000000 --- a/gcc/ada/5iosinte.adb +++ /dev/null @@ -1,132 +0,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 GNU/LinuxThreads, Solaris pthread and HP-UX pthread version --- of this package. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - -with Interfaces.C; use Interfaces.C; -package body System.OS_Interface is - - -------------------- - -- Get_Stack_Base -- - -------------------- - - function Get_Stack_Base (thread : pthread_t) return Address is - pragma Warnings (Off, thread); - - begin - return Null_Address; - end Get_Stack_Base; - - ------------------ - -- pthread_init -- - ------------------ - - procedure pthread_init is - begin - null; - end pthread_init; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (TS : timespec) return Duration is - begin - return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; - end To_Duration; - - function To_Duration (TV : struct_timeval) return Duration is - begin - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end To_Duration; - - ----------------- - -- To_Timespec -- - ----------------- - - function To_Timespec (D : Duration) return timespec is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return timespec'(tv_sec => S, - tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); - end To_Timespec; - - ---------------- - -- To_Timeval -- - ---------------- - - function To_Timeval (D : Duration) return struct_timeval is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return - struct_timeval' - (tv_sec => S, - tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); - end To_Timeval; - -end System.OS_Interface; diff --git a/gcc/ada/5iosinte.ads b/gcc/ada/5iosinte.ads deleted file mode 100644 index c8f06916f13..00000000000 --- a/gcc/ada/5iosinte.ads +++ /dev/null @@ -1,524 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 a GNU/Linux (GNU/LinuxThreads) version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-lpthread"); - - subtype int is Interfaces.C.int; - subtype char is Interfaces.C.char; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 11; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - EPERM : constant := 1; - ETIMEDOUT : constant := 110; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 63; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 7; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGUSR1 : constant := 10; -- user defined signal 1 - SIGUSR2 : constant := 12; -- user defined signal 2 - SIGCLD : constant := 17; -- alias for SIGCHLD - SIGCHLD : constant := 17; -- child status change - SIGPWR : constant := 30; -- power-fail restart - SIGWINCH : constant := 28; -- window size change - SIGURG : constant := 23; -- urgent condition on IO channel - SIGPOLL : constant := 29; -- pollable event occurred - SIGIO : constant := 29; -- I/O now possible (4.2 BSD) - SIGLOST : constant := 29; -- File lock lost - SIGSTOP : constant := 19; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 20; -- user stop requested from tty - SIGCONT : constant := 18; -- stopped process has been continued - SIGTTIN : constant := 21; -- background tty read attempted - SIGTTOU : constant := 22; -- background tty write attempted - SIGVTALRM : constant := 26; -- virtual timer expired - SIGPROF : constant := 27; -- profiling timer expired - SIGXCPU : constant := 24; -- CPU time limit exceeded - SIGXFSZ : constant := 25; -- filesize limit exceeded - SIGUNUSED : constant := 31; -- unused signal (GNU/Linux) - SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux) - SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal - SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal - SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal - - SIGADAABORT : constant := SIGABRT; - -- Change this if you want to use another signal for task abort. - -- SIGTERM might be a good one. - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := ( - SIGTRAP, - -- To enable debugging on multithreaded applications, mark SIGTRAP to - -- be kept unmasked. - - SIGBUS, - - SIGTTIN, SIGTTOU, SIGTSTP, - -- Keep these three signals unmasked so that background processes - -- and IO behaves as normal "C" applications - - SIGPROF, - -- To avoid confusing the profiler - - SIGKILL, SIGSTOP, - -- These two signals actually cannot be masked; - -- POSIX simply won't allow it. - - SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG); - -- These three signals are used by GNU/LinuxThreads starting from - -- glibc 2.1 (future 2.2). - - Reserved : constant Signal_Set := - -- I am not sure why the following two signals are reserved. - -- I guess they are not supported by this version of GNU/Linux. - (SIGVTALRM, SIGUNUSED); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type union_type_3 is new String (1 .. 116); - type siginfo_t is record - si_signo : int; - si_code : int; - si_errno : int; - X_data : union_type_3; - end record; - pragma Convention (C, siginfo_t); - - type struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : unsigned_long; - sa_restorer : System.Address; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - type Machine_State is record - eip : unsigned_long; - ebx : unsigned_long; - esp : unsigned_long; - ebp : unsigned_long; - esi : unsigned_long; - edi : unsigned_long; - end record; - type Machine_State_Ptr is access all Machine_State; - - SA_SIGINFO : constant := 16#04#; - - SIG_BLOCK : constant := 0; - SIG_UNBLOCK : constant := 1; - SIG_SETMASK : constant := 2; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - type timespec is private; - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timeval is private; - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - function gettimeofday - (tv : access struct_timeval; - tz : System.Address := System.Null_Address) return int; - pragma Import (C, gettimeofday, "gettimeofday"); - - function sysconf (name : int) return long; - pragma Import (C, sysconf); - - SC_CLK_TCK : constant := 2; - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_OTHER : constant := 0; - SCHED_FIFO : constant := 1; - SCHED_RR : constant := 2; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is new unsigned_long; - subtype Thread_Id is pthread_t; - - function To_pthread_t is new Unchecked_Conversion - (unsigned_long, pthread_t); - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 1; - - ----------- - -- Stack -- - ----------- - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- This is a dummy procedure to share some GNULLI files - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - procedure pthread_init; - pragma Inline (pthread_init); - -- This is a dummy procedure to share some GNULLI files - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait (set : access sigset_t; sig : access Signal) return int; - pragma Import (C, sigwait, "sigwait"); - - function pthread_kill (thread : pthread_t; sig : Signal) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask, "pthread_sigmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "pthread_cond_init"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - pragma Convention (C, struct_sched_param); - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; - policy : int) return int; - pragma Import - (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy"); - - function sched_yield return int; - pragma Import (C, sched_yield, "sched_yield"); - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "pthread_attr_init"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Import - (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate"); - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "pthread_create"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "pthread_setspecific"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Import (C, pthread_getspecific, "pthread_getspecific"); - - type destructor_pointer is access procedure (arg : System.Address); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "pthread_key_create"); - -private - - type sigset_t is array (0 .. 127) of unsigned_char; - pragma Convention (C, sigset_t); - - type pid_t is new int; - - type time_t is new long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type struct_timeval is record - tv_sec : time_t; - tv_usec : time_t; - end record; - pragma Convention (C, struct_timeval); - - type pthread_attr_t is record - detachstate : int; - schedpolicy : int; - schedparam : struct_sched_param; - inheritsched : int; - scope : int; - guardsize : size_t; - stackaddr_set : int; - stackaddr : System.Address; - stacksize : size_t; - end record; - pragma Convention (C, pthread_attr_t); - - type pthread_condattr_t is record - dummy : int; - end record; - pragma Convention (C, pthread_condattr_t); - - type pthread_mutexattr_t is record - mutexkind : int; - end record; - pragma Convention (C, pthread_mutexattr_t); - - type struct_pthread_fast_lock is record - status : long; - spinlock : int; - end record; - pragma Convention (C, struct_pthread_fast_lock); - - type pthread_mutex_t is record - m_reserved : int; - m_count : int; - m_owner : System.Address; - m_kind : int; - m_lock : struct_pthread_fast_lock; - end record; - pragma Convention (C, pthread_mutex_t); - - type pthread_cond_t is array (0 .. 47) of unsigned_char; - pragma Convention (C, pthread_cond_t); - - type pthread_key_t is new unsigned; - -end System.OS_Interface; diff --git a/gcc/ada/5itaprop.adb b/gcc/ada/5itaprop.adb deleted file mode 100644 index 6ab670f9722..00000000000 --- a/gcc/ada/5itaprop.adb +++ /dev/null @@ -1,1094 +0,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 . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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 a GNU/Linux (GNU/LinuxThreads) version of this package - --- This package contains all the GNULL primitives that interface directly --- with the underlying OS. - -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.Tasking.Debug; --- used for Known_Tasks - -with Interfaces.C; --- used for int --- size_t - -with System.Interrupt_Management; --- used for Keep_Unmasked --- Abort_Task_Interrupt --- Interrupt_ID - -with System.Interrupt_Management.Operations; --- used for Set_Interrupt_Mask --- All_Tasks_Mask -pragma Elaborate_All (System.Interrupt_Management.Operations); - -with System.Parameters; --- used for Size_Type - -with System.Tasking; --- used for Ada_Task_Control_Block --- Task_ID - -with Ada.Exceptions; --- used for Raise_Exception --- Raise_From_Signal_Handler --- Exception_Id - -with System.Soft_Links; --- used for Defer/Undefer_Abort - --- Note that we do not use System.Tasking.Initialization directly since --- this is a higher level package that we shouldn't depend on. For example --- when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Initialization - -with System.OS_Primitives; --- used for Delay_Modes - -with System.Soft_Links; --- used for Get_Machine_State_Addr - -with Unchecked_Conversion; -with Unchecked_Deallocation; - -package body System.Task_Primitives.Operations is - - use System.Tasking.Debug; - use System.Tasking; - use Interfaces.C; - use System.OS_Interface; - use System.Parameters; - use System.OS_Primitives; - - package SSL renames System.Soft_Links; - - ------------------ - -- Local Data -- - ------------------ - - -- The followings are logically constants, but need to be initialized - -- at run time. - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_ID associated with a thread - - Environment_Task_ID : Task_ID; - -- A variable to hold Task_ID for the environment task. - - Unblocked_Signal_Mask : aliased sigset_t; - -- The set of signals that should unblocked in all tasks - - -- The followings are internal configuration constants needed. - Priority_Ceiling_Emulation : constant Boolean := True; - - Next_Serial_Number : Task_Serial_Number := 100; - -- We start at 100, to reserve some special values for - -- using in error checking. - -- The following are internal configuration constants needed. - - Time_Slice_Val : Integer; - pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - - Dispatching_Policy : Character; - pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - - FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; - -- Indicates whether FIFO_Within_Priorities is set. - - -- The following are effectively constants, but they need to - -- be initialized by calling a pthread_ function. - - Mutex_Attr : aliased pthread_mutexattr_t; - Cond_Attr : aliased pthread_condattr_t; - - Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads). - - -------------------- - -- Local Packages -- - -------------------- - - package Specific is - - procedure Initialize (Environment_Task : Task_ID); - pragma Inline (Initialize); - -- Initialize various data needed by this package. - - function Is_Valid_Task return Boolean; - pragma Inline (Is_Valid_Task); - -- Does executing thread have a TCB? - - procedure Set (Self_Id : Task_ID); - pragma Inline (Set); - -- Set the self id for the current task. - - function Self return Task_ID; - pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task. - - end Specific; - - package body Specific is separate; - -- The body of this package is target specific. - - --------------------------------- - -- Support for foreign threads -- - --------------------------------- - - function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; - -- Allocate and Initialize a new ATCB for the current Thread. - - function Register_Foreign_Thread - (Thread : Thread_Id) return Task_ID is separate; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - subtype unsigned_long is Interfaces.C.unsigned_long; - - procedure Abort_Handler (signo : Signal); - - function To_pthread_t is new Unchecked_Conversion - (unsigned_long, System.OS_Interface.pthread_t); - - ------------------- - -- Abort_Handler -- - ------------------- - - procedure Abort_Handler (signo : Signal) is - pragma Unreferenced (signo); - - Self_Id : constant Task_ID := Self; - Result : Interfaces.C.int; - Old_Set : aliased sigset_t; - - begin - if ZCX_By_Default and then GCC_ZCX_Support then - return; - end if; - - if Self_Id.Deferral_Level = 0 - and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level - and then not Self_Id.Aborting - then - Self_Id.Aborting := True; - - -- Make sure signals used for RTS internal purpose are unmasked - - Result := pthread_sigmask (SIG_UNBLOCK, - Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); - pragma Assert (Result = 0); - - raise Standard'Abort_Signal; - end if; - end Abort_Handler; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ----------------- - -- Stack_Guard -- - ----------------- - - -- The underlying thread system extends the memory (up to 2MB) when needed - - procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is - pragma Unreferenced (T); - pragma Unreferenced (On); - - begin - null; - end Stack_Guard; - - -------------------- - -- Get_Thread_Id -- - -------------------- - - function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_ID renames Specific.Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Initialize_TCB and the Storage_Error is - -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) - -- used in RTS is initialized before any status change of RTS. - -- Therefore rasing Storage_Error in the following routines - -- should be able to be handled safely. - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : access Lock) - is - Result : Interfaces.C.int; - - begin - if Priority_Ceiling_Emulation then - L.Ceiling := Prio; - end if; - - Result := pthread_mutex_init (L.L'Access, Mutex_Attr'Access); - - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Ada.Exceptions.Raise_Exception (Storage_Error'Identity, - "Failed to allocate a lock"); - end if; - end Initialize_Lock; - - procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is - pragma Unreferenced (Level); - - Result : Interfaces.C.int; - - begin - Result := pthread_mutex_init (L, Mutex_Attr'Access); - - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : access Lock) is - Result : Interfaces.C.int; - - begin - Result := pthread_mutex_destroy (L.L'Access); - pragma Assert (Result = 0); - end Finalize_Lock; - - procedure Finalize_Lock (L : access RTS_Lock) is - Result : Interfaces.C.int; - - begin - Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0); - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - Result : Interfaces.C.int; - - begin - if Priority_Ceiling_Emulation then - declare - Self_ID : constant Task_ID := Self; - - begin - if Self_ID.Common.LL.Active_Priority > L.Ceiling then - Ceiling_Violation := True; - return; - end if; - - L.Saved_Priority := Self_ID.Common.LL.Active_Priority; - - if Self_ID.Common.LL.Active_Priority < L.Ceiling then - Self_ID.Common.LL.Active_Priority := L.Ceiling; - end if; - - Result := pthread_mutex_lock (L.L'Access); - pragma Assert (Result = 0); - Ceiling_Violation := False; - end; - - else - Result := pthread_mutex_lock (L.L'Access); - Ceiling_Violation := Result = EINVAL; - - -- Assume the cause of EINVAL is a priority ceiling violation - - pragma Assert (Result = 0 or else Result = EINVAL); - end if; - end Write_Lock; - - procedure Write_Lock - (L : access RTS_Lock; - Global_Lock : Boolean := False) - is - Result : Interfaces.C.int; - - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_lock (L); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - procedure Write_Lock (T : Task_ID) is - Result : Interfaces.C.int; - - begin - if not Single_Lock then - Result := pthread_mutex_lock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - begin - Write_Lock (L, Ceiling_Violation); - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : access Lock) is - Result : Interfaces.C.int; - - begin - if Priority_Ceiling_Emulation then - declare - Self_ID : constant Task_ID := Self; - - begin - Result := pthread_mutex_unlock (L.L'Access); - pragma Assert (Result = 0); - - if Self_ID.Common.LL.Active_Priority > L.Saved_Priority then - Self_ID.Common.LL.Active_Priority := L.Saved_Priority; - end if; - end; - - else - Result := pthread_mutex_unlock (L.L'Access); - pragma Assert (Result = 0); - end if; - end Unlock; - - procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is - Result : Interfaces.C.int; - - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); - end if; - end Unlock; - - procedure Unlock (T : Task_ID) is - Result : Interfaces.C.int; - - begin - if not Single_Lock then - Result := pthread_mutex_unlock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Unlock; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : Task_ID; - Reason : System.Tasking.Task_States) - is - pragma Unreferenced (Reason); - - Result : Interfaces.C.int; - - begin - pragma Assert (Self_ID = Self); - - if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; - - -- EINTR is not considered a failure. - pragma Assert (Result = 0 or else Result = EINTR); - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - -- This is for use within the run-time system, so abort is - -- assumed to be already deferred, and the caller should be - -- holding its own ATCB lock. - - procedure Timed_Sleep - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : System.Tasking.Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Unreferenced (Reason); - - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - Timedout := True; - Yielded := False; - - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; - - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); - - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; - - if Single_Lock then - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, - Request'Access); - - else - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, - Request'Access); - end if; - - exit when Abs_Time <= Monotonic_Clock; - - if Result = 0 or Result = EINTR then - -- somebody may have called Wakeup for us - Timedout := False; - exit; - end if; - - pragma Assert (Result = ETIMEDOUT); - end loop; - end if; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - -- This is for use in implementing delay statements, so - -- we assume the caller is abort-deferred but is holding - -- no locks. - - procedure Timed_Delay - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes) - is - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - begin - - -- Only the little window between deferring abort and - -- locking Self_ID is the reason we need to - -- check for pending abort and priority change below! :( - - SSL.Abort_Defer.all; - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - - if Mode = Relative then - Abs_Time := Time + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; - - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); - Self_ID.Common.State := Delay_Sleep; - - loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - if Single_Lock then - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, Request'Access); - else - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Request'Access); - end if; - - exit when Abs_Time <= Monotonic_Clock; - - pragma Assert (Result = 0 or else - Result = ETIMEDOUT or else - Result = EINTR); - end loop; - - Self_ID.Common.State := Runnable; - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - Result := sched_yield; - SSL.Abort_Undefer.all; - end Timed_Delay; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration is - TV : aliased struct_timeval; - Result : Interfaces.C.int; - - begin - Result := gettimeofday (TV'Access, System.Null_Address); - pragma Assert (Result = 0); - return To_Duration (TV); - end Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - begin - return 10#1.0#E-6; - end RT_Resolution; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is - pragma Unreferenced (Reason); - Result : Interfaces.C.int; - begin - Result := pthread_cond_signal (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Wakeup; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - Result : Interfaces.C.int; - pragma Unreferenced (Result); - begin - if Do_Yield then - Result := sched_yield; - end if; - end Yield; - - ------------------ - -- Set_Priority -- - ------------------ - - procedure Set_Priority - (T : Task_ID; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) - is - pragma Unreferenced (Loss_Of_Inheritance); - - Result : Interfaces.C.int; - Param : aliased struct_sched_param; - - begin - T.Common.Current_Priority := Prio; - - if Priority_Ceiling_Emulation then - if T.Common.LL.Active_Priority < Prio then - T.Common.LL.Active_Priority := Prio; - end if; - end if; - - -- Priorities are in range 1 .. 99 on GNU/Linux, so we map - -- map 0 .. 31 to 1 .. 32 - - Param.sched_priority := Interfaces.C.int (Prio) + 1; - - if Time_Slice_Val > 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_RR, Param'Access); - - elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_FIFO, Param'Access); - - else - Param.sched_priority := 0; - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_OTHER, Param'Access); - end if; - - pragma Assert (Result = 0 or else Result = EPERM); - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_ID) return System.Any_Priority is - begin - return T.Common.Current_Priority; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (Self_ID : Task_ID) is - begin - Self_ID.Common.LL.Thread := pthread_self; - - Specific.Set (Self_ID); - - Lock_RTS; - - for J in Known_Tasks'Range loop - if Known_Tasks (J) = null then - Known_Tasks (J) := Self_ID; - Self_ID.Known_Tasks_Index := J; - exit; - end if; - end loop; - - Unlock_RTS; - end Enter_Task; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_ID is - begin - if Is_Valid_Task then - return Self; - else - return Register_Foreign_Thread (pthread_self); - end if; - end Register_Foreign_Thread; - - -------------------- - -- Initialize_TCB -- - -------------------- - - procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is - Result : Interfaces.C.int; - - begin - -- Give the task a unique serial number. - - Self_ID.Serial_Number := Next_Serial_Number; - Next_Serial_Number := Next_Serial_Number + 1; - pragma Assert (Next_Serial_Number /= 0); - - Self_ID.Common.LL.Thread := To_pthread_t (-1); - - if not Single_Lock then - Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, - Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Succeeded := False; - return; - end if; - end if; - - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Succeeded := True; - else - if not Single_Lock then - Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Succeeded := False; - end if; - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_ID; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - Adjusted_Stack_Size : Interfaces.C.size_t; - - Attributes : aliased pthread_attr_t; - Result : Interfaces.C.int; - - begin - if Stack_Size = Unspecified_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size); - - elsif Stack_Size < Minimum_Stack_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); - - else - Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); - end if; - - Result := pthread_attr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := - pthread_attr_setstacksize - (Attributes'Access, Adjusted_Stack_Size); - pragma Assert (Result = 0); - - Result := - pthread_attr_setdetachstate - (Attributes'Access, PTHREAD_CREATE_DETACHED); - pragma Assert (Result = 0); - - -- Since the initial signal mask of a thread is inherited from the - -- creator, and the Environment task has all its signals masked, we - -- do not need to manipulate caller's signal mask at this point. - -- All tasks in RTS will have All_Tasks_Mask initially. - - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); - pragma Assert (Result = 0 or else Result = EAGAIN); - - Succeeded := Result = 0; - - Result := pthread_attr_destroy (Attributes'Access); - pragma Assert (Result = 0); - - Set_Priority (T, Priority); - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_ID) is - Result : Interfaces.C.int; - Tmp : Task_ID := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); - - begin - if not Single_Lock then - Result := pthread_mutex_destroy (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_cond_destroy (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - procedure Exit_Task is - begin - Specific.Set (null); - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_ID) is - Result : Interfaces.C.int; - - begin - Result := pthread_kill (T.Common.LL.Thread, - Signal (System.Interrupt_Management.Abort_Task_Interrupt)); - pragma Assert (Result = 0); - end Abort_Task; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy version - - function Check_Exit (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - - begin - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - - begin - return True; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_ID is - begin - return Environment_Task_ID; - end Environment_Task; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) return Boolean - is - begin - if T.Common.LL.Thread /= Thread_Self then - return pthread_kill (T.Common.LL.Thread, SIGSTOP) = 0; - else - return True; - end if; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) return Boolean - is - begin - if T.Common.LL.Thread /= Thread_Self then - return pthread_kill (T.Common.LL.Thread, SIGCONT) = 0; - else - return True; - end if; - end Resume_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_ID) is - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - Tmp_Set : aliased sigset_t; - Result : Interfaces.C.int; - - function State (Int : System.Interrupt_Management.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: - - 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 - Environment_Task_ID := Environment_Task; - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - - -- Initialize the global RTS lock - - Specific.Initialize (Environment_Task); - - Enter_Task (Environment_Task); - - -- Install the abort-signal handler - - if State (System.Interrupt_Management.Abort_Task_Interrupt) - /= Default - then - act.sa_flags := 0; - act.sa_handler := Abort_Handler'Address; - - Result := sigemptyset (Tmp_Set'Access); - pragma Assert (Result = 0); - act.sa_mask := Tmp_Set; - - Result := - sigaction - (Signal (Interrupt_Management.Abort_Task_Interrupt), - act'Unchecked_Access, - old_act'Unchecked_Access); - pragma Assert (Result = 0); - end if; - end Initialize; - -begin - declare - Result : Interfaces.C.int; - - begin - -- Mask Environment task for all signals. The original mask of the - -- Environment task will be recovered by Interrupt_Server task - -- during the elaboration of s-interr.adb. - - System.Interrupt_Management.Operations.Set_Interrupt_Mask - (System.Interrupt_Management.Operations.All_Tasks_Mask'Access); - - -- Prepare the set of signals that should unblocked in all tasks - - Result := sigemptyset (Unblocked_Signal_Mask'Access); - pragma Assert (Result = 0); - - for J in Interrupt_Management.Interrupt_ID loop - if System.Interrupt_Management.Keep_Unmasked (J) then - Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); - pragma Assert (Result = 0); - end if; - end loop; - - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0); - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0); - end; -end System.Task_Primitives.Operations; diff --git a/gcc/ada/5itaspri.ads b/gcc/ada/5itaspri.ads deleted file mode 100644 index 078ef3e0e8a..00000000000 --- a/gcc/ada/5itaspri.ads +++ /dev/null @@ -1,96 +0,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-2001 Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the GNU/Linux (GNU/LinuxThreads) version of this package. - --- This package provides low-level support for most tasking features. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with System.OS_Interface; --- used for pthread_mutex_t --- pthread_cond_t --- pthread_t - -package System.Task_Primitives is - - type Lock is limited private; - -- Should be used for implementation of protected objects. - - type RTS_Lock is limited private; - -- Should be used inside the runtime system. - -- The difference between Lock and the RTS_Lock is that the later - -- one serves only as a semaphore so that do not check for - -- ceiling violations. - - type Task_Body_Access is access procedure; - -- Pointer to the task body's entry point (or possibly a wrapper - -- declared local to the GNARL). - - type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task - -- basis. A component of this type is guaranteed to be included - -- in the Ada_Task_Control_Block. - -private - - type Prio_Array_Type is array (System.Any_Priority) of Integer; - - type Lock is record - L : aliased System.OS_Interface.pthread_mutex_t; - Ceiling : System.Any_Priority := System.Any_Priority'First; - Saved_Priority : System.Any_Priority := System.Any_Priority'First; - end record; - - type RTS_Lock is new System.OS_Interface.pthread_mutex_t; - type Private_Data is record - Thread : aliased System.OS_Interface.pthread_t; - pragma Atomic (Thread); - -- Thread field may be updated by two different threads of control. - -- (See, Enter_Task and Create_Task in s-taprop.adb). - -- They put the same value (thr_self value). We do not want to - -- use lock on those operations and the only thing we have to - -- make sure is that they are updated in atomic fashion. - - CV : aliased System.OS_Interface.pthread_cond_t; - L : aliased RTS_Lock; - -- protection for all components is lock L - - Active_Priority : System.Any_Priority := System.Any_Priority'First; - -- Simulated active priority, - -- used only if Priority_Ceiling_Support is True. - end record; - -end System.Task_Primitives; diff --git a/gcc/ada/5ksystem.ads b/gcc/ada/5ksystem.ads deleted file mode 100644 index 3e1e3cf9895..00000000000 --- a/gcc/ada/5ksystem.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks version M68K) -- --- -- --- 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 := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - - -- Priority-related Declarations (RM D.1) - - -- 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 := True; - 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 := False; - 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; diff --git a/gcc/ada/5kvxwork.ads b/gcc/ada/5kvxwork.ads deleted file mode 100644 index a0f10be72a0..00000000000 --- a/gcc/ada/5kvxwork.ads +++ /dev/null @@ -1,76 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . V X W O R K S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the M68K VxWorks version of this package. - -with Interfaces.C; - -package System.VxWorks is - pragma Preelaborate (System.VxWorks); - - package IC renames Interfaces.C; - - -- Floating point context record. 68K version - - FP_NUM_DREGS : constant := 8; - FP_STATE_FRAME_SIZE : constant := 216; - - type DOUBLEX is array (1 .. 12) of Interfaces.Unsigned_8; - pragma Pack (DOUBLEX); - for DOUBLEX'Size use 12 * 8; - - type DOUBLEX_Array is array (1 .. FP_NUM_DREGS) of DOUBLEX; - pragma Pack (DOUBLEX_Array); - for DOUBLEX_Array'Size use FP_NUM_DREGS * 12 * 8; - - type FPREG_SET is record - fpcr : IC.int; - fpsr : IC.int; - fpiar : IC.int; - fpx : DOUBLEX_Array; - end record; - - type Fp_State_Frame_Array is array (1 .. FP_STATE_FRAME_SIZE) of IC.char; - pragma Pack (Fp_State_Frame_Array); - for Fp_State_Frame_Array'Size use 8 * FP_STATE_FRAME_SIZE; - - type FP_CONTEXT is record - fpRegSet : FPREG_SET; - stateFrame : Fp_State_Frame_Array; - end record; - pragma Convention (C, FP_CONTEXT); - - Num_HW_Interrupts : constant := 256; - -- Number of entries in the hardware interrupt vector table - -end System.VxWorks; diff --git a/gcc/ada/5lml-tgt.adb b/gcc/ada/5lml-tgt.adb deleted file mode 100644 index 00ab3928b79..00000000000 --- a/gcc/ada/5lml-tgt.adb +++ /dev/null @@ -1,365 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T -- --- (GNU/Linux Version) -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-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. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a set of target dependent routines to build --- static, dynamic and shared libraries. - --- This is the GNU/Linux version of the body. - -with MLib.Fil; -with MLib.Utl; -with Namet; use Namet; -with Opt; -with Output; use Output; -with Prj.Com; -with System; - -package body MLib.Tgt is - - use GNAT; - use MLib; - - No_Arguments : aliased Argument_List := (1 .. 0 => null); - Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; - - Wl_Init_String : aliased String := "-Wl,-init"; - Wl_Init : constant String_Access := Wl_Init_String'Access; - Wl_Fini_String : aliased String := "-Wl,-fini"; - Wl_Fini : constant String_Access := Wl_Fini_String'Access; - - Init_Fini_List : constant Argument_List_Access := - new Argument_List'(1 => Wl_Init, - 2 => null, - 3 => Wl_Fini, - 4 => null); - -- Used to put switches for automatic elaboration/finalization - - --------------------- - -- Archive_Builder -- - --------------------- - - function Archive_Builder return String is - begin - return "ar"; - end Archive_Builder; - - ----------------------------- - -- Archive_Builder_Options -- - ----------------------------- - - function Archive_Builder_Options return String_List_Access is - begin - return new String_List'(1 => new String'("cr")); - end Archive_Builder_Options; - - ----------------- - -- Archive_Ext -- - ----------------- - - function Archive_Ext return String is - begin - return "a"; - end Archive_Ext; - - --------------------- - -- Archive_Indexer -- - --------------------- - - function Archive_Indexer return String is - begin - return "ranlib"; - end Archive_Indexer; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Foreign : Argument_List; - Afiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Address : String := ""; - Lib_Version : String := ""; - Relocatable : Boolean := False; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Foreign); - pragma Unreferenced (Afiles); - pragma Unreferenced (Interfaces); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Lib_Address); - pragma Unreferenced (Relocatable); - - Lib_File : constant String := - Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Filename, DLL_Ext); - - Version_Arg : String_Access; - Symbolic_Link_Needed : Boolean := False; - - Init_Fini : Argument_List_Access := Empty_Argument_List; - - begin - if Opt.Verbose_Mode then - Write_Str ("building relocatable shared library "); - Write_Line (Lib_File); - end if; - - -- If specified, add automatic elaboration/finalization - if Auto_Init then - Init_Fini := Init_Fini_List; - Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init"); - Init_Fini (4) := new String'("-Wl," & Lib_Filename & "final"); - end if; - - if Lib_Version = "" then - Utl.Gcc - (Output_File => Lib_File, - Objects => Ofiles, - Options => Options & Init_Fini.all, - Driver_Name => Driver_Name); - - else - Version_Arg := new String'("-Wl,-soname," & Lib_Version); - - if Is_Absolute_Path (Lib_Version) then - Utl.Gcc - (Output_File => Lib_Version, - Objects => Ofiles, - Options => Options & Version_Arg & Init_Fini.all, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := Lib_Version /= Lib_File; - - else - Utl.Gcc - (Output_File => Lib_Dir & Directory_Separator & Lib_Version, - Objects => Ofiles, - Options => Options & Version_Arg & Init_Fini.all, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := - Lib_Dir & Directory_Separator & Lib_Version /= Lib_File; - end if; - - if Symbolic_Link_Needed then - declare - Success : Boolean; - Oldpath : String (1 .. Lib_Version'Length + 1); - Newpath : String (1 .. Lib_File'Length + 1); - - Result : Integer; - pragma Unreferenced (Result); - - function Symlink - (Oldpath : System.Address; - Newpath : System.Address) return Integer; - pragma Import (C, Symlink, "__gnat_symlink"); - - begin - Oldpath (1 .. Lib_Version'Length) := Lib_Version; - Oldpath (Oldpath'Last) := ASCII.NUL; - Newpath (1 .. Lib_File'Length) := Lib_File; - Newpath (Newpath'Last) := ASCII.NUL; - - Delete_File (Lib_File, Success); - - Result := Symlink (Oldpath'Address, Newpath'Address); - end; - end if; - end if; - end Build_Dynamic_Library; - - ------------------------- - -- Default_DLL_Address -- - ------------------------- - - function Default_DLL_Address return String is - begin - return ""; - end Default_DLL_Address; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return "so"; - end DLL_Ext; - - -------------------- - -- Dynamic_Option -- - -------------------- - - function Dynamic_Option return String is - begin - return "-shared"; - end Dynamic_Option; - - ------------------- - -- Is_Object_Ext -- - ------------------- - - function Is_Object_Ext (Ext : String) return Boolean is - begin - return Ext = ".o"; - end Is_Object_Ext; - - -------------- - -- Is_C_Ext -- - -------------- - - function Is_C_Ext (Ext : String) return Boolean is - begin - return Ext = ".c"; - end Is_C_Ext; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".a" or else Ext = ".so"; - end Is_Archive_Ext; - - ------------- - -- Libgnat -- - ------------- - - function Libgnat return String is - begin - return "libgnat.a"; - end Libgnat; - - ------------------------ - -- Library_Exists_For -- - ------------------------ - - function Library_Exists_For (Project : Project_Id) return Boolean is - begin - if not Projects.Table (Project).Library then - Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & - "for non library project"); - return False; - - else - declare - Lib_Dir : constant String := - Get_Name_String (Projects.Table (Project).Library_Dir); - Lib_Name : constant String := - Get_Name_String (Projects.Table (Project).Library_Name); - - begin - if Projects.Table (Project).Library_Kind = Static then - return Is_Regular_File - (Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - return Is_Regular_File - (Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - end; - end if; - end Library_Exists_For; - - --------------------------- - -- Library_File_Name_For -- - --------------------------- - - function Library_File_Name_For (Project : Project_Id) return Name_Id is - begin - if not Projects.Table (Project).Library then - Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & - "for non library project"); - return No_Name; - - else - declare - Lib_Name : constant String := - Get_Name_String (Projects.Table (Project).Library_Name); - - begin - Name_Len := 3; - Name_Buffer (1 .. Name_Len) := "lib"; - - if Projects.Table (Project).Library_Kind = Static then - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - - return Name_Find; - end; - end if; - end Library_File_Name_For; - - ---------------- - -- Object_Ext -- - ---------------- - - function Object_Ext return String is - begin - return "o"; - end Object_Ext; - - ---------------- - -- PIC_Option -- - ---------------- - - function PIC_Option return String is - begin - return "-fPIC"; - end PIC_Option; - - ----------------------------------------------- - -- Standalone_Library_Auto_Init_Is_Supported -- - ----------------------------------------------- - - function Standalone_Library_Auto_Init_Is_Supported return Boolean is - begin - return True; - end Standalone_Library_Auto_Init_Is_Supported; - - --------------------------- - -- Support_For_Libraries -- - --------------------------- - - function Support_For_Libraries return Library_Support is - begin - return Full; - end Support_For_Libraries; - -end MLib.Tgt; diff --git a/gcc/ada/5losinte.ads b/gcc/ada/5losinte.ads deleted file mode 100644 index df7a4322bf5..00000000000 --- a/gcc/ada/5losinte.ads +++ /dev/null @@ -1,599 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 a GNU/Linux (FSU THREADS) version of this package. - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-lgthreads"); - pragma Linker_Options ("-lmalloc"); - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 11; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIMEDOUT : constant := 110; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 31; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 7; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGUSR1 : constant := 10; -- user defined signal 1 - SIGUSR2 : constant := 12; -- user defined signal 2 - SIGCLD : constant := 17; -- alias for SIGCHLD - SIGCHLD : constant := 17; -- child status change - SIGPWR : constant := 30; -- power-fail restart - SIGWINCH : constant := 28; -- window size change - SIGURG : constant := 23; -- urgent condition on IO channel - SIGPOLL : constant := 29; -- pollable event occurred - SIGIO : constant := 29; -- I/O now possible (4.2 BSD) - SIGLOST : constant := 29; -- File lock lost - SIGSTOP : constant := 19; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 20; -- user stop requested from tty - SIGCONT : constant := 18; -- stopped process has been continued - SIGTTIN : constant := 21; -- background tty read attempted - SIGTTOU : constant := 22; -- background tty write attempted - SIGVTALRM : constant := 26; -- virtual timer expired - SIGPROF : constant := 27; -- profiling timer expired - SIGXCPU : constant := 24; -- CPU time limit exceeded - SIGXFSZ : constant := 25; -- filesize limit exceeded - SIGUNUSED : constant := 31; -- unused signal (GNU/Linux) - SIGSTKFLT : constant := 16; -- coprocessor stack fault (GNU/Linux) - - SIGADAABORT : constant := SIGABRT; - -- Change this if you want to use another signal for task abort. - -- SIGTERM might be a good one. - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := - (SIGTRAP, SIGBUS, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); - - Reserved : constant Signal_Set := - (SIGKILL, SIGSTOP, SIGALRM, SIGVTALRM, SIGUNUSED); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : unsigned_long; - sa_restorer : System.Address; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - type Machine_State is record - eip : unsigned_long; - ebx : unsigned_long; - esp : unsigned_long; - ebp : unsigned_long; - esi : unsigned_long; - edi : unsigned_long; - end record; - type Machine_State_Ptr is access all Machine_State; - - SA_SIGINFO : constant := 16#04#; - - SIG_BLOCK : constant := 0; - SIG_UNBLOCK : constant := 1; - SIG_SETMASK : constant := 2; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - Time_Slice_Supported : constant Boolean := False; - -- Indicates wether time slicing is supported (i.e FSU threads have been - -- compiled with DEF_RR) - - type timespec is private; - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; - pragma Import (C, clock_gettime, "clock_gettime"); - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timeval is private; - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 0; - SCHED_RR : constant := 1; - SCHED_OTHER : constant := 2; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - --------- - -- LWP -- - --------- - - function lwp_self return System.Address; - -- lwp_self does not exist on this thread library, revert to pthread_self - -- which is the closest approximation (with getpid). This function is - -- needed to share 7staprop.adb across POSIX-like targets. - pragma Import (C, lwp_self, "pthread_self"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 1; - - ----------- - -- Stack -- - ----------- - - Stack_Base_Available : constant Boolean := False; - -- Indicates wether the stack base is available on this target. - -- This allows us to share s-osinte.adb between all the FSU run time. - -- Note that this value can only be true if pthread_t has a complete - -- definition that corresponds exactly to the C header files. - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- returns the stack base of the specified thread. - -- Only call this function when Stack_Base_Available is True. - - function Get_Page_Size return size_t; - function Get_Page_Size return Address; - pragma Import (C, Get_Page_Size, "getpagesize"); - -- returns the size of a page, or 0 if this is not relevant on this - -- target - - PROT_NONE : constant := 0; - PROT_READ : constant := 1; - PROT_WRITE : constant := 2; - PROT_EXEC : constant := 4; - PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; - - PROT_ON : constant := PROT_NONE; - PROT_OFF : constant := PROT_ALL; - - function mprotect (addr : Address; len : size_t; prot : int) return int; - pragma Import (C, mprotect); - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - procedure pthread_init; - -- FSU_THREADS requires pthread_init, which is nonstandard - -- and this should be invoked during the elaboration of s-taprop.adb - pragma Import (C, pthread_init, "pthread_init"); - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) return int; - pragma Inline (sigwait); - -- FSU_THREADS has a nonstandard sigwait - - function pthread_kill - (thread : pthread_t; - sig : Signal) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - -- FSU threads does not have pthread_sigmask. Instead, it uses - -- sigprocmask to do the signal handling when the thread library is - -- sucked in. - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask, "sigprocmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy - (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock - (mutex : access pthread_mutex_t) return int; - pragma Inline (pthread_mutex_lock); - -- FSU_THREADS has nonstandard pthread_mutex_lock - - function pthread_mutex_unlock - (mutex : access pthread_mutex_t) return int; - pragma Inline (pthread_mutex_unlock); - -- FSU_THREADS has nonstandard pthread_mutex_lock - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "pthread_cond_init"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Inline (pthread_cond_wait); - -- FSU_THREADS has a nonstandard pthread_cond_wait - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - pragma Inline (pthread_cond_timedwait); - -- FSU_THREADS has a nonstandard pthread_cond_timedwait - - Relative_Timed_Wait : constant Boolean := False; - -- pthread_cond_timedwait requires an absolute delay time - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - PTHREAD_PRIO_NONE : constant := 0; - PTHREAD_PRIO_PROTECT : constant := 2; - PTHREAD_PRIO_INHERIT : constant := 1; - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol); - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int; - pragma Import - (C, pthread_mutexattr_setprioceiling, - "pthread_mutexattr_setprio_ceiling"); - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Inline (pthread_setschedparam); - -- FSU_THREADS does not have pthread_setschedparam - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import (C, pthread_attr_setinheritsched); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; - policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched"); - - function sched_yield return int; - pragma Inline (sched_yield); - -- FSU_THREADS does not have sched_yield; - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "pthread_attr_init"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Inline (pthread_attr_setdetachstate); - -- FSU_THREADS has a nonstandard pthread_attr_setdetachstate - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "pthread_create"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "pthread_setspecific"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Inline (pthread_getspecific); - -- FSU_THREADS has a nonstandard pthread_getspecific - - type destructor_pointer is access procedure (arg : System.Address); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "pthread_key_create"); - -private - - type sigset_t is array (0 .. 31) of unsigned_long; - pragma Convention (C, sigset_t); - -- This is for GNU libc version 2 but should be backward compatible with - -- other libc where sigset_t is smaller. - - type pid_t is new int; - - type time_t is new long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 0; - - type struct_timeval is record - tv_sec : long; - tv_usec : long; - end record; - pragma Convention (C, struct_timeval); - - type pthread_attr_t is record - flags : int; - stacksize : int; - contentionscope : int; - inheritsched : int; - detachstate : int; - sched : int; - prio : int; - starttime : timespec; - deadline : timespec; - period : timespec; - end record; - pragma Convention (C_Pass_By_Copy, pthread_attr_t); - - type pthread_condattr_t is record - flags : int; - end record; - pragma Convention (C, pthread_condattr_t); - - type pthread_mutexattr_t is record - flags : int; - prio_ceiling : int; - protocol : int; - end record; - pragma Convention (C, pthread_mutexattr_t); - - type sigjmp_buf is array (Integer range 0 .. 38) of int; - - type pthread_t_struct is record - context : sigjmp_buf; - pbody : sigjmp_buf; - errno : int; - ret : int; - stack_base : System.Address; - end record; - pragma Convention (C, pthread_t_struct); - - type pthread_t is access all pthread_t_struct; - - type queue_t is record - head : System.Address; - tail : System.Address; - end record; - pragma Convention (C, queue_t); - - type pthread_mutex_t is record - queue : queue_t; - lock : plain_char; - owner : System.Address; - flags : int; - prio_ceiling : int; - protocol : int; - prev_max_ceiling_prio : int; - end record; - pragma Convention (C, pthread_mutex_t); - - type pthread_cond_t is record - queue : queue_t; - flags : int; - waiters : int; - mutex : System.Address; - end record; - pragma Convention (C, pthread_cond_t); - - type pthread_key_t is new int; - -end System.OS_Interface; diff --git a/gcc/ada/5lparame.adb b/gcc/ada/5lparame.adb deleted file mode 100644 index 9b17c158733..00000000000 --- a/gcc/ada/5lparame.adb +++ /dev/null @@ -1,73 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2003 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 Linux (native) specific version - -package body System.Parameters is - - ------------------------- - -- Adjust_Storage_Size -- - ------------------------- - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type is - begin - if Size = Unspecified_Size then - return Default_Stack_Size; - - elsif Size < Minimum_Stack_Size then - return Minimum_Stack_Size; - - else - return Size; - end if; - end Adjust_Storage_Size; - - ------------------------ - -- Default_Stack_Size -- - ------------------------ - - function Default_Stack_Size return Size_Type is - begin - return 2 * 1024 * 1024; - end Default_Stack_Size; - - ------------------------ - -- Minimum_Stack_Size -- - ------------------------ - - function Minimum_Stack_Size return Size_Type is - begin - return 8 * 1024; - end Minimum_Stack_Size; - -end System.Parameters; diff --git a/gcc/ada/5lsystem.ads b/gcc/ada/5lsystem.ads deleted file mode 100644 index 8bcf7808221..00000000000 --- a/gcc/ada/5lsystem.ads +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (GNU-Linux/x86 Version) -- --- -- --- 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 := 0.000_001; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := False; - ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; - 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 := True; - -end System; diff --git a/gcc/ada/5msystem.ads b/gcc/ada/5msystem.ads deleted file mode 100644 index 19c96d0d6ea..00000000000 --- a/gcc/ada/5msystem.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks Version Mips) -- --- -- --- 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 := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - - -- Priority-related Declarations (RM D.1) - - -- 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; diff --git a/gcc/ada/5mvxwork.ads b/gcc/ada/5mvxwork.ads deleted file mode 100644 index 2e31d728aed..00000000000 --- a/gcc/ada/5mvxwork.ads +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . V X W O R K S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the MIPS VxWorks version of this package. - -with Interfaces.C; - -package System.VxWorks is - pragma Preelaborate (System.VxWorks); - - package IC renames Interfaces.C; - - -- Floating point context record. MIPS version - - FP_NUM_DREGS : constant := 16; - type Fpx_Array is array (1 .. FP_NUM_DREGS) of IC.double; - - type FP_CONTEXT is record - fpx : Fpx_Array; - fpcsr : IC.int; - end record; - pragma Convention (C, FP_CONTEXT); - - Num_HW_Interrupts : constant := 256; - -- Number of entries in hardware interrupt vector table. - -end System.VxWorks; diff --git a/gcc/ada/5ninmaop.adb b/gcc/ada/5ninmaop.adb deleted file mode 100644 index f99a104f671..00000000000 --- a/gcc/ada/5ninmaop.adb +++ /dev/null @@ -1,194 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a NO tasking version of this package. - -package body System.Interrupt_Management.Operations is - - -- Turn off warnings since many unused formals - - pragma Warnings (Off); - - ---------------------------- - -- Thread_Block_Interrupt -- - ---------------------------- - - procedure Thread_Block_Interrupt - (Interrupt : Interrupt_ID) - is - begin - null; - end Thread_Block_Interrupt; - - ------------------------------ - -- Thread_Unblock_Interrupt -- - ------------------------------ - - procedure Thread_Unblock_Interrupt - (Interrupt : Interrupt_ID) - is - begin - null; - end Thread_Unblock_Interrupt; - - ------------------------ - -- Set_Interrupt_Mask -- - ------------------------ - - procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is - begin - null; - end Set_Interrupt_Mask; - - procedure Set_Interrupt_Mask - (Mask : access Interrupt_Mask; - OMask : access Interrupt_Mask) is - begin - null; - end Set_Interrupt_Mask; - - ------------------------ - -- Get_Interrupt_Mask -- - ------------------------ - - procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is - begin - null; - end Get_Interrupt_Mask; - - -------------------- - -- Interrupt_Wait -- - -------------------- - - function Interrupt_Wait - (Mask : access Interrupt_Mask) - return Interrupt_ID - is - begin - return 0; - end Interrupt_Wait; - - ---------------------------- - -- Install_Default_Action -- - ---------------------------- - - procedure Install_Default_Action (Interrupt : Interrupt_ID) is - begin - null; - end Install_Default_Action; - - --------------------------- - -- Install_Ignore_Action -- - --------------------------- - - procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is - begin - null; - end Install_Ignore_Action; - - ------------------------- - -- Fill_Interrupt_Mask -- - ------------------------- - - procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is - begin - null; - end Fill_Interrupt_Mask; - - -------------------------- - -- Empty_Interrupt_Mask -- - -------------------------- - - procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is - begin - null; - end Empty_Interrupt_Mask; - - ----------------------- - -- Add_To_Sigal_Mask -- - ----------------------- - - procedure Add_To_Interrupt_Mask - (Mask : access Interrupt_Mask; - Interrupt : Interrupt_ID) - is - begin - null; - end Add_To_Interrupt_Mask; - - -------------------------------- - -- Delete_From_Interrupt_Mask -- - -------------------------------- - - procedure Delete_From_Interrupt_Mask - (Mask : access Interrupt_Mask; - Interrupt : Interrupt_ID) - is - begin - null; - end Delete_From_Interrupt_Mask; - - --------------- - -- Is_Member -- - --------------- - - function Is_Member - (Mask : access Interrupt_Mask; - Interrupt : Interrupt_ID) return Boolean - is - begin - return False; - end Is_Member; - - ------------------------- - -- Copy_Interrupt_Mask -- - ------------------------- - - procedure Copy_Interrupt_Mask - (X : out Interrupt_Mask; - Y : Interrupt_Mask) - is - begin - X := Y; - end Copy_Interrupt_Mask; - - ------------------------- - -- Interrupt_Self_Process -- - ------------------------- - - procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is - begin - null; - end Interrupt_Self_Process; - -end System.Interrupt_Management.Operations; diff --git a/gcc/ada/5nintman.adb b/gcc/ada/5nintman.adb deleted file mode 100644 index 9ef33ab5a15..00000000000 --- a/gcc/ada/5nintman.adb +++ /dev/null @@ -1,49 +0,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) 1997-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 NO tasking version of this package. - -package body System.Interrupt_Management is - - --------------------------- - -- Initialize_Interrupts -- - --------------------------- - - -- Nothing needs to be done on this platform. - - procedure Initialize_Interrupts is - begin - null; - end Initialize_Interrupts; - -end System.Interrupt_Management; diff --git a/gcc/ada/5nosinte.ads b/gcc/ada/5nosinte.ads deleted file mode 100644 index f33370dd43d..00000000000 --- a/gcc/ada/5nosinte.ads +++ /dev/null @@ -1,53 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 no tasking version - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -package System.OS_Interface is - pragma Preelaborate; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 2; - type Signal is new Integer range 0 .. Max_Interrupt; - - type sigset_t is new Integer; - type Thread_Id is new Integer; - -end System.OS_Interface; diff --git a/gcc/ada/5nsystem.ads b/gcc/ada/5nsystem.ads deleted file mode 100644 index 37a495d8870..00000000000 --- a/gcc/ada/5nsystem.ads +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (GNU-Linux/x86-64 Version) -- --- -- --- 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 := 0.000_001; - - -- 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) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -private - - 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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := False; - ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; - 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 := True; - -end System; diff --git a/gcc/ada/5ntaprop.adb b/gcc/ada/5ntaprop.adb deleted file mode 100644 index 365b0d911d3..00000000000 --- a/gcc/ada/5ntaprop.adb +++ /dev/null @@ -1,438 +0,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 . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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 no tasking version of this package - --- This package contains all the GNULL primitives that interface directly --- with the underlying OS. - -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.Tasking; --- used for Ada_Task_Control_Block --- Task_ID - -with System.Error_Reporting; --- used for Shutdown - -package body System.Task_Primitives.Operations is - - use System.Tasking; - use System.Parameters; - - pragma Warnings (Off); - -- Turn off warnings since so many unreferenced parameters - - ----------------- - -- Stack_Guard -- - ----------------- - - procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is - begin - null; - end Stack_Guard; - - -------------------- - -- Get_Thread_Id -- - -------------------- - - function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is - begin - return OSI.Thread_Id (T.Common.LL.Thread); - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_ID is - begin - return Null_Task; - end Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : access Lock) - is - begin - null; - end Initialize_Lock; - - procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is - begin - null; - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : access Lock) is - begin - null; - end Finalize_Lock; - - procedure Finalize_Lock (L : access RTS_Lock) is - begin - null; - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - begin - Ceiling_Violation := False; - end Write_Lock; - - procedure Write_Lock - (L : access RTS_Lock; - Global_Lock : Boolean := False) - is - begin - null; - end Write_Lock; - - procedure Write_Lock (T : Task_ID) is - begin - null; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - begin - Ceiling_Violation := False; - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : access Lock) is - begin - null; - end Unlock; - - procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is - begin - null; - end Unlock; - - procedure Unlock (T : Task_ID) is - begin - null; - end Unlock; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is - begin - null; - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - procedure Timed_Sleep - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : System.Tasking.Task_States; - Timedout : out Boolean; - Yielded : out Boolean) is - begin - Timedout := False; - Yielded := False; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes) is - begin - null; - end Timed_Delay; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration is - begin - return 0.0; - end Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - begin - return 10#1.0#E-6; - end RT_Resolution; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is - begin - null; - end Wakeup; - - ------------------ - -- Set_Priority -- - ------------------ - - procedure Set_Priority - (T : Task_ID; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) is - begin - null; - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_ID) return System.Any_Priority is - begin - return 0; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (Self_ID : Task_ID) is - begin - null; - end Enter_Task; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean is - begin - return False; - end Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_ID is - begin - return null; - end Register_Foreign_Thread; - - ---------------------- - -- Initialize_TCB -- - ---------------------- - - procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is - begin - Succeeded := False; - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_ID; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) is - begin - Succeeded := False; - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_ID) is - begin - null; - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - procedure Exit_Task is - begin - null; - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_ID) is - begin - null; - end Abort_Task; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - begin - null; - end Yield; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy versions. The only currently working versions is for solaris - -- (native). - - function Check_Exit (Self_ID : ST.Task_ID) return Boolean is - begin - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is - begin - return True; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_ID is - begin - return null; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - null; - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - null; - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_ID; - Thread_Self : OSI.Thread_Id) - return Boolean - is - begin - return False; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_ID; - Thread_Self : OSI.Thread_Id) - return Boolean - is - begin - return False; - end Resume_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_ID) is - begin - null; - end Initialize; - - No_Tasking : Boolean; - -begin - -- Can't raise an exception because target independent packages try to - -- do an Abort_Defer, which gets a memory fault. - - No_Tasking := - System.Error_Reporting.Shutdown - ("Tasking not implemented on this configuration"); -end System.Task_Primitives.Operations; diff --git a/gcc/ada/5ntaspri.ads b/gcc/ada/5ntaspri.ads deleted file mode 100644 index 6e6025c589d..00000000000 --- a/gcc/ada/5ntaspri.ads +++ /dev/null @@ -1,55 +0,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-2000 Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a no tasking 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. - -package System.Task_Primitives is - pragma Preelaborate; - - type Lock is new Integer; - - type RTS_Lock is new Integer; - - type Task_Body_Access is access procedure; - - type Private_Data is record - Thread : aliased Integer; - CV : aliased Integer; - L : aliased RTS_Lock; - end record; - -end System.Task_Primitives; diff --git a/gcc/ada/5ointerr.adb b/gcc/ada/5ointerr.adb deleted file mode 100644 index 7dbe33f26a7..00000000000 --- a/gcc/ada/5ointerr.adb +++ /dev/null @@ -1,307 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . I N T E R R U P T S -- --- -- --- 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 an OS/2 version of this package. - --- This version is a stub, for systems that --- do not support interrupts (or signals). - -with Ada.Exceptions; - -package body System.Interrupts is - - pragma Warnings (Off); -- kill warnings on unreferenced formals - - use System.Tasking; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Unimplemented; - -- This procedure raises a Program_Error with an appropriate message - -- indicating that an unimplemented feature has been used. - - -------------------- - -- Attach_Handler -- - -------------------- - - procedure Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean := False) - is - begin - Unimplemented; - end Attach_Handler; - - ----------------------------- - -- Bind_Interrupt_To_Entry -- - ----------------------------- - - procedure Bind_Interrupt_To_Entry - (T : Task_ID; - E : Task_Entry_Index; - Int_Ref : System.Address) - is - begin - Unimplemented; - end Bind_Interrupt_To_Entry; - - --------------------- - -- Block_Interrupt -- - --------------------- - - procedure Block_Interrupt (Interrupt : Interrupt_ID) is - begin - Unimplemented; - end Block_Interrupt; - - --------------------- - -- Current_Handler -- - --------------------- - - function Current_Handler - (Interrupt : Interrupt_ID) - return Parameterless_Handler - is - begin - Unimplemented; - return null; - end Current_Handler; - - -------------------- - -- Detach_Handler -- - -------------------- - - procedure Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean := False) - is - begin - Unimplemented; - end Detach_Handler; - - ------------------------------ - -- Detach_Interrupt_Entries -- - ------------------------------ - - procedure Detach_Interrupt_Entries (T : Task_ID) is - begin - Unimplemented; - end Detach_Interrupt_Entries; - - ---------------------- - -- Exchange_Handler -- - ---------------------- - - procedure Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean := False) - is - begin - Old_Handler := null; - Unimplemented; - end Exchange_Handler; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Static_Interrupt_Protection) is - begin - Unimplemented; - end Finalize; - - ------------------------------------- - -- Has_Interrupt_Or_Attach_Handler -- - ------------------------------------- - - function Has_Interrupt_Or_Attach_Handler - (Object : access Dynamic_Interrupt_Protection) - return Boolean - is - pragma Warnings (Off, Object); - - begin - Unimplemented; - return True; - end Has_Interrupt_Or_Attach_Handler; - - function Has_Interrupt_Or_Attach_Handler - (Object : access Static_Interrupt_Protection) - return Boolean - is - pragma Warnings (Off, Object); - - begin - Unimplemented; - return True; - end Has_Interrupt_Or_Attach_Handler; - - ---------------------- - -- Ignore_Interrupt -- - ---------------------- - - procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is - begin - Unimplemented; - end Ignore_Interrupt; - - ---------------------- - -- Install_Handlers -- - ---------------------- - - procedure Install_Handlers - (Object : access Static_Interrupt_Protection; - New_Handlers : New_Handler_Array) - is - begin - Unimplemented; - end Install_Handlers; - - ---------------- - -- Is_Blocked -- - ---------------- - - function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is - begin - Unimplemented; - return True; - end Is_Blocked; - - ----------------------- - -- Is_Entry_Attached -- - ----------------------- - - function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is - begin - Unimplemented; - return True; - end Is_Entry_Attached; - - ------------------------- - -- Is_Handler_Attached -- - ------------------------- - - function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is - begin - Unimplemented; - return True; - end Is_Handler_Attached; - - ---------------- - -- Is_Ignored -- - ---------------- - - function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is - begin - Unimplemented; - return True; - end Is_Ignored; - - ----------------- - -- Is_Reserved -- - ----------------- - - function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is - begin - Unimplemented; - return True; - end Is_Reserved; - - --------------- - -- Reference -- - --------------- - - function Reference (Interrupt : Interrupt_ID) return System.Address is - begin - Unimplemented; - return Interrupt'Address; - end Reference; - - -------------------------------- - -- Register_Interrupt_Handler -- - -------------------------------- - - procedure Register_Interrupt_Handler - (Handler_Addr : System.Address) - is - begin - Unimplemented; - end Register_Interrupt_Handler; - - ----------------------- - -- Unblock_Interrupt -- - ----------------------- - - procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is - begin - Unimplemented; - end Unblock_Interrupt; - - ------------------ - -- Unblocked_By -- - ------------------ - - function Unblocked_By (Interrupt : Interrupt_ID) - return System.Tasking.Task_ID is - begin - Unimplemented; - return null; - end Unblocked_By; - - ------------------------ - -- Unignore_Interrupt -- - ------------------------ - - procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is - begin - Unimplemented; - end Unignore_Interrupt; - - ------------------- - -- Unimplemented; -- - ------------------- - - procedure Unimplemented is - begin - Ada.Exceptions.Raise_Exception - (Program_Error'Identity, "interrupts/signals not implemented"); - raise Program_Error; - end Unimplemented; - -end System.Interrupts; diff --git a/gcc/ada/5omastop.adb b/gcc/ada/5omastop.adb deleted file mode 100644 index 96ac1138d7e..00000000000 --- a/gcc/ada/5omastop.adb +++ /dev/null @@ -1,594 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- SYSTEM.MACHINE_STATE_OPERATIONS -- --- -- --- B o d y -- --- (Version for x86) -- --- -- --- Copyright (C) 1999-2004 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. -- --- -- ------------------------------------------------------------------------------- - --- Note: it is very important that this unit not generate any exception --- tables of any kind. Otherwise we get a nasty rtsfind recursion problem. --- This means no subprograms, including implicitly generated ones. - -with Unchecked_Conversion; -with System.Storage_Elements; -with System.Machine_Code; use System.Machine_Code; -with System.Memory; - -package body System.Machine_State_Operations is - - function "+" (Left, Right : Address) return Address; - pragma Import (Intrinsic, "+"); - -- Provide addition operation on type Address (this may not be directly - -- available if type System.Address is non-private and the operations on - -- the type are made abstract to hide them from public users of System). - - use System.Exceptions; - - type Uns8 is mod 2 ** 8; - type Uns32 is mod 2 ** 32; - - type Bits5 is mod 2 ** 5; - type Bits6 is mod 2 ** 6; - - function To_Address is new Unchecked_Conversion (Uns32, Address); - - type Uns32_Ptr is access all Uns32; - function To_Uns32_Ptr is new Unchecked_Conversion (Uns32, Uns32_Ptr); - - -- Note: the type Uns32 has an alignment of 4. However, in some cases - -- values of type Uns32_Ptr will not be aligned (notably in the case - -- where we get the immediate field from an instruction). However this - -- does not matter in practice, since the x86 does not require that - -- operands be aligned. - - ---------------------- - -- General Approach -- - ---------------------- - - -- For the x86 version of this unit, the Subprogram_Info_Type values - -- are simply the starting code address for the subprogram. Popping - -- of stack frames works by analyzing the code in the prolog, and - -- deriving from this analysis the necessary information for restoring - -- the registers, including the return point. - - --------------------------- - -- Description of Prolog -- - --------------------------- - - -- If a frame pointer is present, the prolog looks like - - -- pushl %ebp - -- movl %esp,%ebp - -- subl $nnn,%esp omitted if nnn = 0 - -- pushl %edi omitted if edi not used - -- pushl %esi omitted if esi not used - -- pushl %ebx omitted if ebx not used - - -- If a frame pointer is not present, the prolog looks like - - -- subl $nnn,%esp omitted if nnn = 0 - -- pushl %ebp omitted if ebp not used - -- pushl %edi omitted if edi not used - -- pushl %esi omitted if esi not used - -- pushl %ebx omitted if ebx not used - - -- Note: any or all of the save over call registers may be used and - -- if so, will be saved using pushl as shown above. The order of the - -- pushl instructions will be as shown above for gcc generated code, - -- but the code in this unit does not assume this. - - ------------------------- - -- Description of Call -- - ------------------------- - - -- A call looks like: - - -- pushl ... push parameters - -- pushl ... - -- call ... perform the call - -- addl $nnn,%esp omitted if no parameters - - -- Note that we are not absolutely guaranteed that the call is always - -- followed by an addl operation that readjusts %esp for this particular - -- call. There are two reasons for this: - - -- 1) The addl can be delayed and combined in the case where more than - -- one call appears in sequence. This can be suppressed by using the - -- switch -fno-defer-pop and for Ada code, we automatically use - -- this switch, but we could still be dealing with C code that was - -- compiled without using this switch. - - -- 2) Scheduling may result in moving the addl instruction away from - -- the call. It is not clear if this actually can happen at the - -- current time, but it is certainly conceptually possible. - - -- The addl after the call is important, since we need to be able to - -- restore the proper %esp value when we pop the stack. However, we do - -- not try to compensate for either of the above effects. As noted above, - -- case 1 does not occur for Ada code, and it does not appear in practice - -- that case 2 occurs with any significant frequency (we have never seen - -- an example so far for gcc generated code). - - -- Furthermore, it is only in the case of -fomit-frame-pointer that we - -- really get into trouble from not properly restoring %esp. If we have - -- a frame pointer, then the worst that happens is that %esp is slightly - -- more depressed than it should be. This could waste a bit of space on - -- the stack, and even in some cases cause a storage leak on the stack, - -- but it will not affect the functional correctness of the processing. - - ---------------------------------------- - -- Definitions of Instruction Formats -- - ---------------------------------------- - - type Rcode is (eax, ecx, edx, ebx, esp, ebp, esi, edi); - pragma Warnings (Off, Rcode); - -- Code indicating which register is referenced in an instruction - - -- The following define the format of a pushl instruction - - Op_pushl : constant Bits5 := 2#01010#; - - type Ins_pushl is record - Op : Bits5 := Op_pushl; - Reg : Rcode; - end record; - - for Ins_pushl use record - Op at 0 range 3 .. 7; - Reg at 0 range 0 .. 2; - end record; - - Ins_pushl_ebp : constant Ins_pushl := (Op_pushl, Reg => ebp); - - type Ins_pushl_Ptr is access all Ins_pushl; - - -- For the movl %esp,%ebp instruction, we only need to know the length - -- because we simply skip past it when we analyze the prolog. - - Ins_movl_length : constant := 2; - - -- The following define the format of addl/subl esp instructions - - Op_Immed : constant Bits6 := 2#100000#; - - Op2_addl_Immed : constant Bits5 := 2#11100#; - pragma Unreferenced (Op2_addl_Immed); - - Op2_subl_Immed : constant Bits5 := 2#11101#; - - type Word_Byte is (Word, Byte); - pragma Unreferenced (Byte); - - type Ins_addl_subl_byte is record - Op : Bits6; -- Set to Op_Immed - w : Word_Byte; -- Word/Byte flag (set to 1 = byte) - s : Boolean; -- Sign extension bit (1 = extend) - Op2 : Bits5; -- Secondary opcode - Reg : Rcode; -- Register - Imm8 : Uns8; -- Immediate operand - end record; - - for Ins_addl_subl_byte use record - Op at 0 range 2 .. 7; - w at 0 range 1 .. 1; - s at 0 range 0 .. 0; - Op2 at 1 range 3 .. 7; - Reg at 1 range 0 .. 2; - Imm8 at 2 range 0 .. 7; - end record; - - type Ins_addl_subl_word is record - Op : Bits6; -- Set to Op_Immed - w : Word_Byte; -- Word/Byte flag (set to 0 = word) - s : Boolean; -- Sign extension bit (1 = extend) - Op2 : Bits5; -- Secondary opcode - Reg : Rcode; -- Register - Imm32 : Uns32; -- Immediate operand - end record; - - for Ins_addl_subl_word use record - Op at 0 range 2 .. 7; - w at 0 range 1 .. 1; - s at 0 range 0 .. 0; - Op2 at 1 range 3 .. 7; - Reg at 1 range 0 .. 2; - Imm32 at 2 range 0 .. 31; - end record; - - type Ins_addl_subl_byte_Ptr is access all Ins_addl_subl_byte; - type Ins_addl_subl_word_Ptr is access all Ins_addl_subl_word; - - --------------------- - -- Prolog Analysis -- - --------------------- - - -- The analysis of the prolog answers the following questions: - - -- 1. Is %ebp used as a frame pointer? - -- 2. How far is SP depressed (i.e. what is the stack frame size) - -- 3. Which registers are saved in the prolog, and in what order - - -- The following data structure stores the answers to these questions - - subtype SOC is Rcode range ebx .. edi; - -- Possible save over call registers - - SOC_Max : constant := 4; - -- Max number of SOC registers that can be pushed - - type SOC_Push_Regs_Type is array (1 .. 4) of Rcode; - -- Used to hold the register codes of pushed SOC registers - - type Prolog_Type is record - - Frame_Reg : Boolean; - -- This is set to True if %ebp is used as a frame register, and - -- False otherwise (in the False case, %ebp may be saved in the - -- usual manner along with the other SOC registers). - - Frame_Length : Uns32; - -- Amount by which ESP is decremented on entry, includes the effects - -- of push's of save over call registers as indicated above, e.g. if - -- the prolog of a routine is: - -- - -- pushl %ebp - -- movl %esp,%ebp - -- subl $424,%esp - -- pushl %edi - -- pushl %esi - -- pushl %ebx - -- - -- Then the value of Frame_Length would be 436 (424 + 3 * 4). A - -- precise definition is that it is: - -- - -- %esp on entry minus %esp after last SOC push - -- - -- That definition applies both in the frame pointer present and - -- the frame pointer absent cases. - - Num_SOC_Push : Integer range 0 .. SOC_Max; - -- Number of save over call registers actually saved by pushl - -- instructions (other than the initial pushl to save the frame - -- pointer if a frame pointer is in use). - - SOC_Push_Regs : SOC_Push_Regs_Type; - -- The First Num_SOC_Push entries of this array are used to contain - -- the codes for the SOC registers, in the order in which they were - -- pushed. Note that this array excludes %ebp if it is used as a frame - -- register, since although %ebp is still considered an SOC register - -- in this case, it is saved and restored by a separate mechanism. - -- Also we will never see %esp represented in this list. Again, it is - -- true that %esp is saved over call, but it is restored by a separate - -- mechanism. - - end record; - - procedure Analyze_Prolog (A : Address; Prolog : out Prolog_Type); - -- Given the address of the start of the prolog for a procedure, - -- analyze the instructions of the prolog, and set Prolog to contain - -- the information obtained from this analysis. - - ---------------------------------- - -- Machine_State_Representation -- - ---------------------------------- - - -- The type Machine_State is defined in the body of Ada.Exceptions as - -- a Storage_Array of length 1 .. Machine_State_Length. But really it - -- has structure as defined here. We use the structureless declaration - -- in Ada.Exceptions to avoid this unit from being implementation - -- dependent. The actual definition of Machine_State is as follows: - - type SOC_Regs_Type is array (SOC) of Uns32; - - type MState is record - eip : Uns32; - -- The instruction pointer location (which is the return point - -- value from the next level down in all cases). - - Regs : SOC_Regs_Type; - -- Values of the save over call registers - end record; - - for MState use record - eip at 0 range 0 .. 31; - Regs at 4 range 0 .. 5 * 32 - 1; - end record; - -- Note: the routines Enter_Handler, and Set_Machine_State reference - -- the fields in this structure non-symbolically. - - type MState_Ptr is access all MState; - - function To_MState_Ptr is - new Unchecked_Conversion (Machine_State, MState_Ptr); - - ---------------------------- - -- Allocate_Machine_State -- - ---------------------------- - - function Allocate_Machine_State return Machine_State is - use System.Storage_Elements; - - begin - return Machine_State - (Memory.Alloc (MState'Max_Size_In_Storage_Elements)); - end Allocate_Machine_State; - - -------------------- - -- Analyze_Prolog -- - -------------------- - - procedure Analyze_Prolog (A : Address; Prolog : out Prolog_Type) is - Ptr : Address; - Ppl : Ins_pushl_Ptr; - Pas : Ins_addl_subl_byte_Ptr; - - function To_Ins_pushl_Ptr is - new Unchecked_Conversion (Address, Ins_pushl_Ptr); - - function To_Ins_addl_subl_byte_Ptr is - new Unchecked_Conversion (Address, Ins_addl_subl_byte_Ptr); - - function To_Ins_addl_subl_word_Ptr is - new Unchecked_Conversion (Address, Ins_addl_subl_word_Ptr); - - begin - Ptr := A; - Prolog.Frame_Length := 0; - - if Ptr = Null_Address then - Prolog.Num_SOC_Push := 0; - Prolog.Frame_Reg := True; - return; - end if; - - if To_Ins_pushl_Ptr (Ptr).all = Ins_pushl_ebp then - Ptr := Ptr + 1 + Ins_movl_length; - Prolog.Frame_Reg := True; - else - Prolog.Frame_Reg := False; - end if; - - Pas := To_Ins_addl_subl_byte_Ptr (Ptr); - - if Pas.Op = Op_Immed - and then Pas.Op2 = Op2_subl_Immed - and then Pas.Reg = esp - then - if Pas.w = Word then - Prolog.Frame_Length := Prolog.Frame_Length + - To_Ins_addl_subl_word_Ptr (Ptr).Imm32; - Ptr := Ptr + 6; - - else - Prolog.Frame_Length := Prolog.Frame_Length + Uns32 (Pas.Imm8); - Ptr := Ptr + 3; - - -- Note: we ignore sign extension, since a sign extended - -- value that was negative would imply a ludicrous frame size. - end if; - end if; - - -- Now scan push instructions for SOC registers - - Prolog.Num_SOC_Push := 0; - - loop - Ppl := To_Ins_pushl_Ptr (Ptr); - - if Ppl.Op = Op_pushl and then Ppl.Reg in SOC then - Prolog.Num_SOC_Push := Prolog.Num_SOC_Push + 1; - Prolog.SOC_Push_Regs (Prolog.Num_SOC_Push) := Ppl.Reg; - Prolog.Frame_Length := Prolog.Frame_Length + 4; - Ptr := Ptr + 1; - - else - exit; - end if; - end loop; - - end Analyze_Prolog; - - ------------------- - -- Enter_Handler -- - ------------------- - - procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is - begin - Asm ("mov %0,%%edx", Inputs => Machine_State'Asm_Input ("r", M)); - Asm ("mov %0,%%eax", Inputs => Handler_Loc'Asm_Input ("r", Handler)); - - Asm ("mov 4(%%edx),%%ebx"); -- M.Regs (ebx) - Asm ("mov 12(%%edx),%%ebp"); -- M.Regs (ebp) - Asm ("mov 16(%%edx),%%esi"); -- M.Regs (esi) - Asm ("mov 20(%%edx),%%edi"); -- M.Regs (edi) - Asm ("mov 8(%%edx),%%esp"); -- M.Regs (esp) - Asm ("jmp %*%%eax"); - end Enter_Handler; - - ---------------- - -- Fetch_Code -- - ---------------- - - function Fetch_Code (Loc : Code_Loc) return Code_Loc is - begin - return Loc; - end Fetch_Code; - - ------------------------ - -- Free_Machine_State -- - ------------------------ - - procedure Free_Machine_State (M : in out Machine_State) is - begin - Memory.Free (Address (M)); - M := Machine_State (Null_Address); - end Free_Machine_State; - - ------------------ - -- Get_Code_Loc -- - ------------------ - - function Get_Code_Loc (M : Machine_State) return Code_Loc is - - Asm_Call_Size : constant := 2; - -- Minimum size for a call instruction under ix86. Using the minimum - -- size is safe here as the call point computed from the return point - -- will always be inside the call instruction. - - MS : constant MState_Ptr := To_MState_Ptr (M); - - begin - if MS.eip = 0 then - return To_Address (MS.eip); - else - -- When doing a call the return address is pushed to the stack. - -- We want to return the call point address, so we substract - -- Asm_Call_Size from the return address. This value is set - -- to 5 as an asm call takes 5 bytes on x86 architectures. - - return To_Address (MS.eip - Asm_Call_Size); - end if; - end Get_Code_Loc; - - -------------------------- - -- Machine_State_Length -- - -------------------------- - - function Machine_State_Length - return System.Storage_Elements.Storage_Offset - is - begin - return MState'Max_Size_In_Storage_Elements; - end Machine_State_Length; - - --------------- - -- Pop_Frame -- - --------------- - - procedure Pop_Frame - (M : Machine_State; - Info : Subprogram_Info_Type) - is - MS : constant MState_Ptr := To_MState_Ptr (M); - PL : Prolog_Type; - - SOC_Ptr : Uns32; - -- Pointer to stack location after last SOC push - - Rtn_Ptr : Uns32; - -- Pointer to stack location containing return address - - begin - Analyze_Prolog (Info, PL); - - -- Case of frame register, use EBP, safer than ESP - - if PL.Frame_Reg then - SOC_Ptr := MS.Regs (ebp) - PL.Frame_Length; - Rtn_Ptr := MS.Regs (ebp) + 4; - MS.Regs (ebp) := To_Uns32_Ptr (MS.Regs (ebp)).all; - - -- No frame pointer, use ESP, and hope we have it exactly right! - - else - SOC_Ptr := MS.Regs (esp); - Rtn_Ptr := SOC_Ptr + PL.Frame_Length; - end if; - - -- Get saved values of SOC registers - - for J in reverse 1 .. PL.Num_SOC_Push loop - MS.Regs (PL.SOC_Push_Regs (J)) := To_Uns32_Ptr (SOC_Ptr).all; - SOC_Ptr := SOC_Ptr + 4; - end loop; - - MS.eip := To_Uns32_Ptr (Rtn_Ptr).all; - MS.Regs (esp) := Rtn_Ptr + 4; - end Pop_Frame; - - ----------------------- - -- Set_Machine_State -- - ----------------------- - - procedure Set_Machine_State (M : Machine_State) is - N : constant Asm_Output_Operand := No_Output_Operands; - - begin - Asm ("mov %0,%%edx", N, Machine_State'Asm_Input ("r", M)); - - -- At this stage, we have the following situation (note that we - -- are assuming that the -fomit-frame-pointer switch has not been - -- used in compiling this procedure. - - -- (value of M) - -- return point - -- old ebp <------ current ebp/esp value - - -- The values of registers ebx/esi/edi are unchanged from entry - -- so they have the values we want, and %edx points to the parameter - -- value M, so we can store these values directly. - - Asm ("mov %%ebx,4(%%edx)"); -- M.Regs (ebx) - Asm ("mov %%esi,16(%%edx)"); -- M.Regs (esi) - Asm ("mov %%edi,20(%%edx)"); -- M.Regs (edi) - - -- The desired value of ebp is the old value - - Asm ("mov 0(%%ebp),%%eax"); - Asm ("mov %%eax,12(%%edx)"); -- M.Regs (ebp) - - -- The return point is the desired eip value - - Asm ("mov 4(%%ebp),%%eax"); - Asm ("mov %%eax,(%%edx)"); -- M.eip - - -- Finally, the desired %esp value is the value at the point of - -- call to this routine *before* pushing the parameter value. - - Asm ("lea 12(%%ebp),%%eax"); - Asm ("mov %%eax,8(%%edx)"); -- M.Regs (esp) - end Set_Machine_State; - - ------------------------------ - -- Set_Signal_Machine_State -- - ------------------------------ - - procedure Set_Signal_Machine_State - (M : Machine_State; - Context : System.Address) - is - pragma Warnings (Off, M); - pragma Warnings (Off, Context); - - begin - null; - end Set_Signal_Machine_State; - -end System.Machine_State_Operations; diff --git a/gcc/ada/5oosinte.adb b/gcc/ada/5oosinte.adb deleted file mode 100644 index e2a241118d5..00000000000 --- a/gcc/ada/5oosinte.adb +++ /dev/null @@ -1,120 +0,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 the OS/2 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.OS2Lib.Errors; -with Interfaces.OS2Lib.Synchronization; - -package body System.OS_Interface is - - use Interfaces; - use Interfaces.OS2Lib; - use Interfaces.OS2Lib.Synchronization; - use Interfaces.OS2Lib.Errors; - - ----------- - -- Yield -- - ----------- - - -- Give up the remainder of the time-slice and yield the processor - -- to other threads of equal priority. Yield will return immediately - -- without giving up the current time-slice when the only threads - -- that are ready have a lower priority. - - -- ??? Just giving up the current time-slice seems not to be enough - -- to get the thread to the end of the ready queue if OS/2 does use - -- a queue at all. As a partial work-around, we give up two time-slices. - - -- This is the best we can do now, and at least is sufficient for passing - -- the ACVC 2.0.1 Annex D tests. - - procedure Yield is - begin - Delay_For (0); - Delay_For (0); - end Yield; - - --------------- - -- Delay_For -- - --------------- - - procedure Delay_For (Period : in Duration_In_Millisec) is - Result : APIRET; - - begin - pragma Assert (Period >= 0, "GNULLI---Delay_For: negative argument"); - - -- ??? DosSleep is not the appropriate function for a delay in real - -- time. It only gives up some number of scheduled time-slices. - -- Use a timer instead or block for some semaphore with a time-out. - Result := DosSleep (ULONG (Period)); - - if Result = ERROR_TS_WAKEUP then - - -- Do appropriate processing for interrupted sleep - -- Can we raise an exception here? - - null; - end if; - - pragma Assert (Result = NO_ERROR, "GNULLI---Error in Delay_For"); - end Delay_For; - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - - -- Implement conversion from tick count to Duration - -- using fixed point arithmetic. The frequency of - -- the Intel 8254 timer chip is 18.2 * 2**16 Hz. - - Tick_Duration : constant := 1.0 / (18.2 * 2**16); - Tick_Count : aliased QWORD; - - begin - -- Read nr of clock ticks since boot time - - Must_Not_Fail (DosTmrQueryTime (Tick_Count'Access)); - - return Tick_Count * Tick_Duration; - end Clock; - -end System.OS_Interface; diff --git a/gcc/ada/5oosinte.ads b/gcc/ada/5oosinte.ads deleted file mode 100644 index 4ddd2d0b06d..00000000000 --- a/gcc/ada/5oosinte.ads +++ /dev/null @@ -1,125 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 OS/2 version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; - -package System.OS_Interface is - pragma Preelaborate; - - package C renames Interfaces.C; - - subtype int is C.int; - subtype unsigned_long is C.unsigned_long; - - type Duration_In_Millisec is new C.long; - -- New type to prevent confusing time functions in this package - -- with time functions returning seconds or other units. - - type Thread_Id is new unsigned_long; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 5; - EINTR : constant := 13; - EINVAL : constant := 14; - ENOMEM : constant := 25; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 15; - type Signal is new int range 0 .. Max_Interrupt; - - -- Signals for OS/2, only SIGTERM used currently. The values are - -- fake, since OS/2 uses 32 bit exception numbers that cannot be - -- used to index arrays etc. The GNULLI maps these Unix-like signals - -- to OS/2 exception numbers. - - -- SIGTERM is used for the abort interrupt. - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGEMT : constant := 0; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - - subtype sigset_t is unsigned_long; - - ---------- - -- Time -- - ---------- - - function Clock return Duration; - pragma Inline (Clock); - -- Clock measuring time since the epoch, which is the boot-time. - -- The clock resolution is approximately 838 ns. - - procedure Delay_For (Period : in Duration_In_Millisec); - pragma Inline (Delay_For); - -- Changed Sleep to Delay_For, for consistency with System.Time_Operations - - ---------------- - -- Scheduling -- - ---------------- - - -- Put the calling task at the end of the ready queue for its priority - - procedure Yield; - pragma Inline (Yield); - -end System.OS_Interface; diff --git a/gcc/ada/5oosprim.adb b/gcc/ada/5oosprim.adb deleted file mode 100644 index 42e414cde44..00000000000 --- a/gcc/ada/5oosprim.adb +++ /dev/null @@ -1,172 +0,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-2001 Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the OS/2 version of this package - -with Interfaces.C; use Interfaces.C; -with Interfaces.OS2Lib; use Interfaces.OS2Lib; -with Interfaces.OS2Lib.Synchronization; use Interfaces.OS2Lib.Synchronization; - -package body System.OS_Primitives is - - ---------------- - -- Local Data -- - ---------------- - - Epoch_Offset : Duration; -- See Set_Epoch_Offset - Max_Tick_Count : QWORD := 0.0; - -- This is needed to compensate for small glitches in the - -- hardware clock or the way it is read by the OS - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Set_Epoch_Offset; - -- Initializes the Epoch_1970_Offset to the offset of the System_Clock - -- relative to the Unix epoch (Jan 1, 1970), such that - -- Clock = System_Clock + Epoch_1970_Offset - - function System_Clock return Duration; - pragma Inline (System_Clock); - -- Function returning value of system clock with system-dependent timebase. - -- For OS/2 the system clock returns the elapsed time since system boot. - -- The clock resolution is approximately 838 ns. - - ------------------ - -- System_Clock -- - ------------------ - - function System_Clock return Duration is - - -- Implement conversion from tick count to Duration - -- using fixed point arithmetic. The frequency of - -- the Intel 8254 timer chip is 18.2 * 2**16 Hz. - - Tick_Duration : constant := 1.0 / (18.2 * 2**16); - Tick_Count : aliased QWORD; - - begin - Must_Not_Fail (DosTmrQueryTime (Tick_Count'Access)); - -- Read nr of clock ticks since boot time - - Max_Tick_Count := QWORD'Max (Tick_Count, Max_Tick_Count); - - return Max_Tick_Count * Tick_Duration; - end System_Clock; - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - begin - return System_Clock + Epoch_Offset; - end Clock; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration renames Clock; - - ---------------------- - -- Set_Epoch_Offset -- - ---------------------- - - procedure Set_Epoch_Offset is - - -- Interface to Unix C style gettimeofday - - type timeval is record - tv_sec : long; - tv_usec : long; - end record; - - procedure gettimeofday - (time : access timeval; - zone : System.Address := System.Address'Null_Parameter); - pragma Import (C, gettimeofday); - - Time_Of_Day : aliased timeval; - Micro_To_Nano : constant := 1.0E3; - Sec_To_Nano : constant := 1.0E9; - Nanos_Since_Epoch : QWORD; - - begin - gettimeofday (Time_Of_Day'Access); - Nanos_Since_Epoch := QWORD (Time_Of_Day.tv_sec) * Sec_To_Nano - + QWORD (Time_Of_Day.tv_usec) * Micro_To_Nano; - - Epoch_Offset := - Duration'(Nanos_Since_Epoch / Sec_To_Nano) - System_Clock; - - end Set_Epoch_Offset; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Rel_Time : Duration; - Abs_Time : Duration; - Check_Time : Duration := Clock; - - 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 - Must_Not_Fail (DosSleep (ULONG (Rel_Time * 1000.0))); - - Check_Time := Clock; - - exit when Abs_Time <= Check_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - -begin - Set_Epoch_Offset; -end System.OS_Primitives; diff --git a/gcc/ada/5oparame.adb b/gcc/ada/5oparame.adb deleted file mode 100644 index 1ae7463618b..00000000000 --- a/gcc/ada/5oparame.adb +++ /dev/null @@ -1,83 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2002 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 OS/2 specific version - default stacksizes need to be large - -package body System.Parameters is - - ------------------------ - -- Default_Stack_Size -- - ------------------------ - - function Default_Stack_Size return Size_Type is - begin - -- The default stack size for extra tasks is based on the - -- default stack size for the main task (8 MB) and for the heap - -- (32 MB). - - -- In OS/2 it doesn't hurt to define large stacks, unless - -- the system is configured to commit all memory reservations. - -- This is not a default configuration however. - - return 1024 * 1024; - end Default_Stack_Size; - - ------------------------ - -- Minimum_Stack_Size -- - ------------------------ - - function Minimum_Stack_Size return Size_Type is - begin - -- System functions may need 8 kB of stack, so 12 kB seems a - -- good minimum. - return 12 * 1024; - end Minimum_Stack_Size; - - ------------------------- - -- Adjust_Storage_Size -- - ------------------------- - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type is - begin - if Size = Unspecified_Size then - return Default_Stack_Size; - - elsif Size < Minimum_Stack_Size then - return Minimum_Stack_Size; - - else - return Size; - end if; - end Adjust_Storage_Size; - -end System.Parameters; diff --git a/gcc/ada/5osystem.ads b/gcc/ada/5osystem.ads deleted file mode 100644 index 17acb5bc21e..00000000000 --- a/gcc/ada/5osystem.ads +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (OS/2 Version) -- --- -- --- 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 := 0.01; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := False; - ZCX_By_Default : constant Boolean := False; - GCC_ZCX_Support : constant Boolean := False; - Front_End_ZCX_Support : constant Boolean := True; - - -- Obsolete entries, to be removed eventually (bootstrap issues!) - - High_Integrity_Mode : constant Boolean := False; - Long_Shifts_Inlined : constant Boolean := True; - -end System; diff --git a/gcc/ada/5otaprop.adb b/gcc/ada/5otaprop.adb deleted file mode 100644 index 924f477bb67..00000000000 --- a/gcc/ada/5otaprop.adb +++ /dev/null @@ -1,1157 +0,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 . O P E R A T I O N S -- --- -- --- 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 an OS/2 version of this package - --- This package contains all the GNULL primitives that interface directly --- with the underlying OS. - -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.Tasking.Debug; --- used for Known_Tasks - -with Interfaces.C; --- used for size_t - -with Interfaces.C.Strings; --- used for Null_Ptr - -with Interfaces.OS2Lib.Errors; -with Interfaces.OS2Lib.Threads; -with Interfaces.OS2Lib.Synchronization; - -with System.Parameters; --- used for Size_Type - -with System.Tasking; --- used for Task_ID - -with System.Parameters; --- used for Size_Type - -with System.Soft_Links; --- used for Defer/Undefer_Abort - --- Note that we do not use System.Tasking.Initialization directly since --- this is a higher level package that we shouldn't depend on. For example --- when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Initialization - -with System.OS_Primitives; --- used for Delay_Modes --- Clock - -with Unchecked_Conversion; -with Unchecked_Deallocation; - -package body System.Task_Primitives.Operations is - - package IC renames Interfaces.C; - package ICS renames Interfaces.C.Strings; - package OSP renames System.OS_Primitives; - package SSL renames System.Soft_Links; - - use Interfaces.OS2Lib; - use Interfaces.OS2Lib.Errors; - use Interfaces.OS2Lib.Threads; - use Interfaces.OS2Lib.Synchronization; - use System.Parameters; - use System.Tasking.Debug; - use System.Tasking; - use System.OS_Interface; - use Interfaces.C; - use System.OS_Primitives; - - --------------------- - -- Local Constants -- - --------------------- - - Max_Locks_Per_Task : constant := 100; - Suppress_Owner_Check : constant Boolean := False; - - ----------------- - -- Local Types -- - ----------------- - - subtype Lock_Range is Integer range 0 .. Max_Locks_Per_Task; - - ----------------- - -- Local Data -- - ----------------- - - -- The OS/2 DosAllocThreadLocalMemory API is used to allocate our TCB_Ptr. - - -- This API reserves a small range of virtual addresses that is backed - -- by different physical memory for each running thread. In this case we - -- create a pointer at a fixed address that points to the TCB_Ptr for the - -- running thread. So all threads will be able to query and update their - -- own TCB_Ptr without destroying the TCB_Ptr of other threads. - - type Thread_Local_Data is record - Self_ID : Task_ID; -- ID of the current thread - Lock_Prio_Level : Lock_Range; -- Nr of priority changes due to locks - - -- ... room for expansion here, if we decide to make access to - -- jump-buffer and exception stack more efficient in future - end record; - - type Access_Thread_Local_Data is access all Thread_Local_Data; - - -- Pointer to Thread Local Data - Thread_Local_Data_Ptr : aliased Access_Thread_Local_Data; - - type PPTLD is access all Access_Thread_Local_Data; - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - - Environment_Task_ID : Task_ID; - -- A variable to hold Task_ID for the environment task. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function To_PPVOID is new Unchecked_Conversion (PPTLD, PPVOID); - function To_Address is new Unchecked_Conversion (Task_ID, System.Address); - function To_PFNTHREAD is - new Unchecked_Conversion (System.Address, PFNTHREAD); - - function To_MS (D : Duration) return ULONG; - - procedure Set_Temporary_Priority - (T : in Task_ID; - New_Priority : in System.Any_Priority); - - ----------- - -- To_MS -- - ----------- - - function To_MS (D : Duration) return ULONG is - begin - return ULONG (D * 1_000); - end To_MS; - - ----------- - -- Clock -- - ----------- - - function Monotonic_Clock return Duration renames OSP.Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - begin - return 10#1.0#E-6; - end RT_Resolution; - - ------------------- - -- Abort_Handler -- - ------------------- - - -- OS/2 only has limited support for asynchronous signals. - -- It seems not to be possible to jump out of an exception - -- handler or to change the execution context of the thread. - -- So asynchonous transfer of control is not supported. - - ----------------- - -- Stack_Guard -- - ----------------- - - -- The underlying thread system sets a guard page at the - -- bottom of a thread stack, so nothing is needed. - -- ??? Check the comment above - - procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is - pragma Unreferenced (T); - pragma Unreferenced (On); - - begin - null; - end Stack_Guard; - - -------------------- - -- Get_Thread_Id -- - -------------------- - - function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is - begin - return OSI.Thread_Id (T.Common.LL.Thread); - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_ID is - Self_ID : Task_ID renames Thread_Local_Data_Ptr.Self_ID; - begin - -- Check that the thread local data has been initialized. - - pragma Assert - ((Thread_Local_Data_Ptr /= null - and then Thread_Local_Data_Ptr.Self_ID /= null)); - - return Self_ID; - end Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : access Lock) - is - begin - if DosCreateMutexSem - (ICS.Null_Ptr, L.Mutex'Unchecked_Access, 0, False32) /= NO_ERROR - then - raise Storage_Error; - end if; - - pragma Assert (L.Mutex /= 0, "Error creating Mutex"); - L.Priority := Prio; - L.Owner_ID := Null_Address; - end Initialize_Lock; - - procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is - pragma Unreferenced (Level); - - begin - if DosCreateMutexSem - (ICS.Null_Ptr, L.Mutex'Unchecked_Access, 0, False32) /= NO_ERROR - then - raise Storage_Error; - end if; - - pragma Assert (L.Mutex /= 0, "Error creating Mutex"); - - L.Priority := System.Any_Priority'Last; - L.Owner_ID := Null_Address; - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : access Lock) is - begin - Must_Not_Fail (DosCloseMutexSem (L.Mutex)); - end Finalize_Lock; - - procedure Finalize_Lock (L : access RTS_Lock) is - begin - Must_Not_Fail (DosCloseMutexSem (L.Mutex)); - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID; - Old_Priority : constant Any_Priority := - Self_ID.Common.LL.Current_Priority; - - begin - if L.Priority < Old_Priority then - Ceiling_Violation := True; - return; - end if; - - Ceiling_Violation := False; - - -- Increase priority before getting the lock - -- to prevent priority inversion - - Thread_Local_Data_Ptr.Lock_Prio_Level := - Thread_Local_Data_Ptr.Lock_Prio_Level + 1; - if L.Priority > Old_Priority then - Set_Temporary_Priority (Self_ID, L.Priority); - end if; - - -- Request the lock and then update the lock owner data - - Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT)); - L.Owner_Priority := Old_Priority; - L.Owner_ID := Self_ID.all'Address; - end Write_Lock; - - procedure Write_Lock - (L : access RTS_Lock; - Global_Lock : Boolean := False) - is - Self_ID : Task_ID; - Old_Priority : Any_Priority; - - begin - if not Single_Lock or else Global_Lock then - Self_ID := Thread_Local_Data_Ptr.Self_ID; - Old_Priority := Self_ID.Common.LL.Current_Priority; - - -- Increase priority before getting the lock - -- to prevent priority inversion - - Thread_Local_Data_Ptr.Lock_Prio_Level := - Thread_Local_Data_Ptr.Lock_Prio_Level + 1; - - if L.Priority > Old_Priority then - Set_Temporary_Priority (Self_ID, L.Priority); - end if; - - -- Request the lock and then update the lock owner data - - Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT)); - L.Owner_Priority := Old_Priority; - L.Owner_ID := Self_ID.all'Address; - end if; - end Write_Lock; - - procedure Write_Lock (T : Task_ID) is - begin - if not Single_Lock then - - -- Request the lock and then update the lock owner data - - Must_Not_Fail - (DosRequestMutexSem (T.Common.LL.L.Mutex, SEM_INDEFINITE_WAIT)); - T.Common.LL.L.Owner_ID := Null_Address; - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock - (L : access Lock; Ceiling_Violation : out Boolean) renames Write_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : access Lock) is - Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID; - Old_Priority : constant Any_Priority := L.Owner_Priority; - - begin - -- Check that this task holds the lock - - pragma Assert (Suppress_Owner_Check - or else L.Owner_ID = Self_ID.all'Address); - - -- Upate the owner data - - L.Owner_ID := Null_Address; - - -- Do the actual unlocking. No more references - -- to owner data of L after this point. - - Must_Not_Fail (DosReleaseMutexSem (L.Mutex)); - - -- Reset priority after unlocking to avoid priority inversion - - Thread_Local_Data_Ptr.Lock_Prio_Level := - Thread_Local_Data_Ptr.Lock_Prio_Level - 1; - if L.Priority /= Old_Priority then - Set_Temporary_Priority (Self_ID, Old_Priority); - end if; - end Unlock; - - procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is - Self_ID : Task_ID; - Old_Priority : Any_Priority; - - begin - if not Single_Lock or else Global_Lock then - Self_ID := Thread_Local_Data_Ptr.Self_ID; - Old_Priority := L.Owner_Priority; - -- Check that this task holds the lock - - pragma Assert (Suppress_Owner_Check - or else L.Owner_ID = Self_ID.all'Address); - - -- Upate the owner data - - L.Owner_ID := Null_Address; - - -- Do the actual unlocking. No more references - -- to owner data of L after this point. - - Must_Not_Fail (DosReleaseMutexSem (L.Mutex)); - - -- Reset priority after unlocking to avoid priority inversion - - Thread_Local_Data_Ptr.Lock_Prio_Level := - Thread_Local_Data_Ptr.Lock_Prio_Level - 1; - - if L.Priority /= Old_Priority then - Set_Temporary_Priority (Self_ID, Old_Priority); - end if; - end if; - end Unlock; - - procedure Unlock (T : Task_ID) is - begin - if not Single_Lock then - - -- Check the owner data - - pragma Assert (Suppress_Owner_Check - or else T.Common.LL.L.Owner_ID = Null_Address); - - -- Do the actual unlocking. No more references - -- to owner data of T.Common.LL.L after this point. - - Must_Not_Fail (DosReleaseMutexSem (T.Common.LL.L.Mutex)); - end if; - end Unlock; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : Task_ID; - Reason : System.Tasking.Task_States) - is - pragma Unreferenced (Reason); - - Count : aliased ULONG; -- Used to store dummy result - - begin - -- Must reset Cond BEFORE L is unlocked. - - Sem_Must_Not_Fail - (DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access)); - - if Single_Lock then - Unlock_RTS; - else - Unlock (Self_ID); - end if; - - -- No problem if we are interrupted here. - -- If the condition is signaled, DosWaitEventSem will simply not block. - - Sem_Must_Not_Fail - (DosWaitEventSem (Self_ID.Common.LL.CV, SEM_INDEFINITE_WAIT)); - - -- Since L was previously accquired, lock operation should not fail. - - if Single_Lock then - Lock_RTS; - else - Write_Lock (Self_ID); - end if; - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - -- This is for use within the run-time system, so abort is - -- assumed to be already deferred, and the caller should be - -- holding its own ATCB lock. - - -- Pre-assertion: Cond is posted - -- Self is locked. - - -- Post-assertion: Cond is posted - -- Self is locked. - - procedure Timed_Sleep - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : System.Tasking.Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Unreferenced (Reason); - - Check_Time : constant Duration := OSP.Monotonic_Clock; - Rel_Time : Duration; - Abs_Time : Duration; - Time_Out : ULONG; - Result : APIRET; - Count : aliased ULONG; -- Used to store dummy result - - begin - -- Must reset Cond BEFORE Self_ID is unlocked. - - Sem_Must_Not_Fail - (DosResetEventSem (Self_ID.Common.LL.CV, - Count'Unchecked_Access)); - - if Single_Lock then - Unlock_RTS; - else - Unlock (Self_ID); - end if; - - Timedout := True; - Yielded := False; - - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; - - Time_Out := To_MS (Rel_Time); - Result := DosWaitEventSem (Self_ID.Common.LL.CV, Time_Out); - pragma Assert - ((Result = NO_ERROR or Result = ERROR_TIMEOUT - or Result = ERROR_INTERRUPT)); - - -- ??? - -- What to do with error condition ERROR_NOT_ENOUGH_MEMORY? Can - -- we raise an exception here? And what about ERROR_INTERRUPT? - -- Should that be treated as a simple timeout? - -- For now, consider only ERROR_TIMEOUT to be a timeout. - - exit when Abs_Time <= OSP.Monotonic_Clock; - - if Result /= ERROR_TIMEOUT then - -- somebody may have called Wakeup for us - Timedout := False; - exit; - end if; - - Rel_Time := Abs_Time - OSP.Monotonic_Clock; - end loop; - end if; - - -- Ensure post-condition - - if Single_Lock then - Lock_RTS; - else - Write_Lock (Self_ID); - end if; - - if Timedout then - Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV)); - end if; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes) - is - Check_Time : constant Duration := OSP.Monotonic_Clock; - Rel_Time : Duration; - Abs_Time : Duration; - Timedout : Boolean := True; - Time_Out : ULONG; - Result : APIRET; - Count : aliased ULONG; -- Used to store dummy result - - begin - -- Only the little window between deferring abort and - -- locking Self_ID is the reason we need to - -- check for pending abort and priority change below! :( - - SSL.Abort_Defer.all; - - if Single_Lock then - Lock_RTS; - else - Write_Lock (Self_ID); - end if; - - -- Must reset Cond BEFORE Self_ID is unlocked. - - Sem_Must_Not_Fail - (DosResetEventSem (Self_ID.Common.LL.CV, - Count'Unchecked_Access)); - - if Single_Lock then - Unlock_RTS; - else - Unlock (Self_ID); - end if; - - 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 - Self_ID.Common.State := Delay_Sleep; - - loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - Time_Out := To_MS (Rel_Time); - Result := DosWaitEventSem (Self_ID.Common.LL.CV, Time_Out); - - exit when Abs_Time <= OSP.Monotonic_Clock; - - Rel_Time := Abs_Time - OSP.Monotonic_Clock; - end loop; - - Self_ID.Common.State := Runnable; - Timedout := Result = ERROR_TIMEOUT; - end if; - - if Single_Lock then - Lock_RTS; - else - Write_Lock (Self_ID); - end if; - - if Timedout then - Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV)); - end if; - - if Single_Lock then - Unlock_RTS; - else - Unlock (Self_ID); - end if; - - System.OS_Interface.Yield; - SSL.Abort_Undefer.all; - end Timed_Delay; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is - pragma Unreferenced (Reason); - - begin - Sem_Must_Not_Fail (DosPostEventSem (T.Common.LL.CV)); - end Wakeup; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - begin - if Do_Yield then - System.OS_Interface.Yield; - end if; - end Yield; - - ---------------------------- - -- Set_Temporary_Priority -- - ---------------------------- - - procedure Set_Temporary_Priority - (T : Task_ID; - New_Priority : System.Any_Priority) - is - use Interfaces.C; - Delta_Priority : Integer; - - begin - -- When Lock_Prio_Level = 0, we always need to set the - -- Active_Priority. In this way we can make priority changes - -- due to locking independent of those caused by calling - -- Set_Priority. - - if Thread_Local_Data_Ptr.Lock_Prio_Level = 0 - or else New_Priority < T.Common.Current_Priority - then - Delta_Priority := T.Common.Current_Priority - - T.Common.LL.Current_Priority; - else - Delta_Priority := New_Priority - T.Common.LL.Current_Priority; - end if; - - if Delta_Priority /= 0 then - -- ??? There is a race-condition here - -- The TCB is updated before the system call to make - -- pre-emption in the critical section less likely. - - T.Common.LL.Current_Priority := - T.Common.LL.Current_Priority + Delta_Priority; - Must_Not_Fail - (DosSetPriority (Scope => PRTYS_THREAD, - Class => PRTYC_NOCHANGE, - Delta_P => IC.long (Delta_Priority), - PorTid => T.Common.LL.Thread)); - end if; - end Set_Temporary_Priority; - - ------------------ - -- Set_Priority -- - ------------------ - - procedure Set_Priority - (T : Task_ID; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) - is - pragma Unreferenced (Loss_Of_Inheritance); - - begin - T.Common.Current_Priority := Prio; - Set_Temporary_Priority (T, Prio); - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_ID) return System.Any_Priority is - begin - return T.Common.Current_Priority; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (Self_ID : Task_ID) is - begin - -- Initialize thread local data. Must be done first. - - Thread_Local_Data_Ptr.Self_ID := Self_ID; - Thread_Local_Data_Ptr.Lock_Prio_Level := 0; - - Lock_RTS; - - for J in Known_Tasks'Range loop - if Known_Tasks (J) = null then - Known_Tasks (J) := Self_ID; - Self_ID.Known_Tasks_Index := J; - exit; - end if; - end loop; - - Unlock_RTS; - - -- For OS/2, we can set Self_ID.Common.LL.Thread in - -- Create_Task, since the thread is created suspended. - -- That is, there is no danger of the thread racing ahead - -- and trying to reference Self_ID.Common.LL.Thread before it - -- has been initialized. - - -- .... Do we need to do anything with signals for OS/2 ??? - end Enter_Task; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean is - begin - return False; - end Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_ID is - begin - return null; - end Register_Foreign_Thread; - - -------------------- - -- Initialize_TCB -- - -------------------- - - procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is - begin - if DosCreateEventSem (ICS.Null_Ptr, - Self_ID.Common.LL.CV'Unchecked_Access, 0, True32) = NO_ERROR - then - if not Single_Lock - and then DosCreateMutexSem - (ICS.Null_Ptr, - Self_ID.Common.LL.L.Mutex'Unchecked_Access, - 0, - False32) /= NO_ERROR - then - Succeeded := False; - Must_Not_Fail (DosCloseEventSem (Self_ID.Common.LL.CV)); - else - Succeeded := True; - end if; - - -- We now want to do the equivalent of: - - -- Initialize_Lock - -- (Self_ID.Common.LL.L'Unchecked_Access, ATCB_Level); - - -- But we avoid that because the Initialize_TCB routine has an - -- exception handler, and it is too early for us to deal with - -- installing handlers (see comment below), so we do our own - -- Initialize_Lock operation manually. - - Self_ID.Common.LL.L.Priority := System.Any_Priority'Last; - Self_ID.Common.LL.L.Owner_ID := Null_Address; - - else - Succeeded := False; - end if; - - -- Note: at one time we had an exception handler here, whose code - -- was as follows: - - -- exception - - -- Assumes any failure must be due to insufficient resources - - -- when Storage_Error => - -- Must_Not_Fail (DosCloseEventSem (Self_ID.Common.LL.CV)); - -- Succeeded := False; - - -- but that won't work with the old exception scheme, since it would - -- result in messing with Jmpbuf values too early. If and when we get - -- switched entirely to the new zero-cost exception scheme, we could - -- put this handler back in! - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_ID; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - Result : aliased APIRET; - Adjusted_Stack_Size : System.Parameters.Size_Type; - use System.Parameters; - - begin - -- In OS/2 the allocated stack size should be based on the - -- amount of address space that should be reserved for the stack. - -- Actual memory will only be used when the stack is touched anyway. - - -- The new minimum size is 12 kB, although the EMX docs - -- recommend a minimum size of 32 kB. (The original was 4 kB) - -- Systems that use many tasks (say > 30) and require much - -- memory may run out of virtual address space, since OS/2 - -- has a per-proces limit of 512 MB, of which max. 300 MB is - -- usable in practise. - - if Stack_Size = Unspecified_Size then - Adjusted_Stack_Size := Default_Stack_Size; - - elsif Stack_Size < Minimum_Stack_Size then - Adjusted_Stack_Size := Minimum_Stack_Size; - - else - Adjusted_Stack_Size := Stack_Size; - end if; - - -- GB970222: - -- Because DosCreateThread is called directly here, the - -- C RTL doesn't get initialized for the new thead. EMX by - -- default uses per-thread local heaps in addition to the - -- global heap. There might be other effects of by-passing the - -- C library here. - - -- When using _beginthread the newly created thread is not - -- blocked initially. Does this matter or can I create the - -- thread running anyway? The LL.Thread variable will be set - -- anyway because the variable is passed by reference to OS/2. - - T.Common.LL.Wrapper := To_PFNTHREAD (Wrapper); - - -- The OS implicitly gives the new task the priority of this task. - - T.Common.LL.Current_Priority := Self.Common.LL.Current_Priority; - - -- If task was locked before activator task was - -- initialized, assume it has OS standard priority - - if T.Common.LL.L.Owner_Priority not in Any_Priority'Range then - T.Common.LL.L.Owner_Priority := 1; - end if; - - -- Create the thread, in blocked mode - - Result := DosCreateThread - (F_ptid => T.Common.LL.Thread'Unchecked_Access, - pfn => T.Common.LL.Wrapper, - param => To_Address (T), - flag => Block_Child + Commit_Stack, - cbStack => ULONG (Adjusted_Stack_Size)); - - Succeeded := (Result = NO_ERROR); - - if not Succeeded then - return; - end if; - - -- Set the new thread's priority - -- (child has inherited priority from parent) - - Set_Priority (T, Priority); - - -- Start the thread executing - - Must_Not_Fail (DosResumeThread (T.Common.LL.Thread)); - - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_ID) is - Tmp : Task_ID := T; - - procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); - - begin - Must_Not_Fail (DosCloseEventSem (T.Common.LL.CV)); - - if not Single_Lock then - Finalize_Lock (T.Common.LL.L'Unchecked_Access); - end if; - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - Free (Tmp); - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - procedure Exit_Task is - begin - Thread_Local_Data_Ptr := null; - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_ID) is - pragma Unreferenced (T); - - begin - null; - - -- Task abortion not implemented yet. - -- Should perform other action ??? - - end Abort_Task; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy version - - function Check_Exit (Self_ID : ST.Task_ID) return Boolean is - begin - return Check_No_Locks (Self_ID); - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is - TLD : constant Access_Thread_Local_Data := Thread_Local_Data_Ptr; - - begin - return Self_ID = TLD.Self_ID - and then TLD.Lock_Prio_Level = 0; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_ID is - begin - return Environment_Task_ID; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean - is - begin - if Thread_Id (T.Common.LL.Thread) /= Thread_Self then - return DosSuspendThread (T.Common.LL.Thread) = NO_ERROR; - else - return True; - end if; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean - is - begin - if Thread_Id (T.Common.LL.Thread) /= Thread_Self then - return DosResumeThread (T.Common.LL.Thread) = NO_ERROR; - else - return True; - end if; - end Resume_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_ID) is - Succeeded : Boolean; - begin - Environment_Task_ID := Environment_Task; - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - -- Initialize the lock used to synchronize chain of all ATCBs. - - -- Set ID of environment task. - - Thread_Local_Data_Ptr.Self_ID := Environment_Task; - Environment_Task.Common.LL.Thread := 1; -- By definition - - -- This priority is unknown in fact. - -- If actual current priority is different, - -- it will get synchronized later on anyway. - - Environment_Task.Common.LL.Current_Priority := - Environment_Task.Common.Current_Priority; - - -- Initialize TCB for this task. - -- This includes all the normal task-external initialization. - -- This is also done by Initialize_ATCB, why ??? - - Initialize_TCB (Environment_Task, Succeeded); - - -- Consider raising Storage_Error, - -- if propagation can be tolerated ??? - - pragma Assert (Succeeded); - - -- Do normal task-internal initialization, - -- which depends on an initialized TCB. - - Enter_Task (Environment_Task); - - -- Insert here any other special - -- initialization needed for the environment task. - end Initialize; - -begin - -- Initialize pointer to task local data. - -- This is done once, for all tasks. - - Must_Not_Fail (DosAllocThreadLocalMemory - ((Thread_Local_Data'Size + 31) / 32, -- nr of 32-bit words - To_PPVOID (Thread_Local_Data_Ptr'Access))); - - -- Initialize thread local data for main thread - - Thread_Local_Data_Ptr.Self_ID := null; - Thread_Local_Data_Ptr.Lock_Prio_Level := 0; -end System.Task_Primitives.Operations; diff --git a/gcc/ada/5otaspri.ads b/gcc/ada/5otaspri.ads deleted file mode 100644 index cb5b0295b13..00000000000 --- a/gcc/ada/5otaspri.ads +++ /dev/null @@ -1,107 +0,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 an OS/2 version of this package. - --- This package provides low-level support for most tasking features. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with Interfaces.OS2Lib.Threads; -with Interfaces.OS2Lib.Synchronization; - -package System.Task_Primitives is - - pragma Preelaborate; - --- type Lock is limited private; - -- Should be used for implementation of protected objects. - --- type RTS_Lock is limited private; - -- Should be used inside the runtime system. - -- The difference between Lock and the RTS_Lock is that the later - -- one serves only as a semaphore so that do not check for - -- ceiling violations. - - type Task_Body_Access is access procedure; - -- Pointer to the task body's entry point (or possibly a wrapper - -- declared local to the GNARL). - --- type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task - -- basis. A component of this type is guaranteed to be included - -- in the Ada_Task_Control_Block. - --- private - - type Lock is record - Mutex : aliased Interfaces.OS2Lib.Synchronization.HMTX; - Priority : Integer; - Owner_Priority : Integer; - Owner_ID : Address; - end record; - - type RTS_Lock is new Lock; - - type Private_Data is record - Thread : aliased Interfaces.OS2Lib.Threads.TID; - pragma Atomic (Thread); - -- Thread field may be updated by two different threads of control. - -- (See, Enter_Task and Create_Task in s-taprop.adb). - -- They put the same value (thr_self value). We do not want to - -- use lock on those operations and the only thing we have to - -- make sure is that they are updated in atomic fashion. - - CV : aliased Interfaces.OS2Lib.Synchronization.HEV; - - L : aliased RTS_Lock; - -- Protection for all components is lock L - - Current_Priority : Integer := -1; - -- The Current_Priority is the actual priority of a thread. - -- This field is needed because it is only possible to set a - -- delta priority in OS/2. The only places where this field should - -- be set are Set_Priority, Create_Task and Initialize (Environment). - - Wrapper : Interfaces.OS2Lib.Threads.PFNTHREAD; - -- This is the original wrapper passed by Operations.Create_Task. - -- When installing an exception handler in a thread, the thread - -- starts executing the Exception_Wrapper which calls Wrapper - -- when the handler has been installed. The handler is removed when - -- wrapper returns. - end record; - -end System.Task_Primitives; diff --git a/gcc/ada/5posinte.ads b/gcc/ada/5posinte.ads deleted file mode 100644 index 4e5d9567df3..00000000000 --- a/gcc/ada/5posinte.ads +++ /dev/null @@ -1,574 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 a OpenNT/Interix (FSU THREADS) version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-lgthreads"); - pragma Linker_Options ("-lmalloc"); - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 11; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIMEDOUT : constant := 60; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 31; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGEMT : constant := 0; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGUSR1 : constant := 16; -- user defined signal 1 - SIGUSR2 : constant := 17; -- user defined signal 2 - SIGCLD : constant := 18; -- alias for SIGCHLD - SIGCHLD : constant := 18; -- child status change - SIGPWR : constant := 0; -- power-fail restart - SIGWINCH : constant := 20; -- window size change - SIGURG : constant := 21; -- urgent condition on IO channel - SIGPOLL : constant := 22; -- pollable event occurred - SIGIO : constant := 19; -- I/O possible (Solaris SIGPOLL alias) - SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 24; -- user stop requested from tty - SIGCONT : constant := 25; -- stopped process has been continued - SIGTTIN : constant := 26; -- background tty read attempted - SIGTTOU : constant := 27; -- background tty write attempted - SIGVTALRM : constant := 28; -- virtual timer expired - SIGPROF : constant := 29; -- profiling timer expired - SIGXCPU : constant := 30; -- CPU time limit exceeded - SIGXFSZ : constant := 31; -- filesize limit exceeded - - SIGADAABORT : constant := SIGABRT; - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := - (SIGTRAP, SIGALRM, SIGVTALRM, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); - - Reserved : constant Signal_Set := (SIGKILL, SIGSTOP); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : int; - sa_restorer : System.Address; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - SIG_BLOCK : constant := 1; - SIG_UNBLOCK : constant := 2; - SIG_SETMASK : constant := 3; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - SA_SIGINFO : constant := 0; - -- Dummy constant for a sa_flags bit. A proper definition is needed only - -- for the GCC/ZCX EH scheme (see System.Interrupt_Management). - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - -- FSU pthreads redefines sigaction and then uses a special syscall - -- API to call the system version. Doing syscalls on OpenNT is very - -- difficult, so we rename the pthread version instead. - pragma Import (C, sigaction, "pthread_wrapper_sigaction"); - - ---------- - -- Time -- - ---------- - - Time_Slice_Supported : constant Boolean := False; - -- Indicates wether time slicing is supported (i.e FSU threads have been - -- compiled with DEF_RR) - - type timespec is private; - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; - pragma Import (C, clock_gettime, "clock_gettime"); - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timeval is private; - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 0; - SCHED_RR : constant := 1; - SCHED_OTHER : constant := 2; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - --------- - -- LWP -- - --------- - - function lwp_self return System.Address; - -- lwp_self does not exist on this thread library, revert to pthread_self - -- which is the closest approximation (with getpid). This function is - -- needed to share 7staprop.adb across POSIX-like targets. - pragma Import (C, lwp_self, "pthread_self"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 1; - PTHREAD_CREATE_JOINABLE : constant := 0; - - ----------- - -- Stack -- - ----------- - - Stack_Base_Available : constant Boolean := False; - -- Indicates wether the stack base is available on this target. - -- This allows us to share s-osinte.adb between all the FSU run time. - -- Note that this value can only be true if pthread_t has a complete - -- definition that corresponds exactly to the C header files. - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- returns the stack base of the specified thread. - -- Only call this function when Stack_Base_Available is True. - - function Get_Page_Size return size_t; - function Get_Page_Size return Address; - pragma Import (C, Get_Page_Size, "getpagesize"); - -- returns the size of a page, or 0 if this is not relevant on this - -- target - - PROT_NONE : constant := 0; - PROT_READ : constant := 1; - PROT_WRITE : constant := 2; - PROT_EXEC : constant := 4; - PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; - - PROT_ON : constant := PROT_NONE; - PROT_OFF : constant := PROT_ALL; - - function mprotect (addr : Address; len : size_t; prot : int) return int; - pragma Import (C, mprotect); - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - procedure pthread_init; - -- FSU_THREADS requires pthread_init, which is nonstandard - -- and this should be invoked during the elaboration of s-taprop.adb - pragma Import (C, pthread_init, "pthread_init"); - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) return int; - -- FSU_THREADS has a nonstandard sigwait - - function pthread_kill - (thread : pthread_t; - sig : Signal) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask, "pthread_wrapper_sigprocmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - -- FSU_THREADS has nonstandard pthread_mutex_lock - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - -- FSU_THREADS has nonstandard pthread_mutex_lock - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "pthread_cond_init"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - -- FSU_THREADS has a nonstandard pthread_cond_wait - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - -- FSU_THREADS has a nonstandard pthread_cond_timedwait - - Relative_Timed_Wait : constant Boolean := False; - -- pthread_cond_timedwait requires an absolute delay time - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - PTHREAD_PRIO_NONE : constant := 0; - PTHREAD_PRIO_PROTECT : constant := 2; - PTHREAD_PRIO_INHERIT : constant := 1; - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol); - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int; - pragma Import - (C, pthread_mutexattr_setprioceiling, - "pthread_mutexattr_setprio_ceiling"); - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - -- FSU_THREADS does not have pthread_setschedparam - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import (C, pthread_attr_setinheritsched); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; - policy : int) return int; - pragma Import - (C, pthread_attr_setschedpolicy, "pthread_attr_setsched"); - - function sched_yield return int; - -- FSU_THREADS does not have sched_yield; - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "pthread_attr_init"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - -- FSU_THREADS has a nonstandard pthread_attr_setdetachstate - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "pthread_create"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "pthread_setspecific"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - -- FSU_THREADS has a nonstandard pthread_getspecific - - type destructor_pointer is access procedure (arg : System.Address); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "pthread_key_create"); - -private - - type sigset_t is new unsigned_long; - pragma Convention (C, sigset_t); - - type pid_t is new int; - - subtype time_t is long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 0; - - type struct_timeval is record - tv_sec : time_t; - tv_usec : long; - end record; - pragma Convention (C, struct_timeval); - - type pthread_attr_t is record - flags : int; - stacksize : int; - contentionscope : int; - inheritsched : int; - detachstate : int; - sched : int; - prio : int; - starttime : timespec; - deadline : timespec; - period : timespec; - end record; - pragma Convention (C_Pass_By_Copy, pthread_attr_t); - - type pthread_condattr_t is record - flags : int; - end record; - pragma Convention (C, pthread_condattr_t); - - type pthread_mutexattr_t is record - flags : int; - prio_ceiling : int; - protocol : int; - end record; - pragma Convention (C, pthread_mutexattr_t); - - type sigjmp_buf is array (Integer range 0 .. 17) of int; - - type pthread_t_struct is record - context : sigjmp_buf; - pbody : sigjmp_buf; - errno : int; - ret : int; - stack_base : System.Address; - end record; - pragma Convention (C, pthread_t_struct); - - type pthread_t is access all pthread_t_struct; - - type queue_t is record - head : System.Address; - tail : System.Address; - end record; - pragma Convention (C, queue_t); - - type pthread_mutex_t is record - queue : queue_t; - lock : plain_char; - owner : System.Address; - flags : int; - prio_ceiling : int; - protocol : int; - prev_max_ceiling_prio : int; - end record; - pragma Convention (C, pthread_mutex_t); - - type pthread_cond_t is record - queue : queue_t; - flags : int; - waiters : int; - mutex : System.Address; - end record; - pragma Convention (C, pthread_cond_t); - - type pthread_key_t is new int; - -end System.OS_Interface; diff --git a/gcc/ada/5posprim.adb b/gcc/ada/5posprim.adb deleted file mode 100644 index ed8a6f40f55..00000000000 --- a/gcc/ada/5posprim.adb +++ /dev/null @@ -1,124 +0,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 uses gettimeofday and select --- This file is suitable for OpenNT, Dec Unix and SCO UnixWare. - -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_timeval is record - tv_sec : Integer; - tv_usec : Integer; - end record; - pragma Convention (C, struct_timeval); - - procedure gettimeofday - (tv : access struct_timeval; - tz : Address := Null_Address); - pragma Import (C, gettimeofday, "gettimeofday"); - - procedure C_select - (n : Integer := 0; - readfds, - writefds, - exceptfds : Address := Null_Address; - timeout : access struct_timeval); - pragma Import (C, C_select, "select"); - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - TV : aliased struct_timeval; - - begin - gettimeofday (TV'Access); - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end Clock; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration renames Clock; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Rel_Time : Duration; - Abs_Time : Duration; - Check_Time : Duration := Clock; - timeval : aliased struct_timeval; - - 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 - timeval.tv_sec := Integer (Rel_Time); - - if Duration (timeval.tv_sec) > Rel_Time then - timeval.tv_sec := timeval.tv_sec - 1; - end if; - - timeval.tv_usec := - Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6); - - C_select (timeout => timeval'Unchecked_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; diff --git a/gcc/ada/5psystem.ads b/gcc/ada/5psystem.ads deleted file mode 100644 index 11058290e59..00000000000 --- a/gcc/ada/5psystem.ads +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (OpenNT/Interix Version) -- --- -- --- 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 := 0.01; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := False; - 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 := True; - -end System; diff --git a/gcc/ada/5pvxwork.ads b/gcc/ada/5pvxwork.ads deleted file mode 100644 index 17118681fc3..00000000000 --- a/gcc/ada/5pvxwork.ads +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . V X W O R K S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the PPC VxWorks version of this package. - -with Interfaces.C; - -package System.VxWorks is - pragma Preelaborate (System.VxWorks); - - package IC renames Interfaces.C; - - -- Floating point context record. PPC version - - FP_NUM_DREGS : constant := 32; - type Fpr_Array is array (1 .. FP_NUM_DREGS) of IC.double; - - type FP_CONTEXT is record - fpr : Fpr_Array; - fpcsr : IC.int; - pad : IC.int; - end record; - pragma Convention (C, FP_CONTEXT); - - Num_HW_Interrupts : constant := 256; - -end System.VxWorks; diff --git a/gcc/ada/5sintman.adb b/gcc/ada/5sintman.adb deleted file mode 100644 index d8d5963fca2..00000000000 --- a/gcc/ada/5sintman.adb +++ /dev/null @@ -1,263 +0,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-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 Solaris version of this package. - --- PLEASE DO NOT add any dependences on other packages. --- This package is designed to work with or without tasking support. - --- Make a careful study of all signals available under the OS, --- to see which need to be reserved, kept always unmasked, --- or kept always unmasked. - --- Be on the lookout for special signals that --- may be used by the thread library. - -with Interfaces.C; --- used for int - -with System.OS_Interface; --- used for various Constants, Signal and types - -package body System.Interrupt_Management is - - use 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"); - - ---------------------- - -- Notify_Exception -- - ---------------------- - - -- This function identifies the Ada exception to be raised using - -- the information when the system received a synchronous signal. - -- Since this function is machine and OS dependent, different code - -- has to be provided for different target. - - procedure Notify_Exception - (signo : Signal; - info : access siginfo_t; - context : access ucontext_t); - - ---------------------- - -- Notify_Exception -- - ---------------------- - - procedure Notify_Exception - (signo : Signal; - info : access siginfo_t; - context : access ucontext_t) - is - pragma Warnings (Off, context); - - begin - -- 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 => - case info.si_code is - when FPE_INTDIV | - FPE_INTOVF | - FPE_FLTDIV | - FPE_FLTOVF | - FPE_FLTUND | - FPE_FLTRES | - FPE_FLTINV | - FPE_FLTSUB => - - raise Constraint_Error; - - when others => - pragma Assert (False); - null; - end case; - - when SIGILL | SIGSEGV | SIGBUS => - raise Storage_Error; - - when others => - pragma Assert (False); - 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 Initialization -- ----------------------------- - -begin - declare - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - mask : aliased sigset_t; - Result : Interfaces.C.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; - - -- Change this if you want to use another signal for task abort. - -- SIGTERM might be a good one. - - Abort_Task_Interrupt := SIGABRT; - - act.sa_handler := Notify_Exception'Address; - - -- 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. - - -- In that case, this field should be changed back to 0. ??? (Dong-Ik) - - act.sa_flags := 16; - - Result := sigemptyset (mask'Access); - pragma Assert (Result = 0); - - -- ??? For the same reason explained above, we can't mask these - -- signals because otherwise we won't be able to catch more than - -- one signal. - - act.sa_mask := mask; - - pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False)); - pragma Assert (Reserve = (Interrupt_ID'Range => False)); - - 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's - -- 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 not existing 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; diff --git a/gcc/ada/5sml-tgt.adb b/gcc/ada/5sml-tgt.adb deleted file mode 100644 index ac5e4b937fe..00000000000 --- a/gcc/ada/5sml-tgt.adb +++ /dev/null @@ -1,362 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T -- --- (Solaris Version) -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-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. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a set of target dependent routines to build --- static, dynamic and shared libraries. - --- This is the Solaris version of the body - -with MLib.Fil; -with MLib.Utl; -with Namet; use Namet; -with Opt; -with Output; use Output; -with Prj.Com; -with System; - -package body MLib.Tgt is - - No_Arguments : aliased Argument_List := (1 .. 0 => null); - Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; - - Wl_Init_String : constant String := "-Wl,-zinitarray="; - Wl_Fini_String : constant String := "-Wl,-zfiniarray="; - - Init_Fini_List : constant Argument_List_Access := - new Argument_List'(1 => null, - 2 => null); - - -- Used to put switches for automatic elaboration/finalization - - --------------------- - -- Archive_Builder -- - --------------------- - - function Archive_Builder return String is - begin - return "ar"; - end Archive_Builder; - - ----------------------------- - -- Archive_Builder_Options -- - ----------------------------- - - function Archive_Builder_Options return String_List_Access is - begin - return new String_List'(1 => new String'("cr")); - end Archive_Builder_Options; - - ----------------- - -- Archive_Ext -- - ----------------- - - function Archive_Ext return String is - begin - return "a"; - end Archive_Ext; - - --------------------- - -- Archive_Indexer -- - --------------------- - - function Archive_Indexer return String is - begin - return "ranlib"; - end Archive_Indexer; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Foreign : Argument_List; - Afiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Address : String := ""; - Lib_Version : String := ""; - Relocatable : Boolean := False; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Foreign); - pragma Unreferenced (Afiles); - pragma Unreferenced (Interfaces); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Lib_Address); - pragma Unreferenced (Relocatable); - - Lib_File : constant String := - Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Filename, DLL_Ext); - - Version_Arg : String_Access; - Symbolic_Link_Needed : Boolean := False; - - Init_Fini : Argument_List_Access := Empty_Argument_List; - - begin - if Opt.Verbose_Mode then - Write_Str ("building relocatable shared library "); - Write_Line (Lib_File); - end if; - - -- If specified, add automatic elaboration/finalization - if Auto_Init then - Init_Fini := Init_Fini_List; - Init_Fini (1) := - new String'(Wl_Init_String & Lib_Filename & "init"); - Init_Fini (2) := - new String'(Wl_Fini_String & Lib_Filename & "final"); - end if; - - if Lib_Version = "" then - Utl.Gcc - (Output_File => Lib_File, - Objects => Ofiles, - Options => Options & Init_Fini.all, - Driver_Name => Driver_Name); - - else - Version_Arg := new String'("-Wl,-h," & Lib_Version); - - if Is_Absolute_Path (Lib_Version) then - Utl.Gcc - (Output_File => Lib_Version, - Objects => Ofiles, - Options => Options & Version_Arg & Init_Fini.all, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := Lib_Version /= Lib_File; - - else - Utl.Gcc - (Output_File => Lib_Dir & Directory_Separator & Lib_Version, - Objects => Ofiles, - Options => Options & Version_Arg & Init_Fini.all, - Driver_Name => Driver_Name); - Symbolic_Link_Needed := - Lib_Dir & Directory_Separator & Lib_Version /= Lib_File; - end if; - - if Symbolic_Link_Needed then - declare - Success : Boolean; - Oldpath : String (1 .. Lib_Version'Length + 1); - Newpath : String (1 .. Lib_File'Length + 1); - - Result : Integer; - pragma Unreferenced (Result); - - function Symlink - (Oldpath : System.Address; - Newpath : System.Address) - return Integer; - pragma Import (C, Symlink, "__gnat_symlink"); - - begin - Oldpath (1 .. Lib_Version'Length) := Lib_Version; - Oldpath (Oldpath'Last) := ASCII.NUL; - Newpath (1 .. Lib_File'Length) := Lib_File; - Newpath (Newpath'Last) := ASCII.NUL; - - Delete_File (Lib_File, Success); - - Result := Symlink (Oldpath'Address, Newpath'Address); - end; - end if; - end if; - end Build_Dynamic_Library; - - ------------------------- - -- Default_DLL_Address -- - ------------------------- - - function Default_DLL_Address return String is - begin - return ""; - end Default_DLL_Address; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return "so"; - end DLL_Ext; - - -------------------- - -- Dynamic_Option -- - -------------------- - - function Dynamic_Option return String is - begin - return "-shared"; - end Dynamic_Option; - - ------------------- - -- Is_Object_Ext -- - ------------------- - - function Is_Object_Ext (Ext : String) return Boolean is - begin - return Ext = ".o"; - end Is_Object_Ext; - - -------------- - -- Is_C_Ext -- - -------------- - - function Is_C_Ext (Ext : String) return Boolean is - begin - return Ext = ".c"; - end Is_C_Ext; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".a" or else Ext = ".so"; - end Is_Archive_Ext; - - ------------- - -- Libgnat -- - ------------- - - function Libgnat return String is - begin - return "libgnat.a"; - end Libgnat; - - ------------------------ - -- Library_Exists_For -- - ------------------------ - - function Library_Exists_For (Project : Project_Id) return Boolean is - begin - if not Projects.Table (Project).Library then - Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & - "for non library project"); - return False; - - else - declare - Lib_Dir : constant String := - Get_Name_String (Projects.Table (Project).Library_Dir); - Lib_Name : constant String := - Get_Name_String (Projects.Table (Project).Library_Name); - - begin - if Projects.Table (Project).Library_Kind = Static then - return Is_Regular_File - (Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - return Is_Regular_File - (Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - end; - end if; - end Library_Exists_For; - - --------------------------- - -- Library_File_Name_For -- - --------------------------- - - function Library_File_Name_For (Project : Project_Id) return Name_Id is - begin - if not Projects.Table (Project).Library then - Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & - "for non library project"); - return No_Name; - - else - declare - Lib_Name : constant String := - Get_Name_String (Projects.Table (Project).Library_Name); - - begin - Name_Len := 3; - Name_Buffer (1 .. Name_Len) := "lib"; - - if Projects.Table (Project).Library_Kind = Static then - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - - return Name_Find; - end; - end if; - end Library_File_Name_For; - - ---------------- - -- Object_Ext -- - ---------------- - - function Object_Ext return String is - begin - return "o"; - end Object_Ext; - - ---------------- - -- PIC_Option -- - ---------------- - - function PIC_Option return String is - begin - return "-fPIC"; - end PIC_Option; - - ----------------------------------------------- - -- Standalone_Library_Auto_Init_Is_Supported -- - ----------------------------------------------- - - function Standalone_Library_Auto_Init_Is_Supported return Boolean is - begin - return True; - end Standalone_Library_Auto_Init_Is_Supported; - - --------------------------- - -- Support_For_Libraries -- - --------------------------- - - function Support_For_Libraries return Library_Support is - begin - return Full; - end Support_For_Libraries; - -end MLib.Tgt; diff --git a/gcc/ada/5sosinte.adb b/gcc/ada/5sosinte.adb deleted file mode 100644 index 299625dadc2..00000000000 --- a/gcc/ada/5sosinte.adb +++ /dev/null @@ -1,100 +0,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 Solaris version of this package. - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with Interfaces.C; use Interfaces.C; -package body System.OS_Interface is - - ----------------- - -- 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; - - ----------------- - -- To_Timespec -- - ----------------- - - function To_Timespec (D : Duration) return timespec is - S : time_t; - F : Duration; - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - if F < 0.0 then S := S - 1; F := F + 1.0; end if; - return timespec'(tv_sec => S, - tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); - end To_Timespec; - - function To_Duration (TV : struct_timeval) return Duration is - begin - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end To_Duration; - - 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; - - procedure pthread_init is - begin - null; - end pthread_init; - -end System.OS_Interface; diff --git a/gcc/ada/5sosinte.ads b/gcc/ada/5sosinte.ads deleted file mode 100644 index b5754630372..00000000000 --- a/gcc/ada/5sosinte.ads +++ /dev/null @@ -1,569 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 a Solaris (native) version of this package - --- This package includes all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-lposix4"); - pragma Linker_Options ("-lthread"); - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 11; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIME : constant := 62; - ETIMEDOUT : constant := 145; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 45; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGUSR1 : constant := 16; -- user defined signal 1 - SIGUSR2 : constant := 17; -- user defined signal 2 - SIGCLD : constant := 18; -- alias for SIGCHLD - SIGCHLD : constant := 18; -- child status change - SIGPWR : constant := 19; -- power-fail restart - SIGWINCH : constant := 20; -- window size change - SIGURG : constant := 21; -- urgent condition on IO channel - SIGPOLL : constant := 22; -- pollable event occurred - SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias) - SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 24; -- user stop requested from tty - SIGCONT : constant := 25; -- stopped process has been continued - SIGTTIN : constant := 26; -- background tty read attempted - SIGTTOU : constant := 27; -- background tty write attempted - SIGVTALRM : constant := 28; -- virtual timer expired - SIGPROF : constant := 29; -- profiling timer expired - SIGXCPU : constant := 30; -- CPU time limit exceeded - SIGXFSZ : constant := 31; -- filesize limit exceeded - SIGWAITING : constant := 32; -- process's lwps blocked (Solaris) - SIGLWP : constant := 33; -- used by thread library (Solaris) - SIGFREEZE : constant := 34; -- used by CPR (Solaris) - SIGTHAW : constant := 35; -- used by CPR (Solaris) - SIGCANCEL : constant := 36; -- thread cancellation signal (libthread) - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := (SIGTRAP, SIGLWP, SIGPROF); - - -- Following signals should not be disturbed. - -- See c-posix-signals.c in FLORIST - - Reserved : constant Signal_Set := - (SIGKILL, SIGSTOP, SIGWAITING, SIGCANCEL, SIGTRAP, SIGSEGV); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type union_type_3 is new String (1 .. 116); - type siginfo_t is record - si_signo : int; - si_code : int; - si_errno : int; - X_data : union_type_3; - end record; - pragma Convention (C, siginfo_t); - - -- The types mcontext_t and gregset_t are part of the ucontext_t - -- information, which is specific to Solaris2.4 for SPARC - -- The ucontext_t info seems to be used by the handler - -- for SIGSEGV to decide whether it is a Storage_Error (stack overflow) or - -- a Constraint_Error (bad pointer). The original code that did this - -- is suspect, so it is not clear whether we really need this part of - -- the signal context information, or perhaps something else. - -- More analysis is needed, after which these declarations may need to - -- be changed. - - FPE_INTDIV : constant := 1; -- integer divide by zero - FPE_INTOVF : constant := 2; -- integer overflow - FPE_FLTDIV : constant := 3; -- floating point divide by zero - FPE_FLTOVF : constant := 4; -- floating point overflow - FPE_FLTUND : constant := 5; -- floating point underflow - FPE_FLTRES : constant := 6; -- floating point inexact result - FPE_FLTINV : constant := 7; -- invalid floating point operation - FPE_FLTSUB : constant := 8; -- subscript out of range - - type greg_t is new int; - - type gregset_t is array (0 .. 18) of greg_t; - - type union_type_2 is new String (1 .. 128); - type record_type_1 is record - fpu_fr : union_type_2; - fpu_q : System.Address; - fpu_fsr : unsigned; - fpu_qcnt : unsigned_char; - fpu_q_entrysize : unsigned_char; - fpu_en : unsigned_char; - end record; - pragma Convention (C, record_type_1); - - type array_type_7 is array (Integer range 0 .. 20) of long; - type mcontext_t is record - gregs : gregset_t; - gwins : System.Address; - fpregs : record_type_1; - filler : array_type_7; - end record; - pragma Convention (C, mcontext_t); - - type record_type_2 is record - ss_sp : System.Address; - ss_size : int; - ss_flags : int; - end record; - pragma Convention (C, record_type_2); - - type array_type_8 is array (Integer range 0 .. 22) of long; - type ucontext_t is record - uc_flags : unsigned_long; - uc_link : System.Address; - uc_sigmask : sigset_t; - uc_stack : record_type_2; - uc_mcontext : mcontext_t; - uc_filler : array_type_8; - end record; - pragma Convention (C, ucontext_t); - - type Signal_Handler is access procedure - (signo : Signal; - info : access siginfo_t; - context : access ucontext_t); - - type union_type_1 is new plain_char; - type array_type_2 is array (Integer range 0 .. 1) of int; - type struct_sigaction is record - sa_flags : int; - sa_handler : System.Address; - sa_mask : sigset_t; - sa_resv : array_type_2; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - SIG_BLOCK : constant := 1; - SIG_UNBLOCK : constant := 2; - SIG_SETMASK : constant := 3; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - type timespec is private; - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - - function clock_gettime - (clock_id : clockid_t; tp : access timespec) return int; - pragma Import (C, clock_gettime, "clock_gettime"); - - function clock_getres - (clock_id : clockid_t; res : access timespec) return int; - pragma Import (C, clock_getres, "clock_getres"); - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timeval is private; - -- This is needed on systems that do not have clock_gettime() - -- but do have gettimeofday(). - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - THR_DETACHED : constant := 64; - THR_BOUND : constant := 1; - THR_NEW_LWP : constant := 2; - USYNC_THREAD : constant := 0; - - type thread_t is new unsigned; - subtype Thread_Id is thread_t; - -- These types should be commented ??? - - function To_thread_t is new Unchecked_Conversion (Integer, thread_t); - - type mutex_t is limited private; - - type cond_t is limited private; - - type thread_key_t is private; - - function thr_create - (stack_base : System.Address; - stack_size : size_t; - start_routine : Thread_Body; - arg : System.Address; - flags : int; - new_thread : access thread_t) return int; - pragma Import (C, thr_create, "thr_create"); - - function thr_min_stack return size_t; - pragma Import (C, thr_min_stack, "thr_min_stack"); - - function thr_self return thread_t; - pragma Import (C, thr_self, "thr_self"); - - function mutex_init - (mutex : access mutex_t; - mtype : int; - arg : System.Address) return int; - pragma Import (C, mutex_init, "mutex_init"); - - function mutex_destroy (mutex : access mutex_t) return int; - pragma Import (C, mutex_destroy, "mutex_destroy"); - - function mutex_lock (mutex : access mutex_t) return int; - pragma Import (C, mutex_lock, "mutex_lock"); - - function mutex_unlock (mutex : access mutex_t) return int; - pragma Import (C, mutex_unlock, "mutex_unlock"); - - function cond_init - (cond : access cond_t; - ctype : int; - arg : int) return int; - pragma Import (C, cond_init, "cond_init"); - - function cond_wait - (cond : access cond_t; mutex : access mutex_t) return int; - pragma Import (C, cond_wait, "cond_wait"); - - function cond_timedwait - (cond : access cond_t; - mutex : access mutex_t; - abstime : access timespec) return int; - pragma Import (C, cond_timedwait, "cond_timedwait"); - - function cond_signal (cond : access cond_t) return int; - pragma Import (C, cond_signal, "cond_signal"); - - function cond_destroy (cond : access cond_t) return int; - pragma Import (C, cond_destroy, "cond_destroy"); - - function thr_setspecific - (key : thread_key_t; value : System.Address) return int; - pragma Import (C, thr_setspecific, "thr_setspecific"); - - function thr_getspecific - (key : thread_key_t; - value : access System.Address) return int; - pragma Import (C, thr_getspecific, "thr_getspecific"); - - function thr_keycreate - (key : access thread_key_t; destructor : System.Address) return int; - pragma Import (C, thr_keycreate, "thr_keycreate"); - - function thr_setprio (thread : thread_t; priority : int) return int; - pragma Import (C, thr_setprio, "thr_setprio"); - - procedure thr_exit (status : System.Address); - pragma Import (C, thr_exit, "thr_exit"); - - function thr_setconcurrency (new_level : int) return int; - pragma Import (C, thr_setconcurrency, "thr_setconcurrency"); - - function sigwait (set : access sigset_t; sig : access Signal) return int; - pragma Import (C, sigwait, "__posix_sigwait"); - - function thr_kill (thread : thread_t; sig : Signal) return int; - pragma Import (C, thr_kill, "thr_kill"); - - type sigset_t_ptr is access all sigset_t; - - function thr_sigsetmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, thr_sigsetmask, "thr_sigsetmask"); - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask, "thr_sigsetmask"); - - function thr_suspend (target_thread : thread_t) return int; - pragma Import (C, thr_suspend, "thr_suspend"); - - function thr_continue (target_thread : thread_t) return int; - pragma Import (C, thr_continue, "thr_continue"); - - procedure thr_yield; - pragma Import (C, thr_yield, "thr_yield"); - - --------- - -- LWP -- - --------- - - P_PID : constant := 0; - P_LWPID : constant := 8; - - PC_GETCID : constant := 0; - PC_GETCLINFO : constant := 1; - PC_SETPARMS : constant := 2; - PC_GETPARMS : constant := 3; - PC_ADMIN : constant := 4; - - PC_CLNULL : constant := -1; - - RT_NOCHANGE : constant := -1; - RT_TQINF : constant := -2; - RT_TQDEF : constant := -3; - - PC_CLNMSZ : constant := 16; - - PC_VERSION : constant := 1; - - type lwpid_t is new int; - - type pri_t is new short; - - type id_t is new long; - - P_MYID : constant := -1; - -- the specified LWP or process is the current one. - - type struct_pcinfo is record - pc_cid : id_t; - pc_clname : String (1 .. PC_CLNMSZ); - rt_maxpri : short; - end record; - pragma Convention (C, struct_pcinfo); - - type struct_pcparms is record - pc_cid : id_t; - rt_pri : pri_t; - rt_tqsecs : long; - rt_tqnsecs : long; - end record; - pragma Convention (C, struct_pcparms); - - function priocntl - (ver : int; - id_type : int; - id : lwpid_t; - cmd : int; - arg : System.Address) return Interfaces.C.long; - pragma Import (C, priocntl, "__priocntl"); - - function lwp_self return lwpid_t; - pragma Import (C, lwp_self, "_lwp_self"); - - type processorid_t is new int; - type processorid_t_ptr is access all processorid_t; - - -- Constants for function processor_bind - - PBIND_QUERY : constant processorid_t := -2; - -- the processor bindings are not changed. - - PBIND_NONE : constant processorid_t := -1; - -- the processor bindings of the specified LWPs are cleared. - - -- Flags for function p_online - - PR_OFFLINE : constant int := 1; - -- processor is offline, as quiet as possible - - PR_ONLINE : constant int := 2; - -- processor online - - PR_STATUS : constant int := 3; - -- value passed to p_online to request status - - function p_online (processorid : processorid_t; flag : int) return int; - pragma Import (C, p_online, "p_online"); - - function processor_bind - (id_type : int; - id : id_t; - proc_id : processorid_t; - obind : processorid_t_ptr) return int; - pragma Import (C, processor_bind, "processor_bind"); - - procedure pthread_init; - -- dummy procedure to share s-intman.adb with other Solaris targets. - -private - - type array_type_1 is array (0 .. 3) of unsigned_long; - type sigset_t is record - X_X_sigbits : array_type_1; - end record; - pragma Convention (C, sigset_t); - - type pid_t is new long; - - type time_t is new long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 0; - - type struct_timeval is record - tv_sec : long; - tv_usec : long; - end record; - pragma Convention (C, struct_timeval); - - type array_type_9 is array (0 .. 3) of unsigned_char; - type record_type_3 is record - flag : array_type_9; - Xtype : unsigned_long; - end record; - pragma Convention (C, record_type_3); - - type mutex_t is record - flags : record_type_3; - lock : String (1 .. 8); - data : String (1 .. 8); - end record; - pragma Convention (C, mutex_t); - - type cond_t is record - flag : array_type_9; - Xtype : unsigned_long; - data : String (1 .. 8); - end record; - pragma Convention (C, cond_t); - - type thread_key_t is new unsigned; - -end System.OS_Interface; diff --git a/gcc/ada/5sosprim.adb b/gcc/ada/5sosprim.adb deleted file mode 100644 index b6d529d206c..00000000000 --- a/gcc/ada/5sosprim.adb +++ /dev/null @@ -1,124 +0,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 uses gettimeofday and select --- This file is suitable for Solaris (32 and 64 bits). - -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_timeval is record - tv_sec : Long_Integer; - tv_usec : Long_Integer; - end record; - pragma Convention (C, struct_timeval); - - procedure gettimeofday - (tv : access struct_timeval; - tz : Address := Null_Address); - pragma Import (C, gettimeofday, "gettimeofday"); - - procedure C_select - (n : Integer := 0; - readfds, - writefds, - exceptfds : Address := Null_Address; - timeout : access struct_timeval); - pragma Import (C, C_select, "select"); - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - TV : aliased struct_timeval; - - begin - gettimeofday (TV'Access); - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end Clock; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration renames Clock; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Rel_Time : Duration; - Abs_Time : Duration; - Check_Time : Duration := Clock; - timeval : aliased struct_timeval; - - 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 - timeval.tv_sec := Long_Integer (Rel_Time); - - if Duration (timeval.tv_sec) > Rel_Time then - timeval.tv_sec := timeval.tv_sec - 1; - end if; - - timeval.tv_usec := - Long_Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6); - - C_select (timeout => timeval'Unchecked_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; diff --git a/gcc/ada/5sparame.adb b/gcc/ada/5sparame.adb deleted file mode 100644 index 847dda820e8..00000000000 --- a/gcc/ada/5sparame.adb +++ /dev/null @@ -1,80 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- B o d y -- --- -- --- 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. -- --- -- ------------------------------------------------------------------------------- - --- This is the Solaris (native) specific version - -package body System.Parameters is - - ------------------------ - -- Default_Stack_Size -- - ------------------------ - - function Default_Stack_Size return Size_Type is - begin - return 100_000; - end Default_Stack_Size; - - ------------------------ - -- Minimum_Stack_Size -- - ------------------------ - - function Minimum_Stack_Size return Size_Type is - - thr_min_stack : constant Size_Type := 1160; - -- hard coded value for Solaris 8 to avoid adding dependency on - -- libthread for every Ada program. - -- This value does not really matter anyway, since this is checked - -- and adjusted at the library level when creating a thread. - - begin - return thr_min_stack; - end Minimum_Stack_Size; - - ------------------------- - -- Adjust_Storage_Size -- - ------------------------- - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type is - begin - if Size = Unspecified_Size then - return Default_Stack_Size; - - elsif Size < Minimum_Stack_Size then - return Minimum_Stack_Size; - - else - return Size; - end if; - end Adjust_Storage_Size; - -end System.Parameters; diff --git a/gcc/ada/5ssystem.ads b/gcc/ada/5ssystem.ads deleted file mode 100644 index 80621a76517..00000000000 --- a/gcc/ada/5ssystem.ads +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (SUN Solaris Version) -- --- -- --- 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 := 0.01; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := True; - 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 := False; - ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; - 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 := True; - -end System; diff --git a/gcc/ada/5staprop.adb b/gcc/ada/5staprop.adb deleted file mode 100644 index a264b029693..00000000000 --- a/gcc/ada/5staprop.adb +++ /dev/null @@ -1,1815 +0,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 . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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 a Solaris (native) version of this package - --- This package contains all the GNULL primitives that interface directly --- with the underlying OS. - -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.Tasking.Debug; --- used for Known_Tasks - -with Ada.Exceptions; --- used for Raise_Exception - -with GNAT.OS_Lib; --- used for String_Access, Getenv - -with Interfaces.C; --- used for int --- size_t - -with System.Interrupt_Management; --- used for Keep_Unmasked --- Abort_Task_Interrupt --- Interrupt_ID - -with System.Interrupt_Management.Operations; --- used for Set_Interrupt_Mask --- All_Tasks_Mask -pragma Elaborate_All (System.Interrupt_Management.Operations); - -with System.Parameters; --- used for Size_Type - -with System.Tasking; --- used for Ada_Task_Control_Block --- Task_ID --- ATCB components and types - -with System.Task_Info; --- to initialize Task_Info for a C thread, in function Self - -with System.Soft_Links; --- used for Defer/Undefer_Abort --- to initialize TSD for a C thread, in function Self - --- Note that we do not use System.Tasking.Initialization directly since --- this is a higher level package that we shouldn't depend on. For example --- when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Initialization - -with System.OS_Primitives; --- used for Delay_Modes - -with Unchecked_Deallocation; - -package body System.Task_Primitives.Operations is - - use System.Tasking.Debug; - use System.Tasking; - use Interfaces.C; - use System.OS_Interface; - use System.Parameters; - use Ada.Exceptions; - use System.OS_Primitives; - - package SSL renames System.Soft_Links; - - ---------------- - -- Local Data -- - ---------------- - - -- The following are logically constants, but need to be initialized - -- at run time. - - Environment_Task_ID : Task_ID; - -- A variable to hold Task_ID for the environment task. - -- If we use this variable to get the Task_ID, we need the following - -- ATCB_Key only for non-Ada threads. - - Unblocked_Signal_Mask : aliased sigset_t; - -- The set of signals that should unblocked in all tasks - - ATCB_Key : aliased thread_key_t; - -- Key used to find the Ada Task_ID associated with a thread, - -- at least for C threads unknown to the Ada run-time system. - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - - Next_Serial_Number : Task_Serial_Number := 100; - -- We start at 100, to reserve some special values for - -- using in error checking. - -- The following are internal configuration constants needed. - - ---------------------- - -- Priority Support -- - ---------------------- - - Priority_Ceiling_Emulation : constant Boolean := True; - -- controls whether we emulate priority ceiling locking - - -- To get a scheduling close to annex D requirements, we use the real-time - -- class provided for LWP's and map each task/thread to a specific and - -- unique LWP (there is 1 thread per LWP, and 1 LWP per thread). - - -- The real time class can only be set when the process has root - -- priviledges, so in the other cases, we use the normal thread scheduling - -- and priority handling. - - Using_Real_Time_Class : Boolean := False; - -- indicates wether the real time class is being used (i.e the process - -- has root priviledges). - - Prio_Param : aliased struct_pcparms; - -- Hold priority info (Real_Time) initialized during the package - -- elaboration. - - ----------------------------------- - -- External Configuration Values -- - ----------------------------------- - - Time_Slice_Val : Interfaces.C.long; - pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - - Locking_Policy : Character; - pragma Import (C, Locking_Policy, "__gl_locking_policy"); - - Dispatching_Policy : Character; - pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - - Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads). - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function sysconf (name : System.OS_Interface.int) return processorid_t; - pragma Import (C, sysconf, "sysconf"); - - SC_NPROCESSORS_CONF : constant System.OS_Interface.int := 14; - - function Num_Procs - (name : System.OS_Interface.int := SC_NPROCESSORS_CONF) - return processorid_t renames sysconf; - - procedure Abort_Handler - (Sig : Signal; - Code : access siginfo_t; - Context : access ucontext_t); - -- Target-dependent binding of inter-thread Abort signal to - -- the raising of the Abort_Signal exception. - -- See also comments in 7staprop.adb - - ------------ - -- Checks -- - ------------ - - function Check_Initialize_Lock - (L : Lock_Ptr; - Level : Lock_Level) return Boolean; - pragma Inline (Check_Initialize_Lock); - - function Check_Lock (L : Lock_Ptr) return Boolean; - pragma Inline (Check_Lock); - - function Record_Lock (L : Lock_Ptr) return Boolean; - pragma Inline (Record_Lock); - - function Check_Sleep (Reason : Task_States) return Boolean; - pragma Inline (Check_Sleep); - - function Record_Wakeup - (L : Lock_Ptr; - Reason : Task_States) return Boolean; - pragma Inline (Record_Wakeup); - - function Check_Wakeup - (T : Task_ID; - Reason : Task_States) return Boolean; - pragma Inline (Check_Wakeup); - - function Check_Unlock (L : Lock_Ptr) return Boolean; - pragma Inline (Check_Unlock); - - function Check_Finalize_Lock (L : Lock_Ptr) return Boolean; - pragma Inline (Check_Finalize_Lock); - - -------------------- - -- Local Packages -- - -------------------- - - package Specific is - - procedure Initialize (Environment_Task : Task_ID); - pragma Inline (Initialize); - -- Initialize various data needed by this package. - - function Is_Valid_Task return Boolean; - pragma Inline (Is_Valid_Task); - -- Does executing thread have a TCB? - - procedure Set (Self_Id : Task_ID); - pragma Inline (Set); - -- Set the self id for the current task. - - function Self return Task_ID; - pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task. - - end Specific; - - package body Specific is separate; - -- The body of this package is target specific. - - --------------------------------- - -- Support for foreign threads -- - --------------------------------- - - function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; - -- Allocate and Initialize a new ATCB for the current Thread. - - function Register_Foreign_Thread - (Thread : Thread_Id) return Task_ID is separate; - - ------------ - -- Checks -- - ------------ - - Check_Count : Integer := 0; - Lock_Count : Integer := 0; - Unlock_Count : Integer := 0; - - ------------------- - -- Abort_Handler -- - ------------------- - - procedure Abort_Handler - (Sig : Signal; - Code : access siginfo_t; - Context : access ucontext_t) - is - pragma Unreferenced (Sig); - pragma Unreferenced (Code); - pragma Unreferenced (Context); - - Self_ID : constant Task_ID := Self; - Old_Set : aliased sigset_t; - - Result : Interfaces.C.int; - pragma Unreferenced (Result); - - begin - -- It is not safe to raise an exception when using ZCX and the GCC - -- exception handling mechanism. - - if ZCX_By_Default and then GCC_ZCX_Support then - return; - end if; - - if Self_ID.Deferral_Level = 0 - and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - and then not Self_ID.Aborting - then - Self_ID.Aborting := True; - - -- Make sure signals used for RTS internal purpose are unmasked - - Result := thr_sigsetmask (SIG_UNBLOCK, - Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); - pragma Assert (Result = 0); - - raise Standard'Abort_Signal; - end if; - end Abort_Handler; - - ------------------- - -- Stack_Guard -- - ------------------- - - -- The underlying thread system sets a guard page at the - -- bottom of a thread stack, so nothing is needed. - - procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is - pragma Unreferenced (T); - pragma Unreferenced (On); - - begin - null; - end Stack_Guard; - - -------------------- - -- Get_Thread_Id -- - -------------------- - - function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : ST.Task_ID) is - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - Tmp_Set : aliased sigset_t; - Result : Interfaces.C.int; - - procedure Configure_Processors; - -- Processors configuration - -- The user can specify a processor which the program should run - -- on to emulate a single-processor system. This can be easily - -- done by setting environment variable GNAT_PROCESSOR to one of - -- the following : - -- - -- -2 : use the default configuration (run the program on all - -- available processors) - this is the same as having - -- GNAT_PROCESSOR unset - -- -1 : let the RTS choose one processor and run the program on - -- that processor - -- 0 .. Last_Proc : run the program on the specified processor - -- - -- Last_Proc is equal to the value of the system variable - -- _SC_NPROCESSORS_CONF, minus one. - - procedure Configure_Processors is - Proc_Acc : constant GNAT.OS_Lib.String_Access := - GNAT.OS_Lib.Getenv ("GNAT_PROCESSOR"); - Proc : aliased processorid_t; -- User processor # - Last_Proc : processorid_t; -- Last processor # - - begin - if Proc_Acc.all'Length /= 0 then - -- Environment variable is defined - - Last_Proc := Num_Procs - 1; - - if Last_Proc /= -1 then - Proc := processorid_t'Value (Proc_Acc.all); - - if Proc <= -2 or else Proc > Last_Proc then - -- Use the default configuration - null; - elsif Proc = -1 then - -- Choose a processor - - Result := 0; - - while Proc < Last_Proc loop - Proc := Proc + 1; - Result := p_online (Proc, PR_STATUS); - exit when Result = PR_ONLINE; - end loop; - - pragma Assert (Result = PR_ONLINE); - Result := processor_bind (P_PID, P_MYID, Proc, null); - pragma Assert (Result = 0); - - else - -- Use user processor - - Result := processor_bind (P_PID, P_MYID, Proc, null); - pragma Assert (Result = 0); - end if; - end if; - end if; - - exception - when Constraint_Error => - - -- Illegal environment variable GNAT_PROCESSOR - ignored - - null; - end Configure_Processors; - - function State (Int : System.Interrupt_Management.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: - - 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) - - -- Start of processing for Initialize - - begin - Environment_Task_ID := Environment_Task; - - -- This is done in Enter_Task, but this is too late for the - -- Environment Task, since we need to call Self in Check_Locks when - -- the run time is compiled with assertions on. - - Specific.Initialize (Environment_Task); - - -- Initialize the lock used to synchronize chain of all ATCBs. - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - - Enter_Task (Environment_Task); - - -- Install the abort-signal handler - - if State (System.Interrupt_Management.Abort_Task_Interrupt) - /= Default - then - -- Set sa_flags to SA_NODEFER so that during the handler execution - -- we do not change the Signal_Mask to be masked for the Abort_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. - -- In that case, this field should be changed back to 0. ??? - - act.sa_flags := 16; - - act.sa_handler := Abort_Handler'Address; - Result := sigemptyset (Tmp_Set'Access); - pragma Assert (Result = 0); - act.sa_mask := Tmp_Set; - - Result := - sigaction ( - Signal (System.Interrupt_Management.Abort_Task_Interrupt), - act'Unchecked_Access, - old_act'Unchecked_Access); - pragma Assert (Result = 0); - end if; - - Configure_Processors; - end Initialize; - - --------------------- - -- Initialize_Lock -- - --------------------- - - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Initialize_TCB and the Storage_Error is - -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) - -- used in RTS is initialized before any status change of RTS. - -- Therefore rasing Storage_Error in the following routines - -- should be able to be handled safely. - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : access Lock) - is - Result : Interfaces.C.int; - - begin - pragma Assert (Check_Initialize_Lock (Lock_Ptr (L), PO_Level)); - - if Priority_Ceiling_Emulation then - L.Ceiling := Prio; - end if; - - Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Raise_Exception (Storage_Error'Identity, "Failed to allocate a lock"); - end if; - end Initialize_Lock; - - procedure Initialize_Lock - (L : access RTS_Lock; - Level : Lock_Level) - is - Result : Interfaces.C.int; - - begin - pragma Assert (Check_Initialize_Lock - (To_Lock_Ptr (RTS_Lock_Ptr (L)), Level)); - Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Raise_Exception (Storage_Error'Identity, "Failed to allocate a lock"); - end if; - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : access Lock) is - Result : Interfaces.C.int; - - begin - pragma Assert (Check_Finalize_Lock (Lock_Ptr (L))); - Result := mutex_destroy (L.L'Access); - pragma Assert (Result = 0); - end Finalize_Lock; - - procedure Finalize_Lock (L : access RTS_Lock) is - Result : Interfaces.C.int; - - begin - pragma Assert (Check_Finalize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); - Result := mutex_destroy (L.L'Access); - pragma Assert (Result = 0); - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - Result : Interfaces.C.int; - - begin - pragma Assert (Check_Lock (Lock_Ptr (L))); - - if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then - declare - Self_Id : constant Task_ID := Self; - Saved_Priority : System.Any_Priority; - - begin - if Self_Id.Common.LL.Active_Priority > L.Ceiling then - Ceiling_Violation := True; - return; - end if; - - Saved_Priority := Self_Id.Common.LL.Active_Priority; - - if Self_Id.Common.LL.Active_Priority < L.Ceiling then - Set_Priority (Self_Id, L.Ceiling); - end if; - - Result := mutex_lock (L.L'Access); - pragma Assert (Result = 0); - Ceiling_Violation := False; - - L.Saved_Priority := Saved_Priority; - end; - - else - Result := mutex_lock (L.L'Access); - pragma Assert (Result = 0); - Ceiling_Violation := False; - end if; - - pragma Assert (Record_Lock (Lock_Ptr (L))); - end Write_Lock; - - procedure Write_Lock - (L : access RTS_Lock; - Global_Lock : Boolean := False) - is - Result : Interfaces.C.int; - - begin - if not Single_Lock or else Global_Lock then - pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); - Result := mutex_lock (L.L'Access); - pragma Assert (Result = 0); - pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); - end if; - end Write_Lock; - - procedure Write_Lock (T : Task_ID) is - Result : Interfaces.C.int; - - begin - if not Single_Lock then - pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access))); - Result := mutex_lock (T.Common.LL.L.L'Access); - pragma Assert (Result = 0); - pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access))); - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - begin - Write_Lock (L, Ceiling_Violation); - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : access Lock) is - Result : Interfaces.C.int; - - begin - pragma Assert (Check_Unlock (Lock_Ptr (L))); - - if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then - declare - Self_Id : constant Task_ID := Self; - - begin - Result := mutex_unlock (L.L'Access); - pragma Assert (Result = 0); - - if Self_Id.Common.LL.Active_Priority > L.Saved_Priority then - Set_Priority (Self_Id, L.Saved_Priority); - end if; - end; - else - Result := mutex_unlock (L.L'Access); - pragma Assert (Result = 0); - end if; - end Unlock; - - procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is - Result : Interfaces.C.int; - - begin - if not Single_Lock or else Global_Lock then - pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); - Result := mutex_unlock (L.L'Access); - pragma Assert (Result = 0); - end if; - end Unlock; - - procedure Unlock (T : Task_ID) is - Result : Interfaces.C.int; - - begin - if not Single_Lock then - pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access))); - Result := mutex_unlock (T.Common.LL.L.L'Access); - pragma Assert (Result = 0); - end if; - end Unlock; - - -- For the time delay implementation, we need to make sure we - -- achieve following criteria: - - -- 1) We have to delay at least for the amount requested. - -- 2) We have to give up CPU even though the actual delay does not - -- result in blocking. - -- 3) Except for restricted run-time systems that do not support - -- ATC or task abort, the delay must be interrupted by the - -- abort_task operation. - -- 4) The implementation has to be efficient so that the delay overhead - -- is relatively cheap. - -- (1)-(3) are Ada requirements. Even though (2) is an Annex-D - -- requirement we still want to provide the effect in all cases. - -- The reason is that users may want to use short delays to implement - -- their own scheduling effect in the absence of language provided - -- scheduling policies. - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration is - TS : aliased timespec; - Result : Interfaces.C.int; - - begin - Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); - pragma Assert (Result = 0); - return To_Duration (TS); - end Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - begin - return 10#1.0#E-6; - end RT_Resolution; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - begin - if Do_Yield then - System.OS_Interface.thr_yield; - end if; - end Yield; - - ----------- - -- Self --- - ----------- - - function Self return Task_ID renames Specific.Self; - - ------------------ - -- Set_Priority -- - ------------------ - - procedure Set_Priority - (T : Task_ID; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) - is - pragma Unreferenced (Loss_Of_Inheritance); - - Result : Interfaces.C.int; - pragma Unreferenced (Result); - - Param : aliased struct_pcparms; - - use Task_Info; - - begin - T.Common.Current_Priority := Prio; - - if Priority_Ceiling_Emulation then - T.Common.LL.Active_Priority := Prio; - end if; - - if Using_Real_Time_Class then - Param.pc_cid := Prio_Param.pc_cid; - Param.rt_pri := pri_t (Prio); - Param.rt_tqsecs := Prio_Param.rt_tqsecs; - Param.rt_tqnsecs := Prio_Param.rt_tqnsecs; - - Result := Interfaces.C.int ( - priocntl (PC_VERSION, P_LWPID, T.Common.LL.LWP, PC_SETPARMS, - Param'Address)); - - else - if T.Common.Task_Info /= null - and then not T.Common.Task_Info.Bound_To_LWP - then - -- The task is not bound to a LWP, so use thr_setprio - - Result := - thr_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio)); - - else - - -- The task is bound to a LWP, use priocntl - -- ??? TBD - - null; - end if; - end if; - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_ID) return System.Any_Priority is - begin - return T.Common.Current_Priority; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (Self_ID : Task_ID) is - Result : Interfaces.C.int; - Proc : processorid_t; -- User processor # - Last_Proc : processorid_t; -- Last processor # - - use System.Task_Info; - begin - Self_ID.Common.LL.Thread := thr_self; - - Self_ID.Common.LL.LWP := lwp_self; - - if Self_ID.Common.Task_Info /= null then - if Self_ID.Common.Task_Info.New_LWP - and then Self_ID.Common.Task_Info.CPU /= CPU_UNCHANGED - then - Last_Proc := Num_Procs - 1; - - if Self_ID.Common.Task_Info.CPU = ANY_CPU then - Result := 0; - Proc := 0; - - while Proc < Last_Proc loop - Result := p_online (Proc, PR_STATUS); - exit when Result = PR_ONLINE; - Proc := Proc + 1; - end loop; - - Result := processor_bind (P_LWPID, P_MYID, Proc, null); - pragma Assert (Result = 0); - - else - -- Use specified processor - - if Self_ID.Common.Task_Info.CPU < 0 - or else Self_ID.Common.Task_Info.CPU > Last_Proc - then - raise Invalid_CPU_Number; - end if; - - Result := processor_bind - (P_LWPID, P_MYID, Self_ID.Common.Task_Info.CPU, null); - pragma Assert (Result = 0); - end if; - end if; - end if; - - Specific.Set (Self_ID); - - -- We need the above code even if we do direct fetch of Task_ID in Self - -- for the main task on Sun, x86 Solaris and for gcc 2.7.2. - - Lock_RTS; - - for J in Known_Tasks'Range loop - if Known_Tasks (J) = null then - Known_Tasks (J) := Self_ID; - Self_ID.Known_Tasks_Index := J; - exit; - end if; - end loop; - - Unlock_RTS; - end Enter_Task; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_ID is - begin - if Is_Valid_Task then - return Self; - else - return Register_Foreign_Thread (thr_self); - end if; - end Register_Foreign_Thread; - - -------------------- - -- Initialize_TCB -- - -------------------- - - procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is - Result : Interfaces.C.int := 0; - - begin - -- Give the task a unique serial number. - - Self_ID.Serial_Number := Next_Serial_Number; - Next_Serial_Number := Next_Serial_Number + 1; - pragma Assert (Next_Serial_Number /= 0); - - Self_ID.Common.LL.Thread := To_thread_t (-1); - - if not Single_Lock then - Result := mutex_init - (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address); - Self_ID.Common.LL.L.Level := - Private_Task_Serial_Number (Self_ID.Serial_Number); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result = 0 then - Result := cond_init (Self_ID.Common.LL.CV'Access, USYNC_THREAD, 0); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result = 0 then - Succeeded := True; - else - if not Single_Lock then - Result := mutex_destroy (Self_ID.Common.LL.L.L'Access); - pragma Assert (Result = 0); - end if; - - Succeeded := False; - end if; - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_ID; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - pragma Unreferenced (Priority); - - Result : Interfaces.C.int; - Adjusted_Stack_Size : Interfaces.C.size_t; - Opts : Interfaces.C.int := THR_DETACHED; - - Page_Size : constant System.Parameters.Size_Type := 4096; - -- This constant is for reserving extra space at the - -- end of the stack, which can be used by the stack - -- checking as guard page. The idea is that we need - -- to have at least Stack_Size bytes available for - -- actual use. - - use System.Task_Info; - - begin - if Stack_Size = System.Parameters.Unspecified_Size then - Adjusted_Stack_Size := - Interfaces.C.size_t (Default_Stack_Size + Page_Size); - - elsif Stack_Size < Minimum_Stack_Size then - Adjusted_Stack_Size := - Interfaces.C.size_t (Minimum_Stack_Size + Page_Size); - - else - Adjusted_Stack_Size := - Interfaces.C.size_t (Stack_Size + Page_Size); - end if; - - -- Since the initial signal mask of a thread is inherited from the - -- creator, and the Environment task has all its signals masked, we - -- do not need to manipulate caller's signal mask at this point. - -- All tasks in RTS will have All_Tasks_Mask initially. - - if T.Common.Task_Info /= null then - if T.Common.Task_Info.New_LWP then - Opts := Opts + THR_NEW_LWP; - end if; - - if T.Common.Task_Info.Bound_To_LWP then - Opts := Opts + THR_BOUND; - end if; - - else - Opts := THR_DETACHED + THR_BOUND; - end if; - - Result := thr_create - (System.Null_Address, - Adjusted_Stack_Size, - Thread_Body_Access (Wrapper), - To_Address (T), - Opts, - T.Common.LL.Thread'Access); - - Succeeded := Result = 0; - pragma Assert - (Result = 0 - or else Result = ENOMEM - or else Result = EAGAIN); - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_ID) is - Result : Interfaces.C.int; - Tmp : Task_ID := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); - - begin - T.Common.LL.Thread := To_thread_t (0); - - if not Single_Lock then - Result := mutex_destroy (T.Common.LL.L.L'Access); - pragma Assert (Result = 0); - end if; - - Result := cond_destroy (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - -- This procedure must be called with abort deferred. - -- It can no longer call Self or access - -- the current task's ATCB, since the ATCB has been deallocated. - - procedure Exit_Task is - begin - Specific.Set (null); - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_ID) is - Result : Interfaces.C.int; - begin - pragma Assert (T /= Self); - - Result := thr_kill (T.Common.LL.Thread, - Signal (System.Interrupt_Management.Abort_Task_Interrupt)); - null; - - pragma Assert (Result = 0); - end Abort_Task; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : Task_ID; - Reason : Task_States) - is - Result : Interfaces.C.int; - - begin - pragma Assert (Check_Sleep (Reason)); - - if Dynamic_Priority_Support - and then Self_ID.Pending_Priority_Change - then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - - if Single_Lock then - Result := cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access); - else - Result := cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access); - end if; - - pragma Assert (Record_Wakeup - (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason)); - pragma Assert (Result = 0 or else Result = EINTR); - end Sleep; - - -- Note that we are relying heaviliy here on the GNAT feature - -- that Calendar.Time, System.Real_Time.Time, Duration, and - -- System.Real_Time.Time_Span are all represented in the same - -- way, i.e., as a 64-bit count of nanoseconds. - - -- This allows us to always pass the timeout value as a Duration. - - -- ??? - -- We are taking liberties here with the semantics of the delays. - -- That is, we make no distinction between delays on the Calendar clock - -- and delays on the Real_Time clock. That is technically incorrect, if - -- the Calendar clock happens to be reset or adjusted. - -- To solve this defect will require modification to the compiler - -- interface, so that it can pass through more information, to tell - -- us here which clock to use! - - -- cond_timedwait will return if any of the following happens: - -- 1) some other task did cond_signal on this condition variable - -- In this case, the return value is 0 - -- 2) the call just returned, for no good reason - -- This is called a "spurious wakeup". - -- In this case, the return value may also be 0. - -- 3) the time delay expires - -- In this case, the return value is ETIME - -- 4) this task received a signal, which was handled by some - -- handler procedure, and now the thread is resuming execution - -- UNIX calls this an "interrupted" system call. - -- In this case, the return value is EINTR - - -- If the cond_timedwait returns 0 or EINTR, it is still - -- possible that the time has actually expired, and by chance - -- a signal or cond_signal occurred at around the same time. - - -- We have also observed that on some OS's the value ETIME - -- will be returned, but the clock will show that the full delay - -- has not yet expired. - - -- For these reasons, we need to check the clock after return - -- from cond_timedwait. If the time has expired, we will set - -- Timedout = True. - - -- This check might be omitted for systems on which the - -- cond_timedwait() never returns early or wakes up spuriously. - - -- Annex D requires that completion of a delay cause the task - -- to go to the end of its priority queue, regardless of whether - -- the task actually was suspended by the delay. Since - -- cond_timedwait does not do this on Solaris, we add a call - -- to thr_yield at the end. We might do this at the beginning, - -- instead, but then the round-robin effect would not be the - -- same; the delayed task would be ahead of other tasks of the - -- same priority that awoke while it was sleeping. - - -- For Timed_Sleep, we are expecting possible cond_signals - -- to indicate other events (e.g., completion of a RV or - -- completion of the abortable part of an async. select), - -- we want to always return if interrupted. The caller will - -- be responsible for checking the task state to see whether - -- the wakeup was spurious, and to go back to sleep again - -- in that case. We don't need to check for pending abort - -- or priority change on the way in our out; that is the - -- caller's responsibility. - - -- For Timed_Delay, we are not expecting any cond_signals or - -- other interruptions, except for priority changes and aborts. - -- Therefore, we don't want to return unless the delay has - -- actually expired, or the call has been aborted. In this - -- case, since we want to implement the entire delay statement - -- semantics, we do need to check for pending abort and priority - -- changes. We can quietly handle priority changes inside the - -- procedure, since there is no entry-queue reordering involved. - - ----------------- - -- Timed_Sleep -- - ----------------- - - procedure Timed_Sleep - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : System.Tasking.Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - pragma Assert (Check_Sleep (Reason)); - Timedout := True; - Yielded := False; - - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; - - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); - - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else (Dynamic_Priority_Support and then - Self_ID.Pending_Priority_Change); - - if Single_Lock then - Result := cond_timedwait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock.L'Access, Request'Access); - else - Result := cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L.L'Access, Request'Access); - end if; - - Yielded := True; - - exit when Abs_Time <= Monotonic_Clock; - - if Result = 0 or Result = EINTR then - - -- Somebody may have called Wakeup for us - - Timedout := False; - exit; - end if; - - pragma Assert (Result = ETIME); - end loop; - end if; - - pragma Assert (Record_Wakeup - (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason)); - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes) - is - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - Yielded : Boolean := False; - - begin - -- Only the little window between deferring abort and - -- locking Self_ID is the reason we need to - -- check for pending abort and priority change below! - - SSL.Abort_Defer.all; - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - - if Mode = Relative then - Abs_Time := Time + Check_Time; - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - end if; - - if Abs_Time > Check_Time then - Request := To_Timespec (Abs_Time); - Self_ID.Common.State := Delay_Sleep; - - pragma Assert (Check_Sleep (Delay_Sleep)); - - loop - if Dynamic_Priority_Support and then - Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - if Single_Lock then - Result := cond_timedwait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock.L'Access, Request'Access); - else - Result := cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L.L'Access, Request'Access); - end if; - - Yielded := True; - - exit when Abs_Time <= Monotonic_Clock; - - pragma Assert (Result = 0 or else - Result = ETIME or else - Result = EINTR); - end loop; - - pragma Assert (Record_Wakeup - (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Delay_Sleep)); - - Self_ID.Common.State := Runnable; - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - if not Yielded then - thr_yield; - end if; - - SSL.Abort_Undefer.all; - end Timed_Delay; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup - (T : Task_ID; - Reason : Task_States) - is - Result : Interfaces.C.int; - - begin - pragma Assert (Check_Wakeup (T, Reason)); - Result := cond_signal (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Wakeup; - - --------------------------- - -- Check_Initialize_Lock -- - --------------------------- - - -- The following code is intended to check some of the invariant - -- assertions related to lock usage, on which we depend. - - function Check_Initialize_Lock - (L : Lock_Ptr; - Level : Lock_Level) return Boolean - is - Self_ID : constant Task_ID := Self; - - begin - -- Check that caller is abort-deferred - - if Self_ID.Deferral_Level <= 0 then - return False; - end if; - - -- Check that the lock is not yet initialized - - if L.Level /= 0 then - return False; - end if; - - L.Level := Lock_Level'Pos (Level) + 1; - return True; - end Check_Initialize_Lock; - - ---------------- - -- Check_Lock -- - ---------------- - - function Check_Lock (L : Lock_Ptr) return Boolean is - Self_ID : constant Task_ID := Self; - P : Lock_Ptr; - - begin - -- Check that the argument is not null - - if L = null then - return False; - end if; - - -- Check that L is not frozen - - if L.Frozen then - return False; - end if; - - -- Check that caller is abort-deferred - - if Self_ID.Deferral_Level <= 0 then - return False; - end if; - - -- Check that caller is not holding this lock already - - if L.Owner = To_Owner_ID (To_Address (Self_ID)) then - return False; - end if; - - if Single_Lock then - return True; - end if; - - -- Check that TCB lock order rules are satisfied - - P := Self_ID.Common.LL.Locks; - if P /= null then - if P.Level >= L.Level - and then (P.Level > 2 or else L.Level > 2) - then - return False; - end if; - end if; - - return True; - end Check_Lock; - - ----------------- - -- Record_Lock -- - ----------------- - - function Record_Lock (L : Lock_Ptr) return Boolean is - Self_ID : constant Task_ID := Self; - P : Lock_Ptr; - - begin - Lock_Count := Lock_Count + 1; - - -- There should be no owner for this lock at this point - - if L.Owner /= null then - return False; - end if; - - -- Record new owner - - L.Owner := To_Owner_ID (To_Address (Self_ID)); - - if Single_Lock then - return True; - end if; - - -- Check that TCB lock order rules are satisfied - - P := Self_ID.Common.LL.Locks; - - if P /= null then - L.Next := P; - end if; - - Self_ID.Common.LL.Locking := null; - Self_ID.Common.LL.Locks := L; - return True; - end Record_Lock; - - ----------------- - -- Check_Sleep -- - ----------------- - - function Check_Sleep (Reason : Task_States) return Boolean is - pragma Unreferenced (Reason); - - Self_ID : constant Task_ID := Self; - P : Lock_Ptr; - - begin - -- Check that caller is abort-deferred - - if Self_ID.Deferral_Level <= 0 then - return False; - end if; - - if Single_Lock then - return True; - end if; - - -- Check that caller is holding own lock, on top of list - - if Self_ID.Common.LL.Locks /= - To_Lock_Ptr (Self_ID.Common.LL.L'Access) - then - return False; - end if; - - -- Check that TCB lock order rules are satisfied - - if Self_ID.Common.LL.Locks.Next /= null then - return False; - end if; - - Self_ID.Common.LL.L.Owner := null; - P := Self_ID.Common.LL.Locks; - Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next; - P.Next := null; - return True; - end Check_Sleep; - - ------------------- - -- Record_Wakeup -- - ------------------- - - function Record_Wakeup - (L : Lock_Ptr; - Reason : Task_States) return Boolean - is - pragma Unreferenced (Reason); - - Self_ID : constant Task_ID := Self; - P : Lock_Ptr; - - begin - -- Record new owner - - L.Owner := To_Owner_ID (To_Address (Self_ID)); - - if Single_Lock then - return True; - end if; - - -- Check that TCB lock order rules are satisfied - - P := Self_ID.Common.LL.Locks; - - if P /= null then - L.Next := P; - end if; - - Self_ID.Common.LL.Locking := null; - Self_ID.Common.LL.Locks := L; - return True; - end Record_Wakeup; - - ------------------ - -- Check_Wakeup -- - ------------------ - - function Check_Wakeup - (T : Task_ID; - Reason : Task_States) return Boolean - is - Self_ID : constant Task_ID := Self; - - begin - -- Is caller holding T's lock? - - if T.Common.LL.L.Owner /= To_Owner_ID (To_Address (Self_ID)) then - return False; - end if; - - -- Are reasons for wakeup and sleep consistent? - - if T.Common.State /= Reason then - return False; - end if; - - return True; - end Check_Wakeup; - - ------------------ - -- Check_Unlock -- - ------------------ - - function Check_Unlock (L : Lock_Ptr) return Boolean is - Self_ID : constant Task_ID := Self; - P : Lock_Ptr; - - begin - Unlock_Count := Unlock_Count + 1; - - if L = null then - return False; - end if; - - if L.Buddy /= null then - return False; - end if; - - if L.Level = 4 then - Check_Count := Unlock_Count; - end if; - - if Unlock_Count - Check_Count > 1000 then - Check_Count := Unlock_Count; - end if; - - -- Check that caller is abort-deferred - - if Self_ID.Deferral_Level <= 0 then - return False; - end if; - - -- Check that caller is holding this lock, on top of list - - if Self_ID.Common.LL.Locks /= L then - return False; - end if; - - -- Record there is no owner now - - L.Owner := null; - P := Self_ID.Common.LL.Locks; - Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next; - P.Next := null; - return True; - end Check_Unlock; - - -------------------- - -- Check_Finalize -- - -------------------- - - function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is - Self_ID : constant Task_ID := Self; - - begin - -- Check that caller is abort-deferred - - if Self_ID.Deferral_Level <= 0 then - return False; - end if; - - -- Check that no one is holding this lock - - if L.Owner /= null then - return False; - end if; - - L.Frozen := True; - return True; - end Check_Finalize_Lock; - - ---------------- - -- Check_Exit -- - ---------------- - - function Check_Exit (Self_ID : Task_ID) return Boolean is - begin - -- Check that caller is just holding Global_Task_Lock - -- and no other locks - - if Self_ID.Common.LL.Locks = null then - return False; - end if; - - -- 2 = Global_Task_Level - - if Self_ID.Common.LL.Locks.Level /= 2 then - return False; - end if; - - if Self_ID.Common.LL.Locks.Next /= null then - return False; - end if; - - -- Check that caller is abort-deferred - - if Self_ID.Deferral_Level <= 0 then - return False; - end if; - - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : Task_ID) return Boolean is - begin - return Self_ID.Common.LL.Locks = null; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_ID is - begin - return Environment_Task_ID; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) return Boolean - is - begin - if T.Common.LL.Thread /= Thread_Self then - return thr_suspend (T.Common.LL.Thread) = 0; - else - return True; - end if; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) return Boolean - is - begin - if T.Common.LL.Thread /= Thread_Self then - return thr_continue (T.Common.LL.Thread) = 0; - else - return True; - end if; - end Resume_Task; - --- Package elaboration - -begin - declare - Result : Interfaces.C.int; - - begin - -- Mask Environment task for all signals. The original mask of the - -- Environment task will be recovered by Interrupt_Server task - -- during the elaboration of s-interr.adb. - - System.Interrupt_Management.Operations.Set_Interrupt_Mask - (System.Interrupt_Management.Operations.All_Tasks_Mask'Access); - - -- Prepare the set of signals that should unblocked in all tasks - - Result := sigemptyset (Unblocked_Signal_Mask'Access); - pragma Assert (Result = 0); - - for J in Interrupt_Management.Interrupt_ID loop - if System.Interrupt_Management.Keep_Unmasked (J) then - Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); - pragma Assert (Result = 0); - end if; - end loop; - - -- We need the following code to support automatic creation of fake - -- ATCB's for C threads that call the Ada run-time system, even if - -- we use a faster way of getting Self for real Ada tasks. - - Result := thr_keycreate (ATCB_Key'Access, System.Null_Address); - pragma Assert (Result = 0); - end; - - if Dispatching_Policy = 'F' then - declare - Result : Interfaces.C.long; - Class_Info : aliased struct_pcinfo; - Secs, Nsecs : Interfaces.C.long; - - begin - -- If a pragma Time_Slice is specified, takes the value in account. - - if Time_Slice_Val > 0 then - -- Convert Time_Slice_Val (microseconds) into seconds and - -- nanoseconds - - Secs := Time_Slice_Val / 1_000_000; - Nsecs := (Time_Slice_Val rem 1_000_000) * 1_000; - - -- Otherwise, default to no time slicing (i.e run until blocked) - - else - Secs := RT_TQINF; - Nsecs := RT_TQINF; - end if; - - -- Get the real time class id. - - Class_Info.pc_clname (1) := 'R'; - Class_Info.pc_clname (2) := 'T'; - Class_Info.pc_clname (3) := ASCII.NUL; - - Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_GETCID, - Class_Info'Address); - - -- Request the real time class - - Prio_Param.pc_cid := Class_Info.pc_cid; - Prio_Param.rt_pri := pri_t (Class_Info.rt_maxpri); - Prio_Param.rt_tqsecs := Secs; - Prio_Param.rt_tqnsecs := Nsecs; - - Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS, - Prio_Param'Address); - - Using_Real_Time_Class := Result /= -1; - end; - end if; -end System.Task_Primitives.Operations; diff --git a/gcc/ada/5stasinf.adb b/gcc/ada/5stasinf.adb deleted file mode 100644 index 859bcd082ec..00000000000 --- a/gcc/ada/5stasinf.adb +++ /dev/null @@ -1,73 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T A S K _ I N F O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2002 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 body contains the routines associated with the implementation --- of the Task_Info pragma. - --- This is the Solaris (native) version of this module. - -package body System.Task_Info is - - function Unbound_Thread_Attributes return Thread_Attributes is - begin - return (False, False); - end Unbound_Thread_Attributes; - - function Bound_Thread_Attributes return Thread_Attributes is - begin - return (False, True); - end Bound_Thread_Attributes; - - function Bound_Thread_Attributes (CPU : CPU_Number) - return Thread_Attributes is - begin - return (True, True, CPU); - end Bound_Thread_Attributes; - - function New_Unbound_Thread_Attributes return Task_Info_Type is - begin - return new Thread_Attributes'(False, False); - end New_Unbound_Thread_Attributes; - - function New_Bound_Thread_Attributes return Task_Info_Type is - begin - return new Thread_Attributes'(False, True); - end New_Bound_Thread_Attributes; - - function New_Bound_Thread_Attributes (CPU : CPU_Number) - return Task_Info_Type is - begin - return new Thread_Attributes'(True, True, CPU); - end New_Bound_Thread_Attributes; - -end System.Task_Info; diff --git a/gcc/ada/5stasinf.ads b/gcc/ada/5stasinf.ads deleted file mode 100644 index ded456effa1..00000000000 --- a/gcc/ada/5stasinf.ads +++ /dev/null @@ -1,142 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T A S K _ I N F O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2003 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 contains the definitions and routines associated with the --- implementation and use of the Task_Info pragma. It is specialized --- appropriately for targets that make use of this pragma. - --- Note: the compiler generates direct calls to this interface, via Rtsfind. --- Any changes to this interface may require corresponding compiler changes. - --- This unit may be used directly from an application program by providing --- an appropriate WITH, and the interface can be expected to remain stable. - --- This is the Solaris (native) version of this module. - -with System.OS_Interface; - -package System.Task_Info is - pragma Elaborate_Body; - -- To ensure that a body is allowed - - ----------------------------------------------------- - -- Binding of Tasks to LWPs and LWPs to processors -- - ----------------------------------------------------- - - -- The Solaris implementation of the GNU Low-Level Interface (GNULLI) - -- implements each Ada task as a Solaris thread. The Solaris thread - -- library distributes threads across one or more LWPs (Light Weight - -- Process) that are members of the same process. Solaris distributes - -- processes and LWPs across the available CPUs on a given machine. The - -- pragma Task_Info provides the mechanism to control the distribution - -- of tasks to LWPs, and LWPs to processors. - - -- Each thread has a number of attributes that dictate it's scheduling. - -- These attributes are: - -- - -- New_LWP: whether a new LWP is created for this thread. - -- - -- Bound_To_LWP: whether the thread is bound to a specific LWP - -- for its entire lifetime. - -- - -- CPU: the CPU number associated to the LWP - -- - - -- The Task_Info pragma: - - -- pragma Task_Info (EXPRESSION); - - -- allows the specification on a task by task basis of a value of type - -- System.Task_Info.Task_Info_Type to be passed to a task when it is - -- created. The specification of this type, and the effect on the task - -- that is created is target dependent. - - -- The Task_Info pragma appears within a task definition (compare the - -- definition and implementation of pragma Priority). If no such pragma - -- appears, then the value Task_Info_Unspecified is passed. If a pragma - -- is present, then it supplies an alternative value. If the argument of - -- the pragma is a discriminant reference, then the value can be set on - -- a task by task basis by supplying the appropriate discriminant value. - - -- Note that this means that the type used for Task_Info_Type must be - -- suitable for use as a discriminant (i.e. a scalar or access type). - - ----------------------- - -- Thread Attributes -- - ----------------------- - - subtype CPU_Number is System.OS_Interface.processorid_t; - - CPU_UNCHANGED : constant CPU_Number := System.OS_Interface.PBIND_QUERY; - -- Do not bind the LWP to a specific processor - - ANY_CPU : constant CPU_Number := System.OS_Interface.PBIND_NONE; - -- Bind the LWP to any processor - - Invalid_CPU_Number : exception; - - type Thread_Attributes (New_LWP : Boolean) is record - Bound_To_LWP : Boolean := True; - case New_LWP is - when False => - null; - when True => - CPU : CPU_Number := CPU_UNCHANGED; - end case; - end record; - - Default_Thread_Attributes : constant Thread_Attributes := (False, True); - - function Unbound_Thread_Attributes - return Thread_Attributes; - - function Bound_Thread_Attributes - return Thread_Attributes; - - function Bound_Thread_Attributes (CPU : CPU_Number) - return Thread_Attributes; - - type Task_Info_Type is access all Thread_Attributes; - - function New_Unbound_Thread_Attributes - return Task_Info_Type; - - function New_Bound_Thread_Attributes - return Task_Info_Type; - - function New_Bound_Thread_Attributes (CPU : CPU_Number) - return Task_Info_Type; - - Unspecified_Task_Info : constant Task_Info_Type := null; - -end System.Task_Info; diff --git a/gcc/ada/5staspri.ads b/gcc/ada/5staspri.ads deleted file mode 100644 index 335079b7cec..00000000000 --- a/gcc/ada/5staspri.ads +++ /dev/null @@ -1,130 +0,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) 1992-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 a Solaris version of this package - --- This package provides low-level support for most tasking features. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with System.OS_Interface; --- used for mutex_t --- cond_t --- thread_t - -with Unchecked_Conversion; - -package System.Task_Primitives is - pragma Preelaborate; - - type Lock is limited private; - type Lock_Ptr is access all Lock; - -- Should be used for implementation of protected objects - - type RTS_Lock is limited private; - type RTS_Lock_Ptr is access all RTS_Lock; - -- 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. - - function To_Lock_Ptr is new Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr); - - 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 Private_Task_Serial_Number is mod 2 ** 64; - -- Used to give each task a unique serial number. - - type Base_Lock is new System.OS_Interface.mutex_t; - - type Owner_Int is new Integer; - for Owner_Int'Alignment use Standard'Maximum_Alignment; - - type Owner_ID is access all Owner_Int; - - function To_Owner_ID is - new Unchecked_Conversion (System.Address, Owner_ID); - - type Lock is record - L : aliased Base_Lock; - Ceiling : System.Any_Priority := System.Any_Priority'First; - Saved_Priority : System.Any_Priority := System.Any_Priority'First; - Owner : Owner_ID; - Next : Lock_Ptr; - Level : Private_Task_Serial_Number := 0; - Buddy : Owner_ID; - Frozen : Boolean := False; - end record; - - type RTS_Lock is new Lock; - - -- Note that task support on gdb relies on the fact that the first - -- 2 fields of Private_Data are Thread and LWP. - - type Private_Data is record - Thread : aliased System.OS_Interface.thread_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 : System.OS_Interface.lwpid_t; - -- The LWP id of the thread. Set by self in Enter_Task. - - CV : aliased System.OS_Interface.cond_t; - L : aliased RTS_Lock; - -- Protection for all components is lock L - - Active_Priority : System.Any_Priority := System.Any_Priority'First; - -- Simulated active priority, - -- used only if Priority_Ceiling_Support is True. - - Locking : Lock_Ptr; - Locks : Lock_Ptr; - Wakeups : Natural := 0; - end record; - -end System.Task_Primitives; diff --git a/gcc/ada/5stpopsp.adb b/gcc/ada/5stpopsp.adb deleted file mode 100644 index eb32dd2cb81..00000000000 --- a/gcc/ada/5stpopsp.adb +++ /dev/null @@ -1,107 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- --- -- --- 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 a version for Solaris native threads - -separate (System.Task_Primitives.Operations) -package body Specific is - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_ID) is - Result : Interfaces.C.int; - begin - Result := thr_setspecific (ATCB_Key, To_Address (Environment_Task)); - pragma Assert (Result = 0); - end Initialize; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean is - Unknown_Task : aliased System.Address; - Result : Interfaces.C.int; - begin - Result := thr_getspecific (ATCB_Key, Unknown_Task'Unchecked_Access); - pragma Assert (Result = 0); - return Unknown_Task /= System.Null_Address; - end Is_Valid_Task; - - --------- - -- Set -- - --------- - - procedure Set (Self_Id : Task_ID) is - Result : Interfaces.C.int; - begin - Result := thr_setspecific (ATCB_Key, To_Address (Self_Id)); - pragma Assert (Result = 0); - end Set; - - ---------- - -- Self -- - ---------- - - -- To make Ada tasks and C threads interoperate better, we have - -- added some functionality to Self. Suppose a C main program - -- (with threads) calls an Ada procedure and the Ada procedure - -- calls the tasking run-time system. Eventually, a call will be - -- made to self. Since the call is not coming from an Ada task, - -- there will be no corresponding ATCB. - - -- What we do in Self is to catch references that do not come - -- from recognized Ada tasks, and create an ATCB for the calling - -- thread. - - -- The new ATCB will be "detached" from the normal Ada task - -- master hierarchy, much like the existing implicitly created - -- signal-server tasks. - - function Self return Task_ID is - Result : Interfaces.C.int; - Self_Id : aliased System.Address; - begin - Result := thr_getspecific (ATCB_Key, Self_Id'Unchecked_Access); - pragma Assert (Result = 0); - - if Self_Id = System.Null_Address then - return Register_Foreign_Thread; - else - return To_Task_ID (Self_Id); - end if; - end Self; - -end Specific; diff --git a/gcc/ada/5svxwork.ads b/gcc/ada/5svxwork.ads deleted file mode 100644 index 4fc9fd156e3..00000000000 --- a/gcc/ada/5svxwork.ads +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . V X W O R K S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-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 the Sparc64 VxWorks version of this package. - -with Interfaces; - -package System.VxWorks is - pragma Preelaborate (System.VxWorks); - - -- Floating point context record. SPARCV9 version - - FP_NUM_DREGS : constant := 32; - - type RType is new Interfaces.Unsigned_64; - for RType'Alignment use 8; - - type Fpd_Array is array (1 .. FP_NUM_DREGS) of RType; - for Fpd_Array'Alignment use 8; - - type FP_CONTEXT is record - fpd : Fpd_Array; - fsr : RType; - end record; - - for FP_CONTEXT'Alignment use 8; - pragma Convention (C, FP_CONTEXT); - - Num_HW_Interrupts : constant := 256; - -- Number of entries in hardware interrupt vector table. - -end System.VxWorks; diff --git a/gcc/ada/5tosinte.ads b/gcc/ada/5tosinte.ads deleted file mode 100644 index 14caf4e3ddd..00000000000 --- a/gcc/ada/5tosinte.ads +++ /dev/null @@ -1,667 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 a Solaris (FSU THREADS) version of this package - --- This package includes all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("-lgthreads"); - pragma Linker_Options ("-lmalloc"); - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EAGAIN : constant := 11; - EINTR : constant := 4; - EINVAL : constant := 22; - ENOMEM : constant := 12; - ETIMEDOUT : constant := 145; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 45; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGHUP : constant := 1; -- hangup - SIGINT : constant := 2; -- interrupt (rubout) - SIGQUIT : constant := 3; -- quit (ASCD FS) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGTRAP : constant := 5; -- trace trap (not reset) - SIGIOT : constant := 6; -- IOT instruction - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGEMT : constant := 7; -- EMT instruction - SIGFPE : constant := 8; -- floating point exception - SIGKILL : constant := 9; -- kill (cannot be caught or ignored) - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - SIGSYS : constant := 12; -- bad argument to system call - SIGPIPE : constant := 13; -- write on a pipe with no one to read it - SIGALRM : constant := 14; -- alarm clock - SIGTERM : constant := 15; -- software termination signal from kill - SIGUSR1 : constant := 16; -- user defined signal 1 - SIGUSR2 : constant := 17; -- user defined signal 2 - SIGCLD : constant := 18; -- alias for SIGCHLD - SIGCHLD : constant := 18; -- child status change - SIGPWR : constant := 19; -- power-fail restart - SIGWINCH : constant := 20; -- window size change - SIGURG : constant := 21; -- urgent condition on IO channel - SIGPOLL : constant := 22; -- pollable event occurred - SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias) - SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) - SIGTSTP : constant := 24; -- user stop requested from tty - SIGCONT : constant := 25; -- stopped process has been continued - SIGTTIN : constant := 26; -- background tty read attempted - SIGTTOU : constant := 27; -- background tty write attempted - SIGVTALRM : constant := 28; -- virtual timer expired - SIGPROF : constant := 29; -- profiling timer expired - SIGXCPU : constant := 30; -- CPU time limit exceeded - SIGXFSZ : constant := 31; -- filesize limit exceeded - SIGWAITING : constant := 32; -- process's lwps blocked (Solaris) - SIGLWP : constant := 33; -- used by thread library (Solaris) - SIGFREEZE : constant := 34; -- used by CPR (Solaris) - SIGTHAW : constant := 35; -- used by CPR (Solaris) - SIGCANCEL : constant := 36; -- used for thread cancel (Solaris) - SIGRTMIN : constant := 38; -- first (highest-priority) realtime signal - SIGRTMAX : constant := 45; -- last (lowest-priority) realtime signal - - type Signal_Set is array (Natural range <>) of Signal; - - Unmasked : constant Signal_Set := - (SIGTRAP, SIGLWP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); - - Reserved : constant Signal_Set := - (SIGKILL, SIGSTOP, SIGALRM, SIGVTALRM, SIGWAITING, SIGRTMAX); - - type sigset_t is private; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - type union_type_3 is new String (1 .. 116); - type siginfo_t is record - si_signo : int; - si_code : int; - si_errno : int; - X_data : union_type_3; - end record; - pragma Convention (C, siginfo_t); - - -- The types mcontext_t and gregset_t are part of the ucontext_t - -- information, which is specific to Solaris2.4 for SPARC - -- The ucontext_t info seems to be used by the handler - -- for SIGSEGV to decide whether it is a Storage_Error (stack overflow) or - -- a Constraint_Error (bad pointer). The original code that did this - -- is suspect, so it is not clear whether we really need this part of - -- the signal context information, or perhaps something else. - -- More analysis is needed, after which these declarations may need to - -- be changed. - - EMT_TAGOVF : constant := 1; -- tag overflow - FPE_INTDIV : constant := 1; -- integer divide by zero - FPE_INTOVF : constant := 2; -- integer overflow - FPE_FLTDIV : constant := 3; -- floating point divide by zero - FPE_FLTOVF : constant := 4; -- floating point overflow - FPE_FLTUND : constant := 5; -- floating point underflow - FPE_FLTRES : constant := 6; -- floating point inexact result - FPE_FLTINV : constant := 7; -- invalid floating point operation - FPE_FLTSUB : constant := 8; -- subscript out of range - - SEGV_MAPERR : constant := 1; -- address not mapped to object - SEGV_ACCERR : constant := 2; -- invalid permissions - - BUS_ADRALN : constant := 1; -- invalid address alignment - BUS_ADRERR : constant := 2; -- non-existent physical address - BUS_OBJERR : constant := 3; -- object specific hardware error - - ILL_ILLOPC : constant := 1; -- illegal opcode - ILL_ILLOPN : constant := 2; -- illegal operand - ILL_ILLADR : constant := 3; -- illegal addressing mode - ILL_ILLTRP : constant := 4; -- illegal trap - ILL_PRVOPC : constant := 5; -- privileged opcode - ILL_PRVREG : constant := 6; -- privileged register - ILL_COPROC : constant := 7; -- co-processor - ILL_BADSTK : constant := 8; -- bad stack - - type greg_t is new int; - - type gregset_t is array (Integer range 0 .. 18) of greg_t; - - REG_O0 : constant := 11; - -- index of saved register O0 in ucontext.uc_mcontext.gregs array - - type union_type_2 is new String (1 .. 128); - type record_type_1 is record - fpu_fr : union_type_2; - fpu_q : System.Address; - fpu_fsr : unsigned; - fpu_qcnt : unsigned_char; - fpu_q_entrysize : unsigned_char; - fpu_en : unsigned_char; - end record; - pragma Convention (C, record_type_1); - type array_type_7 is array (Integer range 0 .. 20) of long; - type mcontext_t is record - gregs : gregset_t; - gwins : System.Address; - fpregs : record_type_1; - filler : array_type_7; - end record; - pragma Convention (C, mcontext_t); - - type record_type_2 is record - ss_sp : System.Address; - ss_size : int; - ss_flags : int; - end record; - pragma Convention (C, record_type_2); - type array_type_8 is array (Integer range 0 .. 22) of long; - type ucontext_t is record - uc_flags : unsigned_long; - uc_link : System.Address; - uc_sigmask : sigset_t; - uc_stack : record_type_2; - uc_mcontext : mcontext_t; - uc_filler : array_type_8; - end record; - pragma Convention (C, ucontext_t); - - type Signal_Handler is access procedure - (signo : Signal; - info : access siginfo_t; - context : access ucontext_t); - - type union_type_1 is new plain_char; - type array_type_2 is array (Integer range 0 .. 1) of int; - type struct_sigaction is record - sa_flags : int; - sa_handler : System.Address; - sa_mask : sigset_t; - sa_resv : array_type_2; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - SA_SIGINFO : constant := 16#08#; - - SIG_BLOCK : constant := 1; - SIG_UNBLOCK : constant := 2; - SIG_SETMASK : constant := 3; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - ---------- - -- Time -- - ---------- - - Time_Slice_Supported : constant Boolean := False; - -- Indicates wether time slicing is supported (i.e FSU threads have been - -- compiled with DEF_RR) - - type timespec is private; - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; - - function clock_gettime - (clock_id : clockid_t; - tp : access timespec) return int; - pragma Import (C, clock_gettime, "clock_gettime"); - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - type struct_timeval is private; - - function To_Duration (TV : struct_timeval) return Duration; - pragma Inline (To_Duration); - - function To_Timeval (D : Duration) return struct_timeval; - pragma Inline (To_Timeval); - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 0; - SCHED_RR : constant := 1; - SCHED_OTHER : constant := 2; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - function getpid return pid_t; - pragma Import (C, getpid, "getpid"); - - --------- - -- LWP -- - --------- - - function lwp_self return System.Address; - -- lwp_self does not exist on this thread library, revert to pthread_self - -- which is the closest approximation (with getpid). This function is - -- needed to share 7staprop.adb across POSIX-like targets. - pragma Import (C, lwp_self, "pthread_self"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_DETACHED : constant := 1; - - ----------- - -- Stack -- - ----------- - - Stack_Base_Available : constant Boolean := False; - -- Indicates wether the stack base is available on this target. - -- This allows us to share s-osinte.adb between all the FSU run time. - -- Note that this value can only be true if pthread_t has a complete - -- definition that corresponds exactly to the C header files. - - function Get_Stack_Base (thread : pthread_t) return Address; - pragma Inline (Get_Stack_Base); - -- returns the stack base of the specified thread. - -- Only call this function when Stack_Base_Available is True. - - function Get_Page_Size return size_t; - function Get_Page_Size return Address; - pragma Import (C, Get_Page_Size, "getpagesize"); - -- returns the size of a page, or 0 if this is not relevant on this - -- target - - PROT_NONE : constant := 0; - PROT_READ : constant := 1; - PROT_WRITE : constant := 2; - PROT_EXEC : constant := 4; - PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; - - PROT_ON : constant := PROT_NONE; - PROT_OFF : constant := PROT_ALL; - - function mprotect (addr : Address; len : size_t; prot : int) return int; - pragma Import (C, mprotect); - - --------------------------------------- - -- Nonstandard Thread Initialization -- - --------------------------------------- - - procedure pthread_init; - -- FSU_THREADS requires pthread_init, which is nonstandard - -- and this should be invoked during the elaboration of s-taprop.adb - pragma Import (C, pthread_init, "pthread_init"); - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function sigwait (set : access sigset_t; sig : access Signal) return int; - -- FSU_THREADS has a nonstandard sigwait - - function pthread_kill (thread : pthread_t; sig : Signal) return int; - pragma Import (C, pthread_kill, "pthread_kill"); - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask, "sigprocmask"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - -- FSU_THREADS has nonstandard pthread_mutex_lock - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - -- FSU_THREADS has nonstandard pthread_mutex_lock - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "pthread_cond_init"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - -- FSU_THREADS has a nonstandard pthread_cond_wait - - function pthread_cond_timedwait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t; - abstime : access timespec) return int; - -- FSU_THREADS has a nonstandard pthread_cond_timedwait - - Relative_Timed_Wait : constant Boolean := False; - -- pthread_cond_timedwait requires an absolute delay time - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - PTHREAD_PRIO_NONE : constant := 0; - PTHREAD_PRIO_PROTECT : constant := 2; - PTHREAD_PRIO_INHERIT : constant := 1; - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; - protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol); - - function pthread_mutexattr_setprioceiling - (attr : access pthread_mutexattr_t; - prioceiling : int) return int; - pragma Import - (C, pthread_mutexattr_setprioceiling, - "pthread_mutexattr_setprio_ceiling"); - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - -- FSU_THREADS does not have pthread_setschedparam - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import (C, pthread_attr_setinheritsched); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; - policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched"); - - function sched_yield return int; - -- FSU_THREADS does not have sched_yield; - - --------------------------- - -- P1003.1c - Section 16 -- - --------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "pthread_attr_init"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - -- FSU_THREADS has a nonstandard pthread_attr_setdetachstate - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "pthread_create"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "pthread_exit"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "pthread_self"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "pthread_setspecific"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - -- FSU_THREADS has a nonstandard pthread_getspecific - - type destructor_pointer is access procedure (arg : System.Address); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "pthread_key_create"); - -private - - type array_type_1 is array (Integer range 0 .. 3) of unsigned_long; - type sigset_t is record - X_X_sigbits : array_type_1; - end record; - pragma Convention (C, sigset_t); - - type pid_t is new long; - - type time_t is new long; - - type timespec is record - tv_sec : time_t; - tv_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 0; - - type struct_timeval is record - tv_sec : long; - tv_usec : long; - end record; - pragma Convention (C, struct_timeval); - - type pthread_attr_t is record - flags : int; - stacksize : int; - contentionscope : int; - inheritsched : int; - detachstate : int; - sched : int; - prio : int; - starttime : timespec; - deadline : timespec; - period : timespec; - end record; - pragma Convention (C, pthread_attr_t); - - type pthread_condattr_t is record - flags : int; - end record; - pragma Convention (C, pthread_condattr_t); - - type pthread_mutexattr_t is record - flags : int; - prio_ceiling : int; - protocol : int; - end record; - pragma Convention (C, pthread_mutexattr_t); - - type sigjmp_buf is array (Integer range 0 .. 18) of int; - - type pthread_t_struct is record - context : sigjmp_buf; - pbody : sigjmp_buf; - errno : int; - ret : int; - stack_base : System.Address; - end record; - pragma Convention (C, pthread_t_struct); - - type pthread_t is access all pthread_t_struct; - - type queue_t is record - head : System.Address; - tail : System.Address; - end record; - pragma Convention (C, queue_t); - - type pthread_mutex_t is record - queue : queue_t; - lock : plain_char; - owner : System.Address; - flags : int; - prio_ceiling : int; - protocol : int; - prev_max_ceiling_prio : int; - end record; - pragma Convention (C, pthread_mutex_t); - - type pthread_cond_t is record - queue : queue_t; - flags : int; - waiters : int; - mutex : System.Address; - end record; - pragma Convention (C, pthread_cond_t); - - type pthread_key_t is new int; - -end System.OS_Interface; diff --git a/gcc/ada/5usystem.ads b/gcc/ada/5usystem.ads deleted file mode 100644 index dca552ebc5a..00000000000 --- a/gcc/ada/5usystem.ads +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (Solaris Sparcv9 Version) -- --- -- --- 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 := 0.01; - - -- 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 := High_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := True; - 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 := False; - ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; - 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 := True; - -end System; diff --git a/gcc/ada/5vasthan.adb b/gcc/ada/5vasthan.adb deleted file mode 100644 index 86d04025dbf..00000000000 --- a/gcc/ada/5vasthan.adb +++ /dev/null @@ -1,597 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . A S T _ H A N D L I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-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 version. - -with System; use System; - -with System.IO; - -with System.Machine_Code; -with System.Parameters; -with System.Storage_Elements; - -with System.Tasking; -with System.Tasking.Rendezvous; -with System.Tasking.Initialization; -with System.Tasking.Utilities; - -with System.Task_Primitives; -with System.Task_Primitives.Operations; -with System.Task_Primitives.Operations.DEC; - --- with Ada.Finalization; --- removed, because of problem with controlled attribute ??? - -with Ada.Task_Attributes; -with Ada.Task_Identification; - -with Ada.Exceptions; use Ada.Exceptions; - -with Ada.Unchecked_Conversion; - -package body System.AST_Handling is - - package ATID renames Ada.Task_Identification; - - package SP renames System.Parameters; - package ST renames System.Tasking; - package STR renames System.Tasking.Rendezvous; - package STI renames System.Tasking.Initialization; - package STU renames System.Tasking.Utilities; - - package SSE renames System.Storage_Elements; - package STPO renames System.Task_Primitives.Operations; - package STPOD renames System.Task_Primitives.Operations.DEC; - - AST_Lock : aliased System.Task_Primitives.RTS_Lock; - -- This is a global lock; it is used to execute in mutual exclusion - -- from all other AST tasks. It is only used by Lock_AST and - -- Unlock_AST. - - procedure Lock_AST (Self_ID : ST.Task_ID); - -- Locks out other AST tasks. Preceding a section of code by Lock_AST and - -- following it by Unlock_AST creates a critical region. - - procedure Unlock_AST (Self_ID : ST.Task_ID); - -- Releases lock previously set by call to Lock_AST. - -- All nested locks must be released before other tasks competing for the - -- tasking lock are released. - - -------------- - -- Lock_AST -- - -------------- - - procedure Lock_AST (Self_ID : ST.Task_ID) is - begin - STI.Defer_Abort_Nestable (Self_ID); - STPO.Write_Lock (AST_Lock'Access, Global_Lock => True); - end Lock_AST; - - ---------------- - -- Unlock_AST -- - ---------------- - - procedure Unlock_AST (Self_ID : ST.Task_ID) is - begin - STPO.Unlock (AST_Lock'Access, Global_Lock => True); - STI.Undefer_Abort_Nestable (Self_ID); - end Unlock_AST; - - --------------------------------- - -- AST_Handler Data Structures -- - --------------------------------- - - -- As noted in the private part of the spec of System.Aux_DEC, the - -- AST_Handler type is simply a pointer to a procedure that takes - -- a single 64bit parameter. The following is a local copy - -- of that definition. - - -- We need our own copy because we need to get our hands on this - -- and we cannot see the private part of System.Aux_DEC. We don't - -- want to be a child of Aux_Dec because of complications resulting - -- from the use of pragma Extend_System. We will use unchecked - -- conversions between the two versions of the declarations. - - type AST_Handler is access procedure (Param : Long_Integer); - - -- However, this declaration is somewhat misleading, since the values - -- referenced by AST_Handler values (all produced in this package by - -- calls to Create_AST_Handler) are highly stylized. - - -- The first point is that in VMS/Alpha, procedure pointers do not in - -- fact point to code, but rather to a 48-byte procedure descriptor. - -- So a value of type AST_Handler is in fact a pointer to one of these - -- 48-byte descriptors. - - type Descriptor_Type is new SSE.Storage_Array (1 .. 48); - for Descriptor_Type'Alignment use Standard'Maximum_Alignment; - pragma Warnings (Off, Descriptor_Type); - -- Suppress harmless warnings about alignment. - -- Should explain why this warning is harmless ??? - - type Descriptor_Ref is access all Descriptor_Type; - - -- Normally, there is only one such descriptor for a given procedure, but - -- it works fine to make a copy of the single allocated descriptor, and - -- use the copy itself, and we take advantage of this in the design here. - -- The idea is that AST_Handler values will all point to a record with the - -- following structure: - - -- Note: When we say it works fine, there is one delicate point, which - -- is that the code for the AST procedure itself requires the original - -- descriptor address. We handle this by saving the orignal descriptor - -- address in this structure and restoring in Process_AST. - - type AST_Handler_Data is record - Descriptor : Descriptor_Type; - Original_Descriptor_Ref : Descriptor_Ref; - Taskid : ATID.Task_Id; - Entryno : Natural; - end record; - - type AST_Handler_Data_Ref is access all AST_Handler_Data; - - function To_AST_Handler is new Ada.Unchecked_Conversion - (AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler); - - -- Each time Create_AST_Handler is called, a new value of this record - -- type is created, containing a copy of the procedure descriptor for - -- the routine used to handle all AST's (Process_AST), and the Task_Id - -- and entry number parameters identifying the task entry involved. - - -- The AST_Handler value returned is a pointer to this record. Since - -- the record starts with the procedure descriptor, it can be used - -- by the system in the normal way to call the procedure. But now - -- when the procedure gets control, it can determine the address of - -- the procedure descriptor used to call it (since the ABI specifies - -- that this is left sitting in register r27 on entry), and then use - -- that address to retrieve the Task_Id and entry number so that it - -- knows on which entry to queue the AST request. - - -- The next issue is where are these records placed. Since we intend - -- to pass pointers to these records to asynchronous system service - -- routines, they have to be on the heap, which means we have to worry - -- about when to allocate them and deallocate them. - - -- We solve this problem by introducing a task attribute that points to - -- a vector, indexed by the entry number, of AST_Handler_Data records - -- for a given task. The pointer itself is a controlled object allowing - -- us to write a finalization routine that frees the referenced vector. - - -- An entry in this vector is either initialized (Entryno non-zero) and - -- can be used for any subsequent reference to the same entry, or it is - -- unused, marked by the Entryno value being zero. - - type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data; - type AST_Handler_Vector_Ref is access all AST_Handler_Vector; - --- type AST_Vector_Ptr is new Ada.Finalization.Controlled with record --- removed due to problem with controlled attribute, consequence is that --- we have a memory leak if a task that has AST attribute entries is --- terminated. ??? - - type AST_Vector_Ptr is record - Vector : AST_Handler_Vector_Ref; - end record; - - AST_Vector_Init : AST_Vector_Ptr; - -- Initial value, treated as constant, Vector will be null. - - package AST_Attribute is new Ada.Task_Attributes - (Attribute => AST_Vector_Ptr, - Initial_Value => AST_Vector_Init); - - use AST_Attribute; - - ----------------------- - -- AST Service Queue -- - ----------------------- - - -- The following global data structures are used to queue pending - -- AST requests. When an AST is signalled, the AST service routine - -- Process_AST is called, and it makes an entry in this structure. - - type AST_Instance is record - Taskid : ATID.Task_Id; - Entryno : Natural; - Param : Long_Integer; - end record; - -- The Taskid and Entryno indicate the entry on which this AST is to - -- be queued, and Param is the parameter provided from the AST itself. - - AST_Service_Queue_Size : constant := 256; - AST_Service_Queue_Limit : constant := 250; - type AST_Service_Queue_Index is mod AST_Service_Queue_Size; - -- Index used to refer to entries in the circular buffer which holds - -- active AST_Instance values. The upper bound reflects the maximum - -- number of AST instances that can be stored in the buffer. Since - -- these entries are immediately serviced by the high priority server - -- task that does the actual entry queuing, it is very unusual to have - -- any significant number of entries simulaneously queued. - - AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance; - pragma Volatile_Components (AST_Service_Queue); - -- The circular buffer used to store active AST requests. - - AST_Service_Queue_Put : AST_Service_Queue_Index := 0; - AST_Service_Queue_Get : AST_Service_Queue_Index := 0; - pragma Atomic (AST_Service_Queue_Put); - pragma Atomic (AST_Service_Queue_Get); - -- These two variables point to the next slots in the AST_Service_Queue - -- to be used for putting a new entry in and taking an entry out. This - -- is a circular buffer, so these pointers wrap around. If the two values - -- are equal the buffer is currently empty. The pointers are atomic to - -- ensure proper synchronization between the single producer (namely the - -- Process_AST procedure), and the single consumer (the AST_Service_Task). - - -------------------------------- - -- AST Server Task Structures -- - -------------------------------- - - -- The basic approach is that when an AST comes in, a call is made to - -- the Process_AST procedure. It queues the request in the service queue - -- and then wakes up an AST server task to perform the actual call to the - -- required entry. We use this intermediate server task, since the AST - -- procedure itself cannot wait to return, and we need some caller for - -- the rendezvous so that we can use the normal rendezvous mechanism. - - -- It would work to have only one AST server task, but then we would lose - -- all overlap in AST processing, and furthermore, we could get priority - -- inversion effects resulting in starvation of AST requests. - - -- We therefore maintain a small pool of AST server tasks. We adjust - -- the size of the pool dynamically to reflect traffic, so that we have - -- a sufficient number of server tasks to avoid starvation. - - Max_AST_Servers : constant Natural := 16; - -- Maximum number of AST server tasks that can be allocated - - Num_AST_Servers : Natural := 0; - -- Number of AST server tasks currently active - - Num_Waiting_AST_Servers : Natural := 0; - -- This is the number of AST server tasks that are either waiting for - -- work, or just about to go to sleep and wait for work. - - Is_Waiting : array (1 .. Max_AST_Servers) of Boolean := (others => False); - -- An array of flags showing which AST server tasks are currently waiting - - AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_ID; - -- Task Id's of allocated AST server tasks - - task type AST_Server_Task (Num : Natural) is - pragma Priority (Priority'Last); - end AST_Server_Task; - -- Declaration for AST server task. This task has no entries, it is - -- controlled by sleep and wakeup calls at the task primitives level. - - type AST_Server_Task_Ptr is access all AST_Server_Task; - -- Type used to allocate server tasks - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Allocate_New_AST_Server; - -- Allocate an additional AST server task - - procedure Process_AST (Param : Long_Integer); - -- This is the central routine for processing all AST's, it is referenced - -- as the code address of all created AST_Handler values. See detailed - -- description in body to understand how it works to have a single such - -- procedure for all AST's even though it does not get any indication of - -- the entry involved passed as an explicit parameter. The single explicit - -- parameter Param is the parameter passed by the system with the AST. - - ----------------------------- - -- Allocate_New_AST_Server -- - ----------------------------- - - procedure Allocate_New_AST_Server is - Dummy : AST_Server_Task_Ptr; - pragma Unreferenced (Dummy); - - begin - if Num_AST_Servers = Max_AST_Servers then - return; - - else - -- Note: it is safe to increment Num_AST_Servers immediately, since - -- no one will try to activate this task until it indicates that it - -- is sleeping by setting its entry in Is_Waiting to True. - - Num_AST_Servers := Num_AST_Servers + 1; - Dummy := new AST_Server_Task (Num_AST_Servers); - end if; - end Allocate_New_AST_Server; - - --------------------- - -- AST_Server_Task -- - --------------------- - - task body AST_Server_Task is - Taskid : ATID.Task_Id; - Entryno : Natural; - Param : aliased Long_Integer; - Self_Id : constant ST.Task_ID := ST.Self; - - pragma Volatile (Param); - - begin - -- By making this task independent of master, when the environment - -- task is finalizing, the AST_Server_Task will be notified that it - -- should terminate. - - STU.Make_Independent; - - -- Record our task Id for access by Process_AST - - AST_Task_Ids (Num) := Self_Id; - - -- Note: this entire task operates with the main task lock set, except - -- when it is sleeping waiting for work, or busy doing a rendezvous - -- with an AST server. This lock protects the data structures that - -- are shared by multiple instances of the server task. - - Lock_AST (Self_Id); - - -- This is the main infinite loop of the task. We go to sleep and - -- wait to be woken up by Process_AST when there is some work to do. - - loop - Num_Waiting_AST_Servers := Num_Waiting_AST_Servers + 1; - - Unlock_AST (Self_Id); - - STI.Defer_Abort (Self_Id); - - if SP.Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Self_Id); - - Is_Waiting (Num) := True; - - Self_Id.Common.State := ST.AST_Server_Sleep; - STPO.Sleep (Self_Id, ST.AST_Server_Sleep); - Self_Id.Common.State := ST.Runnable; - - STPO.Unlock (Self_Id); - - if SP.Single_Lock then - STPO.Unlock_RTS; - end if; - - -- If the process is finalizing, Undefer_Abort will simply end - -- this task. - - STI.Undefer_Abort (Self_Id); - - -- We are awake, there is something to do! - - Lock_AST (Self_Id); - Num_Waiting_AST_Servers := Num_Waiting_AST_Servers - 1; - - -- Loop here to service outstanding requests. We are always - -- locked on entry to this loop. - - while AST_Service_Queue_Get /= AST_Service_Queue_Put loop - Taskid := AST_Service_Queue (AST_Service_Queue_Get).Taskid; - Entryno := AST_Service_Queue (AST_Service_Queue_Get).Entryno; - Param := AST_Service_Queue (AST_Service_Queue_Get).Param; - - AST_Service_Queue_Get := AST_Service_Queue_Get + 1; - - -- This is a manual expansion of the normal call simple code - - declare - type AA is access all Long_Integer; - P : AA := Param'Unrestricted_Access; - - function To_ST_Task_Id is new Ada.Unchecked_Conversion - (ATID.Task_Id, ST.Task_ID); - - begin - Unlock_AST (Self_Id); - STR.Call_Simple - (Acceptor => To_ST_Task_Id (Taskid), - E => ST.Task_Entry_Index (Entryno), - Uninterpreted_Data => P'Address); - - exception - when E : others => - System.IO.Put_Line ("%Debugging event"); - System.IO.Put_Line (Exception_Name (E) & - " raised when trying to deliver an AST."); - - if Exception_Message (E)'Length /= 0 then - System.IO.Put_Line (Exception_Message (E)); - end if; - - System.IO.Put_Line ("Task type is " & "Receiver_Type"); - System.IO.Put_Line ("Task id is " & ATID.Image (Taskid)); - end; - - Lock_AST (Self_Id); - end loop; - end loop; - end AST_Server_Task; - - ------------------------ - -- Create_AST_Handler -- - ------------------------ - - function Create_AST_Handler - (Taskid : ATID.Task_Id; - Entryno : Natural) return System.Aux_DEC.AST_Handler - is - Attr_Ref : Attribute_Handle; - - Process_AST_Ptr : constant AST_Handler := Process_AST'Access; - -- Reference to standard procedure descriptor for Process_AST - - function To_Descriptor_Ref is new Ada.Unchecked_Conversion - (AST_Handler, Descriptor_Ref); - - Original_Descriptor_Ref : constant Descriptor_Ref := - To_Descriptor_Ref (Process_AST_Ptr); - - begin - if ATID.Is_Terminated (Taskid) then - raise Program_Error; - end if; - - Attr_Ref := Reference (Taskid); - - -- Allocate another server if supply is getting low - - if Num_Waiting_AST_Servers < 2 then - Allocate_New_AST_Server; - end if; - - -- No point in creating more if we have zillions waiting to - -- be serviced. - - while AST_Service_Queue_Put - AST_Service_Queue_Get - > AST_Service_Queue_Limit - loop - delay 0.01; - end loop; - - -- If no AST vector allocated, or the one we have is too short, then - -- allocate one of right size and initialize all entries except the - -- one we will use to unused. Note that the assignment automatically - -- frees the old allocated table if there is one. - - if Attr_Ref.Vector = null - or else Attr_Ref.Vector'Length < Entryno - then - Attr_Ref.Vector := new AST_Handler_Vector (1 .. Entryno); - - for E in 1 .. Entryno loop - Attr_Ref.Vector (E).Descriptor := - Original_Descriptor_Ref.all; - Attr_Ref.Vector (E).Original_Descriptor_Ref := - Original_Descriptor_Ref; - Attr_Ref.Vector (E).Taskid := Taskid; - Attr_Ref.Vector (E).Entryno := E; - end loop; - end if; - - return To_AST_Handler (Attr_Ref.Vector (Entryno)'Unrestricted_Access); - end Create_AST_Handler; - - ---------------------------- - -- Expand_AST_Packet_Pool -- - ---------------------------- - - procedure Expand_AST_Packet_Pool - (Requested_Packets : in Natural; - Actual_Number : out Natural; - Total_Number : out Natural) - is - pragma Unreferenced (Requested_Packets); - begin - -- The AST implementation of GNAT does not permit dynamic expansion - -- of the pool, so we simply add no entries and return the total. If - -- it is necessary to expand the allocation, then this package body - -- must be recompiled with a larger value for AST_Service_Queue_Size. - - Actual_Number := 0; - Total_Number := AST_Service_Queue_Size; - end Expand_AST_Packet_Pool; - - ----------------- - -- Process_AST -- - ----------------- - - procedure Process_AST (Param : Long_Integer) is - - Handler_Data_Ptr : AST_Handler_Data_Ref; - -- This variable is set to the address of the descriptor through - -- which Process_AST is called. Since the descriptor is part of - -- an AST_Handler value, this is also the address of this value, - -- from which we can obtain the task and entry number information. - - function To_Address is new Ada.Unchecked_Conversion - (ST.Task_ID, System.Address); - - begin - System.Machine_Code.Asm - (Template => "addl $27,0,%0", - Outputs => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr), - Volatile => True); - - System.Machine_Code.Asm - (Template => "ldl $27,%0", - Inputs => Descriptor_Ref'Asm_Input - ("m", Handler_Data_Ptr.Original_Descriptor_Ref), - Volatile => True); - - AST_Service_Queue (AST_Service_Queue_Put) := AST_Instance' - (Taskid => Handler_Data_Ptr.Taskid, - Entryno => Handler_Data_Ptr.Entryno, - Param => Param); - - -- OpenVMS Programming Concepts manual, chapter 8.2.3: - -- "Implicit synchronization can be achieved for data that is shared - -- for write by using only AST routines to write the data, since only - -- one AST can be running at any one time." - - -- This subprogram runs at AST level so is guaranteed to be - -- called sequentially at a given access level. - - AST_Service_Queue_Put := AST_Service_Queue_Put + 1; - - -- Need to wake up processing task. If there is no waiting server - -- then we have temporarily run out, but things should still be - -- OK, since one of the active ones will eventually pick up the - -- service request queued in the AST_Service_Queue. - - for J in 1 .. Num_AST_Servers loop - if Is_Waiting (J) then - Is_Waiting (J) := False; - - -- Sleeps are handled by ASTs on VMS, so don't call Wakeup. - - STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J))); - exit; - end if; - end loop; - end Process_AST; - -begin - STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level); -end System.AST_Handling; diff --git a/gcc/ada/5vdirval.adb b/gcc/ada/5vdirval.adb deleted file mode 100644 index 76cae74aa34..00000000000 --- a/gcc/ada/5vdirval.adb +++ /dev/null @@ -1,175 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I R E C T O R I E S . V A L I D I T Y -- --- -- --- B o d y -- --- (VMS Version) -- --- -- --- Copyright (C) 2004 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 version of this package - -package body Ada.Directories.Validity is - - Max_Number_Of_Characters : constant := 39; - Max_Path_Length : constant := 1_024; - - Invalid_Character : constant array (Character) of Boolean := - ('a' .. 'z' => False, - 'A' .. 'Z' => False, - '_' | '$' | '-' | '.' => False, - others => True); - - ------------------------ - -- Is_Valid_Path_Name -- - ------------------------ - - function Is_Valid_Path_Name (Name : String) return Boolean is - First : Positive := Name'First; - Last : Positive; - Dot_Found : Boolean := False; - - begin - -- A valid path (directory) name cannot be empty, and cannot contain - -- more than 1024 characters. Directories can be ".", ".." or be simple - -- name without extensions. - - if Name'Length = 0 or else Name'Length > Max_Path_Length then - return False; - - else - loop - -- Look for the start of the next directory or file name - - while First <= Name'Last and then Name (First) = '/' loop - First := First + 1; - end loop; - - -- If all directories/file names are OK, return True - - exit when First > Name'Last; - - Last := First; - Dot_Found := False; - - -- Look for the end of the directory/file name - - while Last < Name'Last loop - exit when Name (Last + 1) = '/'; - Last := Last + 1; - - if Name (Last) = '.' then - Dot_Found := True; - end if; - end loop; - - -- If name include a dot, it can only be ".", ".." or a the last - -- file name. - - if Dot_Found then - if Name (First .. Last) /= "." and then - Name (First .. Last) /= ".." - then - return Last = Name'Last - and then Is_Valid_Simple_Name (Name (First .. Last)); - - end if; - - -- Check if the directory/file name is valid - - elsif not Is_Valid_Simple_Name (Name (First .. Last)) then - return False; - end if; - - -- Move to the next name - - First := Last + 1; - end loop; - end if; - - -- If Name follows the rules, then it is valid - - return True; - end Is_Valid_Path_Name; - - -------------------------- - -- Is_Valid_Simple_Name -- - -------------------------- - - function Is_Valid_Simple_Name (Name : String) return Boolean is - In_Extension : Boolean := False; - Number_Of_Characters : Natural := 0; - - begin - -- A file name cannot be empty, and cannot have more than 39 characters - -- before or after a single '.'. - - if Name'Length = 0 then - return False; - - else - -- Check each character for validity - - for J in Name'Range loop - if Invalid_Character (Name (J)) then - return False; - - elsif Name (J) = '.' then - - -- Name cannot contain several dots - - if In_Extension then - return False; - - else - -- Reset the number of characters to count the characters - -- of the extension. - - In_Extension := True; - Number_Of_Characters := 0; - end if; - - else - -- Check that the number of character is not too large - - Number_Of_Characters := Number_Of_Characters + 1; - - if Number_Of_Characters > Max_Number_Of_Characters then - return False; - end if; - end if; - end loop; - end if; - - -- If the rules are followed, then it is valid - - return True; - end Is_Valid_Simple_Name; - -end Ada.Directories.Validity; - diff --git a/gcc/ada/5vinmaop.adb b/gcc/ada/5vinmaop.adb deleted file mode 100644 index 2cbfd0eb715..00000000000 --- a/gcc/ada/5vinmaop.adb +++ /dev/null @@ -1,298 +0,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 . -- --- O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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 a OpenVMS/Alpha version of this package. - -with System.OS_Interface; --- used for various type, constant, and operations - -with System.Aux_DEC; --- used for Short_Address - -with System.Parameters; - -with System.Tasking; - -with System.Tasking.Initialization; - -with System.Task_Primitives.Operations; - -with System.Task_Primitives.Operations.DEC; - -with Unchecked_Conversion; - -package body System.Interrupt_Management.Operations is - - use System.OS_Interface; - use System.Parameters; - use System.Tasking; - use type unsigned_short; - - function To_Address is new Unchecked_Conversion (Task_ID, System.Address); - package POP renames System.Task_Primitives.Operations; - - ---------------------------- - -- Thread_Block_Interrupt -- - ---------------------------- - - procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID) is - pragma Warnings (Off, Interrupt); - begin - null; - end Thread_Block_Interrupt; - - ------------------------------ - -- Thread_Unblock_Interrupt -- - ------------------------------ - - procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID) is - pragma Warnings (Off, Interrupt); - begin - null; - end Thread_Unblock_Interrupt; - - ------------------------ - -- Set_Interrupt_Mask -- - ------------------------ - - procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is - pragma Warnings (Off, Mask); - begin - null; - end Set_Interrupt_Mask; - - procedure Set_Interrupt_Mask - (Mask : access Interrupt_Mask; - OMask : access Interrupt_Mask) - is - pragma Warnings (Off, Mask); - pragma Warnings (Off, OMask); - begin - null; - end Set_Interrupt_Mask; - - ------------------------ - -- Get_Interrupt_Mask -- - ------------------------ - - procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is - pragma Warnings (Off, Mask); - begin - null; - end Get_Interrupt_Mask; - - -------------------- - -- Interrupt_Wait -- - -------------------- - - function To_unsigned_long is new - Unchecked_Conversion (System.Aux_DEC.Short_Address, unsigned_long); - - function Interrupt_Wait (Mask : access Interrupt_Mask) - return Interrupt_ID - is - Self_ID : constant Task_ID := Self; - Iosb : IO_Status_Block_Type := (0, 0, 0); - Status : Cond_Value_Type; - - begin - - -- A QIO read is registered. The system call returns immediately - -- after scheduling an AST to be fired when the operation - -- completes. - - Sys_QIO - (Status => Status, - Chan => Rcv_Interrupt_Chan, - Func => IO_READVBLK, - Iosb => Iosb, - Astadr => - POP.DEC.Interrupt_AST_Handler'Access, - Astprm => To_Address (Self_ID), - P1 => To_unsigned_long (Interrupt_Mailbox'Address), - P2 => Interrupt_ID'Size / 8); - - pragma Assert ((Status and 1) = 1); - - loop - - -- Wait to be woken up. Could be that the AST has fired, - -- in which case the Iosb.Status variable will be non-zero, - -- or maybe the wait is being aborted. - - POP.Sleep - (Self_ID, - System.Tasking.Interrupt_Server_Blocked_On_Event_Flag); - - if Iosb.Status /= 0 then - if (Iosb.Status and 1) = 1 - and then Mask (Signal (Interrupt_Mailbox)) - then - return Interrupt_Mailbox; - else - return 0; - end if; - else - POP.Unlock (Self_ID); - - if Single_Lock then - POP.Unlock_RTS; - end if; - - System.Tasking.Initialization.Undefer_Abort (Self_ID); - System.Tasking.Initialization.Defer_Abort (Self_ID); - - if Single_Lock then - POP.Lock_RTS; - end if; - - POP.Write_Lock (Self_ID); - end if; - end loop; - end Interrupt_Wait; - - ---------------------------- - -- Install_Default_Action -- - ---------------------------- - - procedure Install_Default_Action (Interrupt : Interrupt_ID) is - pragma Warnings (Off, Interrupt); - begin - null; - end Install_Default_Action; - - --------------------------- - -- Install_Ignore_Action -- - --------------------------- - - procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is - pragma Warnings (Off, Interrupt); - begin - null; - end Install_Ignore_Action; - - ------------------------- - -- Fill_Interrupt_Mask -- - ------------------------- - - procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is - begin - Mask.all := (others => True); - end Fill_Interrupt_Mask; - - -------------------------- - -- Empty_Interrupt_Mask -- - -------------------------- - - procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is - begin - Mask.all := (others => False); - end Empty_Interrupt_Mask; - - --------------------------- - -- Add_To_Interrupt_Mask -- - --------------------------- - - procedure Add_To_Interrupt_Mask - (Mask : access Interrupt_Mask; - Interrupt : Interrupt_ID) - is - begin - Mask (Signal (Interrupt)) := True; - end Add_To_Interrupt_Mask; - - -------------------------------- - -- Delete_From_Interrupt_Mask -- - -------------------------------- - - procedure Delete_From_Interrupt_Mask - (Mask : access Interrupt_Mask; - Interrupt : Interrupt_ID) - is - begin - Mask (Signal (Interrupt)) := False; - end Delete_From_Interrupt_Mask; - - --------------- - -- Is_Member -- - --------------- - - function Is_Member - (Mask : access Interrupt_Mask; - Interrupt : Interrupt_ID) return Boolean - is - begin - return Mask (Signal (Interrupt)); - end Is_Member; - - ------------------------- - -- Copy_Interrupt_Mask -- - ------------------------- - - procedure Copy_Interrupt_Mask - (X : out Interrupt_Mask; - Y : Interrupt_Mask) - is - begin - X := Y; - end Copy_Interrupt_Mask; - - ------------------------- - -- Interrupt_Self_Process -- - ------------------------- - - procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is - Status : Cond_Value_Type; - begin - Sys_QIO - (Status => Status, - Chan => Snd_Interrupt_Chan, - Func => IO_WRITEVBLK, - P1 => To_unsigned_long (Interrupt'Address), - P2 => Interrupt_ID'Size / 8); - - pragma Assert ((Status and 1) = 1); - end Interrupt_Self_Process; - -begin - Environment_Mask := (others => False); - All_Tasks_Mask := (others => True); - - for J in Interrupt_ID loop - if Keep_Unmasked (J) then - Environment_Mask (Signal (J)) := True; - All_Tasks_Mask (Signal (J)) := False; - end if; - end loop; -end System.Interrupt_Management.Operations; diff --git a/gcc/ada/5vinterr.adb b/gcc/ada/5vinterr.adb deleted file mode 100644 index f302ead12e3..00000000000 --- a/gcc/ada/5vinterr.adb +++ /dev/null @@ -1,1176 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . I N T E R R U P T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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 an OpenVMS/Alpha version of this package. - --- Invariants: - --- Once we associate a Server_Task with an interrupt, the task never --- goes away, and we never remove the association. - --- There is no more than one interrupt per Server_Task and no more than --- one Server_Task per interrupt. - --- Within this package, the lock L is used to protect the various status --- tables. If there is a Server_Task associated with an interrupt, we use --- the per-task lock of the Server_Task instead so that we protect the --- status between Interrupt_Manager and Server_Task. Protection among --- service requests are done using User Request to Interrupt_Manager --- rendezvous. - -with Ada.Task_Identification; --- used for Task_ID type - -with Ada.Exceptions; --- used for Raise_Exception - -with System.Task_Primitives; --- used for RTS_Lock --- Self - -with System.Interrupt_Management; --- used for Reserve --- Interrupt_ID --- Interrupt_Mask --- Abort_Task_Interrupt - -with System.Interrupt_Management.Operations; --- used for Thread_Block_Interrupt --- Thread_Unblock_Interrupt --- Install_Default_Action --- Install_Ignore_Action --- Copy_Interrupt_Mask --- Set_Interrupt_Mask --- Empty_Interrupt_Mask --- Fill_Interrupt_Mask --- Add_To_Interrupt_Mask --- Delete_From_Interrupt_Mask --- Interrupt_Wait --- Interrupt_Self_Process --- Get_Interrupt_Mask --- Set_Interrupt_Mask --- IS_Member --- Environment_Mask -pragma Elaborate_All (System.Interrupt_Management.Operations); - -with System.Task_Primitives.Operations; --- used for Write_Lock --- Unlock --- Abort --- Wakeup_Task --- Sleep --- Initialize_Lock - -with System.Task_Primitives.Interrupt_Operations; --- used for Set_Interrupt_ID - -with System.Storage_Elements; --- used for To_Address --- To_Integer --- Integer_Address - -with System.Tasking; --- used for Task_ID --- Task_Entry_Index --- Null_Task --- Self --- Interrupt_Manager_ID - -with System.Tasking.Utilities; --- used for Make_Independent - -with System.Tasking.Rendezvous; --- used for Call_Simple -pragma Elaborate_All (System.Tasking.Rendezvous); - -with System.Tasking.Initialization; --- used for Defer_Abort --- Undefer_Abort - -with System.Parameters; --- used for Single_Lock - -with Unchecked_Conversion; - -package body System.Interrupts is - - use Tasking; - use System.Parameters; - use Ada.Exceptions; - - package POP renames System.Task_Primitives.Operations; - package PIO renames System.Task_Primitives.Interrupt_Operations; - package IMNG renames System.Interrupt_Management; - package IMOP renames System.Interrupt_Management.Operations; - - function To_System is new Unchecked_Conversion - (Ada.Task_Identification.Task_Id, Task_ID); - - ----------------- - -- Local Tasks -- - ----------------- - - -- WARNING: System.Tasking.Stages performs calls to this task - -- with low-level constructs. Do not change this spec without synchro- - -- nizing it. - - task Interrupt_Manager is - entry Detach_Interrupt_Entries (T : Task_ID); - - entry Initialize (Mask : IMNG.Interrupt_Mask); - - entry Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False); - - entry Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean); - - entry Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean); - - entry Bind_Interrupt_To_Entry - (T : Task_ID; - E : Task_Entry_Index; - Interrupt : Interrupt_ID); - - entry Block_Interrupt (Interrupt : Interrupt_ID); - - entry Unblock_Interrupt (Interrupt : Interrupt_ID); - - entry Ignore_Interrupt (Interrupt : Interrupt_ID); - - entry Unignore_Interrupt (Interrupt : Interrupt_ID); - - pragma Interrupt_Priority (System.Interrupt_Priority'Last); - end Interrupt_Manager; - - task type Server_Task (Interrupt : Interrupt_ID) is - pragma Priority (System.Interrupt_Priority'Last); - -- Note: the above pragma Priority is strictly speaking improper - -- since it is outside the range of allowed priorities, but the - -- compiler treats system units specially and does not apply - -- this range checking rule to system units. - - end Server_Task; - - type Server_Task_Access is access Server_Task; - - -------------------------------- - -- Local Types and Variables -- - -------------------------------- - - type Entry_Assoc is record - T : Task_ID; - E : Task_Entry_Index; - end record; - - type Handler_Assoc is record - H : Parameterless_Handler; - Static : Boolean; -- Indicates static binding; - end record; - - User_Handler : array (Interrupt_ID'Range) of Handler_Assoc := - (others => (null, Static => False)); - pragma Volatile_Components (User_Handler); - -- Holds the protected procedure handler (if any) and its Static - -- information for each interrupt. A handler is a Static one if - -- it is specified through the pragma Attach_Handler. - -- Attach_Handler. Otherwise, not static) - - User_Entry : array (Interrupt_ID'Range) of Entry_Assoc := - (others => (T => Null_Task, E => Null_Task_Entry)); - pragma Volatile_Components (User_Entry); - -- Holds the task and entry index (if any) for each interrupt - - Blocked : constant array (Interrupt_ID'Range) of Boolean := - (others => False); --- ??? pragma Volatile_Components (Blocked); - -- True iff the corresponding interrupt is blocked in the process level - - Ignored : array (Interrupt_ID'Range) of Boolean := (others => False); - pragma Volatile_Components (Ignored); - -- True iff the corresponding interrupt is blocked in the process level - - Last_Unblocker : constant array (Interrupt_ID'Range) of Task_ID := - (others => Null_Task); --- ??? pragma Volatile_Components (Last_Unblocker); - -- Holds the ID of the last Task which Unblocked this Interrupt. - -- It contains Null_Task if no tasks have ever requested the - -- Unblocking operation or the Interrupt is currently Blocked. - - Server_ID : array (Interrupt_ID'Range) of Task_ID := - (others => Null_Task); - pragma Atomic_Components (Server_ID); - -- Holds the Task_ID of the Server_Task for each interrupt. - -- Task_ID is needed to accomplish locking per Interrupt base. Also - -- is needed to decide whether to create a new Server_Task. - - -- Type and Head, Tail of the list containing Registered Interrupt - -- Handlers. These definitions are used to register the handlers - -- specified by the pragma Interrupt_Handler. - - type Registered_Handler; - type R_Link is access all Registered_Handler; - - type Registered_Handler is record - H : System.Address := System.Null_Address; - Next : R_Link := null; - end record; - - Registered_Handler_Head : R_Link := null; - Registered_Handler_Tail : R_Link := null; - - Access_Hold : Server_Task_Access; - -- variable used to allocate Server_Task using "new". - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Is_Registered (Handler : Parameterless_Handler) return Boolean; - -- See if the Handler has been "pragma"ed using Interrupt_Handler. - -- Always consider a null handler as registered. - - -------------------------------- - -- Register_Interrupt_Handler -- - -------------------------------- - - procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is - New_Node_Ptr : R_Link; - begin - -- This routine registers the Handler as usable for Dynamic - -- Interrupt Handler. Routines attaching and detaching Handler - -- dynamically should first consult if the Handler is rgistered. - -- A Program Error should be raised if it is not registered. - - -- The pragma Interrupt_Handler can only appear in the library - -- level PO definition and instantiation. Therefore, we do not need - -- to implement Unregistering operation. Neither we need to - -- protect the queue structure using a Lock. - - pragma Assert (Handler_Addr /= System.Null_Address); - - New_Node_Ptr := new Registered_Handler; - New_Node_Ptr.H := Handler_Addr; - - if Registered_Handler_Head = null then - Registered_Handler_Head := New_Node_Ptr; - Registered_Handler_Tail := New_Node_Ptr; - - else - Registered_Handler_Tail.Next := New_Node_Ptr; - Registered_Handler_Tail := New_Node_Ptr; - end if; - end Register_Interrupt_Handler; - - ------------------- - -- Is_Registered -- - ------------------- - - function Is_Registered (Handler : Parameterless_Handler) return Boolean is - type Fat_Ptr is record - Object_Addr : System.Address; - Handler_Addr : System.Address; - end record; - - function To_Fat_Ptr is new Unchecked_Conversion - (Parameterless_Handler, Fat_Ptr); - - Ptr : R_Link; - Fat : Fat_Ptr; - - begin - if Handler = null then - return True; - end if; - - Fat := To_Fat_Ptr (Handler); - - Ptr := Registered_Handler_Head; - - while Ptr /= null loop - if Ptr.H = Fat.Handler_Addr then - return True; - end if; - - Ptr := Ptr.Next; - end loop; - - return False; - - end Is_Registered; - - ----------------- - -- Is_Reserved -- - ----------------- - - function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is - begin - return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt)); - end Is_Reserved; - - ----------------------- - -- Is_Entry_Attached -- - ----------------------- - - function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is - begin - if Is_Reserved (Interrupt) then - Raise_Exception (Program_Error'Identity, "Interrupt" & - Interrupt_ID'Image (Interrupt) & " is reserved"); - end if; - - return User_Entry (Interrupt).T /= Null_Task; - end Is_Entry_Attached; - - ------------------------- - -- Is_Handler_Attached -- - ------------------------- - - function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is - begin - if Is_Reserved (Interrupt) then - Raise_Exception (Program_Error'Identity, "Interrupt" & - Interrupt_ID'Image (Interrupt) & " is reserved"); - end if; - - return User_Handler (Interrupt).H /= null; - end Is_Handler_Attached; - - ---------------- - -- Is_Blocked -- - ---------------- - - function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is - begin - if Is_Reserved (Interrupt) then - Raise_Exception (Program_Error'Identity, "Interrupt" & - Interrupt_ID'Image (Interrupt) & " is reserved"); - end if; - - return Blocked (Interrupt); - end Is_Blocked; - - ---------------- - -- Is_Ignored -- - ---------------- - - function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is - begin - if Is_Reserved (Interrupt) then - Raise_Exception (Program_Error'Identity, "Interrupt" & - Interrupt_ID'Image (Interrupt) & " is reserved"); - end if; - - return Ignored (Interrupt); - end Is_Ignored; - - --------------------- - -- Current_Handler -- - --------------------- - - function Current_Handler (Interrupt : Interrupt_ID) - return Parameterless_Handler is - begin - if Is_Reserved (Interrupt) then - Raise_Exception (Program_Error'Identity, "Interrupt" & - Interrupt_ID'Image (Interrupt) & " is reserved"); - end if; - - -- ??? Since Parameterless_Handler is not Atomic, the - -- current implementation is wrong. We need a new service in - -- Interrupt_Manager to ensure atomicity. - - return User_Handler (Interrupt).H; - end Current_Handler; - - -------------------- - -- Attach_Handler -- - -------------------- - - -- Calling this procedure with New_Handler = null and Static = True - -- means we want to detach the current handler regardless of the - -- previous handler's binding status (ie. do not care if it is a - -- dynamic or static handler). - - -- This option is needed so that during the finalization of a PO, we - -- can detach handlers attached through pragma Attach_Handler. - - procedure Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean := False) is - begin - if Is_Reserved (Interrupt) then - Raise_Exception (Program_Error'Identity, "Interrupt" & - Interrupt_ID'Image (Interrupt) & " is reserved"); - end if; - - Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); - - end Attach_Handler; - - ---------------------- - -- Exchange_Handler -- - ---------------------- - - -- Calling this procedure with New_Handler = null and Static = True - -- means we want to detach the current handler regardless of the - -- previous handler's binding status (ie. do not care if it is a - -- dynamic or static handler). - - -- This option is needed so that during the finalization of a PO, we - -- can detach handlers attached through pragma Attach_Handler. - - procedure Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean := False) is - begin - if Is_Reserved (Interrupt) then - Raise_Exception (Program_Error'Identity, "Interrupt" & - Interrupt_ID'Image (Interrupt) & " is reserved"); - end if; - - Interrupt_Manager.Exchange_Handler - (Old_Handler, New_Handler, Interrupt, Static); - - end Exchange_Handler; - - -------------------- - -- Detach_Handler -- - -------------------- - - -- Calling this procedure with Static = True means we want to Detach the - -- current handler regardless of the previous handler's binding status - -- (i.e. do not care if it is a dynamic or static handler). - - -- This option is needed so that during the finalization of a PO, we can - -- detach handlers attached through pragma Attach_Handler. - - procedure Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean := False) - is - begin - if Is_Reserved (Interrupt) then - Raise_Exception (Program_Error'Identity, "Interrupt" & - Interrupt_ID'Image (Interrupt) & " is reserved"); - end if; - - Interrupt_Manager.Detach_Handler (Interrupt, Static); - end Detach_Handler; - - --------------- - -- Reference -- - --------------- - - function Reference (Interrupt : Interrupt_ID) return System.Address is - begin - if Is_Reserved (Interrupt) then - Raise_Exception (Program_Error'Identity, "Interrupt" & - Interrupt_ID'Image (Interrupt) & " is reserved"); - end if; - - return Storage_Elements.To_Address - (Storage_Elements.Integer_Address (Interrupt)); - end Reference; - - ----------------------------- - -- Bind_Interrupt_To_Entry -- - ----------------------------- - - -- This procedure raises a Program_Error if it tries to - -- bind an interrupt to which an Entry or a Procedure is - -- already bound. - - procedure Bind_Interrupt_To_Entry - (T : Task_ID; - E : Task_Entry_Index; - Int_Ref : System.Address) - is - Interrupt : constant Interrupt_ID := - Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); - - begin - if Is_Reserved (Interrupt) then - Raise_Exception (Program_Error'Identity, "Interrupt" & - Interrupt_ID'Image (Interrupt) & " is reserved"); - end if; - - Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); - - end Bind_Interrupt_To_Entry; - - ------------------------------ - -- Detach_Interrupt_Entries -- - ------------------------------ - - procedure Detach_Interrupt_Entries (T : Task_ID) is - begin - Interrupt_Manager.Detach_Interrupt_Entries (T); - end Detach_Interrupt_Entries; - - --------------------- - -- Block_Interrupt -- - --------------------- - - procedure Block_Interrupt (Interrupt : Interrupt_ID) is - begin - if Is_Reserved (Interrupt) then - Raise_Exception (Program_Error'Identity, "Interrupt" & - Interrupt_ID'Image (Interrupt) & " is reserved"); - end if; - - Interrupt_Manager.Block_Interrupt (Interrupt); - end Block_Interrupt; - - ----------------------- - -- Unblock_Interrupt -- - ----------------------- - - procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is - begin - if Is_Reserved (Interrupt) then - Raise_Exception (Program_Error'Identity, "Interrupt" & - Interrupt_ID'Image (Interrupt) & " is reserved"); - end if; - - Interrupt_Manager.Unblock_Interrupt (Interrupt); - end Unblock_Interrupt; - - ------------------ - -- Unblocked_By -- - ------------------ - - function Unblocked_By - (Interrupt : Interrupt_ID) return System.Tasking.Task_ID is - begin - if Is_Reserved (Interrupt) then - Raise_Exception (Program_Error'Identity, "Interrupt" & - Interrupt_ID'Image (Interrupt) & " is reserved"); - end if; - - return Last_Unblocker (Interrupt); - end Unblocked_By; - - ---------------------- - -- Ignore_Interrupt -- - ---------------------- - - procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is - begin - if Is_Reserved (Interrupt) then - Raise_Exception (Program_Error'Identity, "Interrupt" & - Interrupt_ID'Image (Interrupt) & " is reserved"); - end if; - - Interrupt_Manager.Ignore_Interrupt (Interrupt); - end Ignore_Interrupt; - - ------------------------ - -- Unignore_Interrupt -- - ------------------------ - - procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is - begin - if Is_Reserved (Interrupt) then - Raise_Exception (Program_Error'Identity, "Interrupt" & - Interrupt_ID'Image (Interrupt) & " is reserved"); - end if; - - Interrupt_Manager.Unignore_Interrupt (Interrupt); - end Unignore_Interrupt; - - ----------------------- - -- Interrupt_Manager -- - ----------------------- - - task body Interrupt_Manager is - - --------------------- - -- Local Routines -- - --------------------- - - procedure Unprotected_Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False); - - procedure Unprotected_Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean); - - ---------------------------------- - -- Unprotected_Exchange_Handler -- - ---------------------------------- - - procedure Unprotected_Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False) - is - begin - if User_Entry (Interrupt).T /= Null_Task then - -- In case we have an Interrupt Entry already installed. - -- raise a program error. (propagate it to the caller). - - Raise_Exception (Program_Error'Identity, - "An interrupt is already installed"); - end if; - - -- Note : A null handler with Static = True will - -- pass the following check. That is the case when we want to - -- Detach a handler regardless of the Static status - -- of the current_Handler. - -- We don't check anything if Restoration is True, since we - -- may be detaching a static handler to restore a dynamic one. - - if not Restoration and then not Static - -- Tries to overwrite a static Interrupt Handler with a - -- dynamic Handler - - and then (User_Handler (Interrupt).Static - - -- The new handler is not specified as an - -- Interrupt Handler by a pragma. - - or else not Is_Registered (New_Handler)) - then - Raise_Exception (Program_Error'Identity, - "Trying to overwrite a static Interrupt Handler with a " & - "dynamic Handler"); - end if; - - -- The interrupt should no longer be ingnored if - -- it was ever ignored. - - Ignored (Interrupt) := False; - - -- Save the old handler - - Old_Handler := User_Handler (Interrupt).H; - - -- The new handler - - User_Handler (Interrupt).H := New_Handler; - - if New_Handler = null then - - -- The null handler means we are detaching the handler. - - User_Handler (Interrupt).Static := False; - - else - User_Handler (Interrupt).Static := Static; - end if; - - -- Invoke a corresponding Server_Task if not yet created. - -- Place Task_ID info in Server_ID array. - - if Server_ID (Interrupt) = Null_Task then - Access_Hold := new Server_Task (Interrupt); - Server_ID (Interrupt) := To_System (Access_Hold.all'Identity); - else - POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep); - end if; - - end Unprotected_Exchange_Handler; - - -------------------------------- - -- Unprotected_Detach_Handler -- - -------------------------------- - - procedure Unprotected_Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean) - is - begin - if User_Entry (Interrupt).T /= Null_Task then - -- In case we have an Interrupt Entry installed. - -- raise a program error. (propagate it to the caller). - - Raise_Exception (Program_Error'Identity, - "An interrupt entry is already installed"); - end if; - - -- Note : Static = True will pass the following check. That is the - -- case when we want to detach a handler regardless of the static - -- status of the current_Handler. - - if not Static and then User_Handler (Interrupt).Static then - -- Tries to detach a static Interrupt Handler. - -- raise a program error. - - Raise_Exception (Program_Error'Identity, - "Trying to detach a static Interrupt Handler"); - end if; - - -- The interrupt should no longer be ignored if - -- it was ever ignored. - - Ignored (Interrupt) := False; - - -- The new handler - - User_Handler (Interrupt).H := null; - User_Handler (Interrupt).Static := False; - IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (Interrupt)); - - end Unprotected_Detach_Handler; - - -- Start of processing for Interrupt_Manager - - begin - -- By making this task independent of master, when the process - -- goes away, the Interrupt_Manager will terminate gracefully. - - System.Tasking.Utilities.Make_Independent; - - -- Environmen task gets its own interrupt mask, saves it, - -- and then masks all interrupts except the Keep_Unmasked set. - - -- During rendezvous, the Interrupt_Manager receives the old - -- interrupt mask of the environment task, and sets its own - -- interrupt mask to that value. - - -- The environment task will call the entry of Interrupt_Manager some - -- during elaboration of the body of this package. - - accept Initialize (Mask : IMNG.Interrupt_Mask) do - pragma Warnings (Off, Mask); - null; - end Initialize; - - -- Note: All tasks in RTS will have all the Reserve Interrupts - -- being masked (except the Interrupt_Manager) and Keep_Unmasked - -- unmasked when created. - - -- Abort_Task_Interrupt is one of the Interrupt unmasked - -- in all tasks. We mask the Interrupt in this particular task - -- so that "sigwait" is possible to catch an explicitely sent - -- Abort_Task_Interrupt from the Server_Tasks. - - -- This sigwaiting is needed so that we make sure a Server_Task is - -- out of its own sigwait state. This extra synchronization is - -- necessary to prevent following senarios. - - -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the - -- Server_Task then changes its own interrupt mask (OS level). - -- If an interrupt (corresponding to the Server_Task) arrives - -- in the nean time we have the Interrupt_Manager umnasked and - -- the Server_Task waiting on sigwait. - - -- 2) For unbinding handler, we install a default action in the - -- Interrupt_Manager. POSIX.1c states that the result of using - -- "sigwait" and "sigaction" simaltaneously on the same interrupt - -- is undefined. Therefore, we need to be informed from the - -- Server_Task of the fact that the Server_Task is out of its - -- sigwait stage. - - loop - -- A block is needed to absorb Program_Error exception - - declare - Old_Handler : Parameterless_Handler; - begin - select - - accept Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False) - do - Unprotected_Exchange_Handler - (Old_Handler, New_Handler, Interrupt, Static, Restoration); - end Attach_Handler; - - or accept Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean) - do - Unprotected_Exchange_Handler - (Old_Handler, New_Handler, Interrupt, Static); - end Exchange_Handler; - - or accept Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean) - do - Unprotected_Detach_Handler (Interrupt, Static); - end Detach_Handler; - - or accept Bind_Interrupt_To_Entry - (T : Task_ID; - E : Task_Entry_Index; - Interrupt : Interrupt_ID) - do - -- if there is a binding already (either a procedure or an - -- entry), raise Program_Error (propagate it to the caller). - - if User_Handler (Interrupt).H /= null - or else User_Entry (Interrupt).T /= Null_Task - then - Raise_Exception (Program_Error'Identity, - "A binding for this interrupt is already present"); - end if; - - -- The interrupt should no longer be ingnored if - -- it was ever ignored. - - Ignored (Interrupt) := False; - User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E); - - -- Indicate the attachment of Interrupt Entry in ATCB. - -- This is need so that when an Interrupt Entry task - -- terminates the binding can be cleaned. - -- The call to unbinding must be - -- make by the task before it terminates. - - T.Interrupt_Entry := True; - - -- Invoke a corresponding Server_Task if not yet created. - -- Place Task_ID info in Server_ID array. - - if Server_ID (Interrupt) = Null_Task then - - Access_Hold := new Server_Task (Interrupt); - Server_ID (Interrupt) := - To_System (Access_Hold.all'Identity); - else - POP.Wakeup (Server_ID (Interrupt), - Interrupt_Server_Idle_Sleep); - end if; - end Bind_Interrupt_To_Entry; - - or accept Detach_Interrupt_Entries (T : Task_ID) - do - for J in Interrupt_ID'Range loop - if not Is_Reserved (J) then - if User_Entry (J).T = T then - - -- The interrupt should no longer be ignored if - -- it was ever ignored. - - Ignored (J) := False; - User_Entry (J) := - Entry_Assoc'(T => Null_Task, E => Null_Task_Entry); - IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (J)); - end if; - end if; - end loop; - - -- Indicate in ATCB that no Interrupt Entries are attached. - - T.Interrupt_Entry := False; - end Detach_Interrupt_Entries; - - or accept Block_Interrupt (Interrupt : Interrupt_ID) do - pragma Warnings (Off, Interrupt); - raise Program_Error; - end Block_Interrupt; - - or accept Unblock_Interrupt (Interrupt : Interrupt_ID) do - pragma Warnings (Off, Interrupt); - raise Program_Error; - end Unblock_Interrupt; - - or accept Ignore_Interrupt (Interrupt : Interrupt_ID) do - pragma Warnings (Off, Interrupt); - raise Program_Error; - end Ignore_Interrupt; - - or accept Unignore_Interrupt (Interrupt : Interrupt_ID) do - pragma Warnings (Off, Interrupt); - raise Program_Error; - end Unignore_Interrupt; - - end select; - - exception - -- If there is a program error we just want to propagate it - -- to the caller and do not want to stop this task. - - when Program_Error => - null; - - when others => - pragma Assert (False); - null; - end; - end loop; - end Interrupt_Manager; - - ----------------- - -- Server_Task -- - ----------------- - - task body Server_Task is - Self_ID : constant Task_ID := Self; - Tmp_Handler : Parameterless_Handler; - Tmp_ID : Task_ID; - Tmp_Entry_Index : Task_Entry_Index; - Intwait_Mask : aliased IMNG.Interrupt_Mask; - - begin - -- By making this task independent of master, when the process - -- goes away, the Server_Task will terminate gracefully. - - System.Tasking.Utilities.Make_Independent; - - -- Install default action in system level. - - IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); - - -- Set up the mask (also clears the event flag) - - IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); - IMOP.Add_To_Interrupt_Mask - (Intwait_Mask'Access, IMNG.Interrupt_ID (Interrupt)); - - -- Remember the Interrupt_ID for Abort_Task. - - PIO.Set_Interrupt_ID (IMNG.Interrupt_ID (Interrupt), Self_ID); - - -- Note: All tasks in RTS will have all the Reserve Interrupts - -- being masked (except the Interrupt_Manager) and Keep_Unmasked - -- unmasked when created. - - loop - System.Tasking.Initialization.Defer_Abort (Self_ID); - - -- A Handler or an Entry is installed. At this point all tasks - -- mask for the Interrupt is masked. Catch the Interrupt using - -- sigwait. - - -- This task may wake up from sigwait by receiving an interrupt - -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding - -- a Procedure Handler or an Entry. Or it could be a wake up - -- from status change (Unblocked -> Blocked). If that is not - -- the case, we should exceute the attached Procedure or Entry. - - if Single_Lock then - POP.Lock_RTS; - end if; - - POP.Write_Lock (Self_ID); - - if User_Handler (Interrupt).H = null - and then User_Entry (Interrupt).T = Null_Task - then - -- No Interrupt binding. If there is an interrupt, - -- Interrupt_Manager will take default action. - - Self_ID.Common.State := Interrupt_Server_Idle_Sleep; - POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep); - Self_ID.Common.State := Runnable; - - else - Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag; - Self_ID.Common.State := Runnable; - - if not (Self_ID.Deferral_Level = 0 - and then Self_ID.Pending_ATC_Level - < Self_ID.ATC_Nesting_Level) - then - if User_Handler (Interrupt).H /= null then - Tmp_Handler := User_Handler (Interrupt).H; - - -- RTS calls should not be made with self being locked. - - POP.Unlock (Self_ID); - - if Single_Lock then - POP.Unlock_RTS; - end if; - - Tmp_Handler.all; - - if Single_Lock then - POP.Lock_RTS; - end if; - - POP.Write_Lock (Self_ID); - - elsif User_Entry (Interrupt).T /= Null_Task then - Tmp_ID := User_Entry (Interrupt).T; - Tmp_Entry_Index := User_Entry (Interrupt).E; - - -- RTS calls should not be made with self being locked. - - POP.Unlock (Self_ID); - - if Single_Lock then - POP.Unlock_RTS; - end if; - - System.Tasking.Rendezvous.Call_Simple - (Tmp_ID, Tmp_Entry_Index, System.Null_Address); - - if Single_Lock then - POP.Lock_RTS; - end if; - - POP.Write_Lock (Self_ID); - end if; - end if; - end if; - - POP.Unlock (Self_ID); - - if Single_Lock then - POP.Unlock_RTS; - end if; - - System.Tasking.Initialization.Undefer_Abort (Self_ID); - - -- Undefer abort here to allow a window for this task - -- to be aborted at the time of system shutdown. - end loop; - end Server_Task; - - ------------------------------------- - -- Has_Interrupt_Or_Attach_Handler -- - ------------------------------------- - - function Has_Interrupt_Or_Attach_Handler - (Object : access Dynamic_Interrupt_Protection) - return Boolean - is - pragma Warnings (Off, Object); - - begin - return True; - end Has_Interrupt_Or_Attach_Handler; - - ---------------- - -- Finalize -- - ---------------- - - procedure Finalize (Object : in out Static_Interrupt_Protection) is - begin - -- ??? loop to be executed only when we're not doing library level - -- finalization, since in this case all interrupt tasks are gone. - if not Interrupt_Manager'Terminated then - for N in reverse Object.Previous_Handlers'Range loop - Interrupt_Manager.Attach_Handler - (New_Handler => Object.Previous_Handlers (N).Handler, - Interrupt => Object.Previous_Handlers (N).Interrupt, - Static => Object.Previous_Handlers (N).Static, - Restoration => True); - end loop; - end if; - - Tasking.Protected_Objects.Entries.Finalize - (Tasking.Protected_Objects.Entries.Protection_Entries (Object)); - end Finalize; - - ------------------------------------- - -- Has_Interrupt_Or_Attach_Handler -- - ------------------------------------- - - function Has_Interrupt_Or_Attach_Handler - (Object : access Static_Interrupt_Protection) - return Boolean - is - pragma Warnings (Off, Object); - begin - return True; - end Has_Interrupt_Or_Attach_Handler; - - ---------------------- - -- Install_Handlers -- - ---------------------- - - procedure Install_Handlers - (Object : access Static_Interrupt_Protection; - New_Handlers : New_Handler_Array) - is - begin - for N in New_Handlers'Range loop - - -- We need a lock around this ??? - - Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt; - Object.Previous_Handlers (N).Static := User_Handler - (New_Handlers (N).Interrupt).Static; - - -- We call Exchange_Handler and not directly Interrupt_Manager. - -- Exchange_Handler so we get the Is_Reserved check. - - Exchange_Handler - (Old_Handler => Object.Previous_Handlers (N).Handler, - New_Handler => New_Handlers (N).Handler, - Interrupt => New_Handlers (N).Interrupt, - Static => True); - end loop; - end Install_Handlers; - --- Elaboration code for package System.Interrupts -begin - - -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent. - - Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); - - -- During the elaboration of this package body we want RTS to - -- inherit the interrupt mask from the Environment Task. - - -- The Environment Task should have gotten its mask from - -- the enclosing process during the RTS start up. (See - -- in s-inmaop.adb). Pass the Interrupt_Mask of the Environment - -- task to the Interrupt_Manager. - - -- Note : At this point we know that all tasks (including - -- RTS internal servers) are masked for non-reserved signals - -- (see s-taprop.adb). Only the Interrupt_Manager will have - -- masks set up differently inheriting the original Environment - -- Task's mask. - - Interrupt_Manager.Initialize (IMOP.Environment_Mask); -end System.Interrupts; diff --git a/gcc/ada/5vintman.adb b/gcc/ada/5vintman.adb deleted file mode 100644 index 1190378766f..00000000000 --- a/gcc/ada/5vintman.adb +++ /dev/null @@ -1,88 +0,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-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 OpenVMS/Alpha version of this package. - --- PLEASE DO NOT add any dependences on other packages. --- 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. - -with System.OS_Interface; --- used for various Constants, Signal and types - -package body System.Interrupt_Management is - - use System.OS_Interface; - use type unsigned_long; - - --------------------------- - -- Initialize_Interrupts -- - --------------------------- - - procedure Initialize_Interrupts is - Status : Cond_Value_Type; - - begin - Sys_Crembx - (Status => Status, - Prmflg => False, - Chan => Rcv_Interrupt_Chan, - Maxmsg => Interrupt_ID'Size, - Bufquo => Interrupt_Bufquo, - Lognam => "GNAT_Interrupt_Mailbox", - Flags => CMB_M_READONLY); - - pragma Assert ((Status and 1) = 1); - - Sys_Assign - (Status => Status, - Devnam => "GNAT_Interrupt_Mailbox", - Chan => Snd_Interrupt_Chan, - Flags => AGN_M_WRITEONLY); - - pragma Assert ((Status and 1) = 1); - end Initialize_Interrupts; - -begin - -- Unused - - Abort_Task_Interrupt := Interrupt_ID_0; - - Reserve := Reserve or Keep_Unmasked or Keep_Masked; - - Reserve (Interrupt_ID_0) := True; - - Initialize_Interrupts; -end System.Interrupt_Management; diff --git a/gcc/ada/5vintman.ads b/gcc/ada/5vintman.ads deleted file mode 100644 index 60f410b01d7..00000000000 --- a/gcc/ada/5vintman.ads +++ /dev/null @@ -1,142 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-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 Alpha/VMS version of this package. --- --- This package encapsulates and centralizes information about --- all uses of interrupts (or signals), including the --- target-dependent mapping of interrupts (or signals) to exceptions. - --- PLEASE DO NOT add any with-clauses to this package. --- This is designed to work for both tasking and non-tasking systems, --- without pulling in any of the tasking support. - --- PLEASE DO NOT remove the Elaborate_Body pragma from this package. --- Elaboration of this package should happen early, as most other --- initializations depend on it. --- Forcing immediate elaboration of the body also helps to enforce --- the design assumption that this is a second-level --- package, just one level above System.OS_Interface, with no --- cross-dependences. - --- PLEASE DO NOT put any subprogram declarations with arguments of --- type Interrupt_ID into the visible part of this package. --- The type Interrupt_ID is used to derive the type in Ada.Interrupts, --- and adding more operations to that type would be illegal according --- to the Ada Reference Manual. (This is the reason why the signals sets --- below are implemented as visible arrays rather than functions.) - -with System.OS_Interface; --- used for Signal --- sigset_t - -package System.Interrupt_Management is - - pragma Elaborate_Body; - - type Interrupt_Mask is limited private; - - type Interrupt_ID is new System.OS_Interface.Signal; - - type Interrupt_Set is array (Interrupt_ID) of Boolean; - - -- The following objects serve as constants, but are initialized - -- in the body to aid portability. This permits us - -- to use more portable names for interrupts, - -- where distinct names may map to the same interrupt ID value. - -- For example, suppose SIGRARE is a signal that is not defined on - -- all systems, but is always reserved when it is defined. - -- If we have the convention that ID zero is not used for any "real" - -- signals, and SIGRARE = 0 when SIGRARE is not one of the locally - -- supported signals, we can write - -- Reserved (SIGRARE) := true; - -- and the initialization code will be portable. - - Abort_Task_Interrupt : Interrupt_ID; - -- The interrupt that is used to implement task abortion, - -- if an interrupt is used for that purpose. - -- This is one of the reserved interrupts. - - Keep_Unmasked : Interrupt_Set := (others => False); - -- Keep_Unmasked (I) is true iff the interrupt I is - -- one that must be kept unmasked at all times, - -- except (perhaps) for short critical sections. - -- This includes interrupts that are mapped to exceptions - -- (see System.Interrupt_Exceptions.Is_Exception), but may also - -- include interrupts (e.g. timer) that need to be kept unmasked - -- for other reasons. - -- Where interrupts are implemented as OS signals, and signal masking - -- is per-task, the interrupt should be unmasked in ALL TASKS. - - Reserve : Interrupt_Set := (others => False); - -- Reserve (I) is true iff the interrupt I is one that - -- cannot be permitted to be attached to a user handler. - -- The possible reasons are many. For example, - -- it may be mapped to an exception, used to implement task abortion, - -- or used to implement time delays. - - Keep_Masked : Interrupt_Set := (others => False); - -- Keep_Masked (I) is true iff the interrupt I must always be masked. - -- Where interrupts are implemented as OS signals, and signal masking - -- is per-task, the interrupt should be masked in ALL TASKS. - -- There might not be any interrupts in this class, depending on - -- the environment. For example, if interrupts are OS signals - -- and signal masking is per-task, use of the sigwait operation - -- requires the signal be masked in all tasks. - - procedure Initialize_Interrupts; - -- On systems where there is no signal inheritance between tasks (e.g - -- VxWorks, GNU/LinuxThreads), this procedure is used to initialize - -- interrupts handling in each task. Otherwise this function should - -- only be called by initialize in this package body. - -private - - use type System.OS_Interface.unsigned_long; - - type Interrupt_Mask is new System.OS_Interface.sigset_t; - - -- Interrupts on VMS are implemented with a mailbox. A QIO read is - -- registered on the Rcv channel and the interrupt occurs by registering - -- a QIO write on the Snd channel. The maximum number of pending - -- interrupts is arbitrarily set at 1000. One nice feature of using - -- a mailbox is that it is trivially extendable to cross process - -- interrupts. - - Rcv_Interrupt_Chan : System.OS_Interface.unsigned_short := 0; - Snd_Interrupt_Chan : System.OS_Interface.unsigned_short := 0; - Interrupt_Mailbox : Interrupt_ID := 0; - Interrupt_Bufquo : System.OS_Interface.unsigned_long - := 1000 * (Interrupt_ID'Size / 8); - -end System.Interrupt_Management; diff --git a/gcc/ada/5vmastop.adb b/gcc/ada/5vmastop.adb deleted file mode 100644 index 5bb3f8a1eff..00000000000 --- a/gcc/ada/5vmastop.adb +++ /dev/null @@ -1,339 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- SYSTEM.MACHINE_STATE_OPERATIONS -- --- -- --- B o d y -- --- (Version for Alpha/VMS) -- --- -- --- Copyright (C) 2001-2002 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 of System.Machine_State_Operations is for use on --- Alpha systems running VMS. - -with System.Memory; -with System.Aux_DEC; use System.Aux_DEC; -with Unchecked_Conversion; - -package body System.Machine_State_Operations is - - use System.Exceptions; - subtype Cond_Value_Type is Unsigned_Longword; - - -- Record layouts copied from Starlet. - - type ICB_Fflags_Bits_Type is record - Exception_Frame : Boolean; - Ast_Frame : Boolean; - Bottom_Of_Stack : Boolean; - Base_Frame : Boolean; - Filler_1 : Unsigned_20; - end record; - - for ICB_Fflags_Bits_Type use record - Exception_Frame at 0 range 0 .. 0; - Ast_Frame at 0 range 1 .. 1; - Bottom_Of_Stack at 0 range 2 .. 2; - Base_Frame at 0 range 3 .. 3; - Filler_1 at 0 range 4 .. 23; - end record; - for ICB_Fflags_Bits_Type'Size use 24; - - type ICB_Hdr_Quad_Type is record - Context_Length : Unsigned_Longword; - Fflags_Bits : ICB_Fflags_Bits_Type; - Block_Version : Unsigned_Byte; - end record; - - for ICB_Hdr_Quad_Type use record - Context_Length at 0 range 0 .. 31; - Fflags_Bits at 4 range 0 .. 23; - Block_Version at 7 range 0 .. 7; - end record; - for ICB_Hdr_Quad_Type'Size use 64; - - type Invo_Context_Blk_Type is record - - Hdr_Quad : ICB_Hdr_Quad_Type; - -- The first quadword contains: - -- o The length of the structure in bytes (a longword field) - -- o The frame flags (a 3 byte field of bits) - -- o The version number (a 1 byte field) - - Procedure_Descriptor : Unsigned_Quadword; - -- The address of the procedure descriptor for the procedure - - Program_Counter : Integer_64; - -- The current PC of a given procedure invocation - - Processor_Status : Integer_64; - -- The current PS of a given procedure invocation - - Ireg : Unsigned_Quadword_Array (0 .. 30); - Freg : Unsigned_Quadword_Array (0 .. 30); - -- The register contents areas. 31 for scalars, 31 for float. - - System_Defined : Unsigned_Quadword_Array (0 .. 1); - -- The following is an "internal" area that's reserved for use by - -- the operating system. It's size may vary over time. - - -- Chfctx_Addr : Unsigned_Quadword; - -- Defined as a comment since it overlaps other fields - - Filler_1 : String (1 .. 0); - -- Align to octaword - end record; - - for Invo_Context_Blk_Type use record - Hdr_Quad at 0 range 0 .. 63; - Procedure_Descriptor at 8 range 0 .. 63; - Program_Counter at 16 range 0 .. 63; - Processor_Status at 24 range 0 .. 63; - Ireg at 32 range 0 .. 1983; - Freg at 280 range 0 .. 1983; - System_Defined at 528 range 0 .. 127; - - -- Component representation spec(s) below are defined as - -- comments since they overlap other fields - - -- Chfctx_Addr at 528 range 0 .. 63; - - Filler_1 at 544 range 0 .. -1; - end record; - for Invo_Context_Blk_Type'Size use 4352; - - subtype Invo_Handle_Type is Unsigned_Longword; - - type Invo_Handle_Access_Type is access all Invo_Handle_Type; - - function Fetch is new Fetch_From_Address (Code_Loc); - - function To_Invo_Handle_Access is new Unchecked_Conversion - (Machine_State, Invo_Handle_Access_Type); - - function To_Machine_State is new Unchecked_Conversion - (System.Address, Machine_State); - - ---------------------------- - -- Allocate_Machine_State -- - ---------------------------- - - function Allocate_Machine_State return Machine_State is - begin - return To_Machine_State - (Memory.Alloc (Invo_Handle_Type'Max_Size_In_Storage_Elements)); - end Allocate_Machine_State; - - ------------------- - -- Enter_Handler -- - ------------------- - - procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is - procedure Get_Invo_Context ( - Result : out Unsigned_Longword; -- return value - Invo_Handle : Invo_Handle_Type; - Invo_Context : out Invo_Context_Blk_Type); - - pragma Interface (External, Get_Invo_Context); - - pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT", - (Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type), - (Value, Value, Reference)); - - ICB : Invo_Context_Blk_Type; - - procedure Goto_Unwind ( - Status : out Cond_Value_Type; -- return value - Target_Invo : Address := Address_Zero; - Target_PC : Address := Address_Zero; - New_R0 : Unsigned_Quadword := Unsigned_Quadword'Null_Parameter; - New_R1 : Unsigned_Quadword := Unsigned_Quadword'Null_Parameter); - - pragma Interface (External, Goto_Unwind); - - pragma Import_Valued_Procedure - (Goto_Unwind, "SYS$GOTO_UNWIND", - (Cond_Value_Type, Address, Address, - Unsigned_Quadword, Unsigned_Quadword), - (Value, Reference, Reference, - Reference, Reference)); - - Status : Cond_Value_Type; - - begin - Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB); - Goto_Unwind - (Status, System.Address (To_Invo_Handle_Access (M).all), Handler); - end Enter_Handler; - - ---------------- - -- Fetch_Code -- - ---------------- - - function Fetch_Code (Loc : Code_Loc) return Code_Loc is - begin - -- The starting address is in the second longword pointed to by Loc. - - return Fetch (System.Aux_DEC."+" (Loc, 8)); - end Fetch_Code; - - ------------------------ - -- Free_Machine_State -- - ------------------------ - - procedure Free_Machine_State (M : in out Machine_State) is - begin - Memory.Free (Address (M)); - M := Machine_State (Null_Address); - end Free_Machine_State; - - ------------------ - -- Get_Code_Loc -- - ------------------ - - function Get_Code_Loc (M : Machine_State) return Code_Loc is - procedure Get_Invo_Context ( - Result : out Unsigned_Longword; -- return value - Invo_Handle : in Invo_Handle_Type; - Invo_Context : out Invo_Context_Blk_Type); - - pragma Interface (External, Get_Invo_Context); - - pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT", - (Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type), - (Value, Value, Reference)); - - Asm_Call_Size : constant := 4; - -- Under VMS a call - -- asm instruction takes 4 bytes. So we must remove this amount. - - ICB : Invo_Context_Blk_Type; - Status : Cond_Value_Type; - - begin - Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB); - - if (Status and 1) /= 1 then - return Code_Loc (System.Null_Address); - end if; - - return Code_Loc (ICB.Program_Counter - Asm_Call_Size); - end Get_Code_Loc; - - -------------------------- - -- Machine_State_Length -- - -------------------------- - - function Machine_State_Length - return System.Storage_Elements.Storage_Offset - is - use System.Storage_Elements; - - begin - return Invo_Handle_Type'Size / 8; - end Machine_State_Length; - - --------------- - -- Pop_Frame -- - --------------- - - procedure Pop_Frame - (M : Machine_State; - Info : Subprogram_Info_Type) - is - pragma Warnings (Off, Info); - - procedure Get_Prev_Invo_Handle ( - Result : out Invo_Handle_Type; -- return value - ICB : in Invo_Handle_Type); - - pragma Interface (External, Get_Prev_Invo_Handle); - - pragma Import_Valued_Procedure - (Get_Prev_Invo_Handle, "LIB$GET_PREV_INVO_HANDLE", - (Invo_Handle_Type, Invo_Handle_Type), - (Value, Value)); - - Prev_Handle : aliased Invo_Handle_Type; - - begin - Get_Prev_Invo_Handle (Prev_Handle, To_Invo_Handle_Access (M).all); - To_Invo_Handle_Access (M).all := Prev_Handle; - end Pop_Frame; - - ----------------------- - -- Set_Machine_State -- - ----------------------- - - procedure Set_Machine_State (M : Machine_State) is - - procedure Get_Curr_Invo_Context - (Invo_Context : out Invo_Context_Blk_Type); - - pragma Interface (External, Get_Curr_Invo_Context); - - pragma Import_Valued_Procedure - (Get_Curr_Invo_Context, "LIB$GET_CURR_INVO_CONTEXT", - (Invo_Context_Blk_Type), - (Reference)); - - procedure Get_Invo_Handle ( - Result : out Invo_Handle_Type; -- return value - Invo_Context : in Invo_Context_Blk_Type); - - pragma Interface (External, Get_Invo_Handle); - - pragma Import_Valued_Procedure (Get_Invo_Handle, "LIB$GET_INVO_HANDLE", - (Invo_Handle_Type, Invo_Context_Blk_Type), - (Value, Reference)); - - ICB : Invo_Context_Blk_Type; - Invo_Handle : aliased Invo_Handle_Type; - - begin - Get_Curr_Invo_Context (ICB); - Get_Invo_Handle (Invo_Handle, ICB); - To_Invo_Handle_Access (M).all := Invo_Handle; - Pop_Frame (M, System.Null_Address); - end Set_Machine_State; - - ------------------------------ - -- Set_Signal_Machine_State -- - ------------------------------ - - procedure Set_Signal_Machine_State - (M : Machine_State; - Context : System.Address) - is - pragma Warnings (Off, M); - pragma Warnings (Off, Context); - - begin - null; - end Set_Signal_Machine_State; - -end System.Machine_State_Operations; diff --git a/gcc/ada/5vml-tgt.adb b/gcc/ada/5vml-tgt.adb deleted file mode 100644 index 6db0dccb9dc..00000000000 --- a/gcc/ada/5vml-tgt.adb +++ /dev/null @@ -1,703 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T -- --- (VMS Version) -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-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. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VMS version of the body - -with Ada.Characters.Handling; use Ada.Characters.Handling; - -with GNAT.Directory_Operations; use GNAT.Directory_Operations; -with GNAT.OS_Lib; use GNAT.OS_Lib; - -with MLib.Fil; -with MLib.Utl; -with Namet; use Namet; -with Opt; use Opt; -with Output; use Output; -with Prj.Com; -with System; use System; -with System.Case_Util; use System.Case_Util; - -package body MLib.Tgt is - - use GNAT; - - Empty_Argument_List : aliased Argument_List := (1 .. 0 => null); - Additional_Objects : Argument_List_Access := Empty_Argument_List'Access; - -- Used to add the generated auto-init object files for auto-initializing - -- stand-alone libraries. - - Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler"; - -- The name of the command to invoke the macro-assembler - - VMS_Options : Argument_List := (1 .. 1 => null); - - Gnatsym_Name : constant String := "gnatsym"; - - Gnatsym_Path : String_Access; - - Arguments : Argument_List_Access := null; - Last_Argument : Natural := 0; - - Success : Boolean := False; - - Shared_Libgcc : aliased String := "-shared-libgcc"; - - No_Shared_Libgcc_Switch : aliased Argument_List := (1 .. 0 => null); - Shared_Libgcc_Switch : aliased Argument_List := - (1 => Shared_Libgcc'Access); - Link_With_Shared_Libgcc : Argument_List_Access := - No_Shared_Libgcc_Switch'Access; - - ------------------------------ - -- Target dependent section -- - ------------------------------ - - function Popen (Command, Mode : System.Address) return System.Address; - pragma Import (C, Popen); - - function Pclose (File : System.Address) return Integer; - pragma Import (C, Pclose); - - --------------------- - -- Archive_Builder -- - --------------------- - - function Archive_Builder return String is - begin - return "ar"; - end Archive_Builder; - - ----------------------------- - -- Archive_Builder_Options -- - ----------------------------- - - function Archive_Builder_Options return String_List_Access is - begin - return new String_List'(1 => new String'("cr")); - end Archive_Builder_Options; - - ----------------- - -- Archive_Ext -- - ----------------- - - function Archive_Ext return String is - begin - return "olb"; - end Archive_Ext; - - --------------------- - -- Archive_Indexer -- - --------------------- - - function Archive_Indexer return String is - begin - return "ranlib"; - end Archive_Indexer; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Foreign : Argument_List; - Afiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Address : String := ""; - Lib_Version : String := ""; - Relocatable : Boolean := False; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Foreign); - pragma Unreferenced (Afiles); - pragma Unreferenced (Lib_Address); - pragma Unreferenced (Relocatable); - - Lib_File : constant String := - Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Filename, DLL_Ext); - - Opts : Argument_List := Options; - Last_Opt : Natural := Opts'Last; - Opts2 : Argument_List (Options'Range); - Last_Opt2 : Natural := Opts2'First - 1; - - Inter : constant Argument_List := Interfaces; - - function Is_Interface (Obj_File : String) return Boolean; - -- For a Stand-Alone Library, returns True if Obj_File is the object - -- file name of an interface of the SAL. - -- For other libraries, always return True. - - function Option_File_Name return String; - -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt" - - function Version_String return String; - -- Returns Lib_Version if not empty, otherwise returns "1". - -- Fails gnatmake if Lib_Version is not the image of a positive number. - - ------------------ - -- Is_Interface -- - ------------------ - - function Is_Interface (Obj_File : String) return Boolean is - ALI : constant String := - Fil.Ext_To - (Filename => To_Lower (Base_Name (Obj_File)), - New_Ext => "ali"); - - begin - if Inter'Length = 0 then - return True; - - elsif ALI'Length > 2 and then - ALI (ALI'First .. ALI'First + 1) = "b$" - then - return True; - - else - for J in Inter'Range loop - if Inter (J).all = ALI then - return True; - end if; - end loop; - - return False; - end if; - end Is_Interface; - - ---------------------- - -- Option_File_Name -- - ---------------------- - - function Option_File_Name return String is - begin - if Symbol_Data.Symbol_File = No_Name then - return "symvec.opt"; - else - Get_Name_String (Symbol_Data.Symbol_File); - To_Lower (Name_Buffer (1 .. Name_Len)); - return Name_Buffer (1 .. Name_Len); - end if; - end Option_File_Name; - - -------------------- - -- Version_String -- - -------------------- - - function Version_String return String is - Version : Integer := 0; - begin - if Lib_Version = "" then - return "1"; - - else - begin - Version := Integer'Value (Lib_Version); - - if Version <= 0 then - raise Constraint_Error; - end if; - - return Lib_Version; - - exception - when Constraint_Error => - Fail ("illegal version """, Lib_Version, - """ (on VMS version must be a positive number)"); - return ""; - end; - end if; - end Version_String; - - Opt_File_Name : constant String := Option_File_Name; - Version : constant String := Version_String; - For_Linker_Opt : String_Access; - - -- Start of processing for Build_Dynamic_Library - - begin - -- Invoke gcc with -shared-libgcc, but only for GCC 3 or higher - - if GCC_Version >= 3 then - Link_With_Shared_Libgcc := Shared_Libgcc_Switch'Access; - else - Link_With_Shared_Libgcc := No_Shared_Libgcc_Switch'Access; - end if; - - -- If option file name does not ends with ".opt", append "/OPTIONS" - -- to its specification for the VMS linker. - - if Opt_File_Name'Length > 4 - and then - Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt" - then - For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name); - else - For_Linker_Opt := - new String'("--for-linker=" & Opt_File_Name & "/OPTIONS"); - end if; - - VMS_Options (VMS_Options'First) := For_Linker_Opt; - - for J in Inter'Range loop - To_Lower (Inter (J).all); - end loop; - - -- "gnatsym" is necessary for building the option file - - if Gnatsym_Path = null then - Gnatsym_Path := OS_Lib.Locate_Exec_On_Path (Gnatsym_Name); - - if Gnatsym_Path = null then - Fail (Gnatsym_Name, " not found in path"); - end if; - end if; - - -- For auto-initialization of a stand-alone library, we create - -- a macro-assembly file and we invoke the macro-assembler. - - if Auto_Init then - declare - Macro_File_Name : constant String := Lib_Filename & "$init.asm"; - Macro_File : File_Descriptor; - Init_Proc : String := Lib_Filename & "INIT"; - Popen_Result : System.Address; - Pclose_Result : Integer; - Len : Natural; - OK : Boolean := True; - - Command : constant String := - Macro_Name & " " & Macro_File_Name & ASCII.NUL; - -- The command to invoke the assembler on the generated auto-init - -- assembly file. - - Mode : constant String := "r" & ASCII.NUL; - -- The mode for the invocation of Popen - - begin - To_Upper (Init_Proc); - - if Verbose_Mode then - Write_Str ("Creating auto-init assembly file """); - Write_Str (Macro_File_Name); - Write_Line (""""); - end if; - - -- Create and write the auto-init assembly file - - declare - First_Line : constant String := - ASCII.HT & ".section LIB$INITIALIZE,GBL,NOWRT" & - ASCII.LF; - Second_Line : constant String := - ASCII.HT & ".long " & Init_Proc & ASCII.LF; - -- First and second lines of the auto-init assembly file - - begin - Macro_File := Create_File (Macro_File_Name, Text); - OK := Macro_File /= Invalid_FD; - - if OK then - Len := Write - (Macro_File, First_Line (First_Line'First)'Address, - First_Line'Length); - OK := Len = First_Line'Length; - end if; - - if OK then - Len := Write - (Macro_File, Second_Line (Second_Line'First)'Address, - Second_Line'Length); - OK := Len = Second_Line'Length; - end if; - - if OK then - Close (Macro_File, OK); - end if; - - if not OK then - Fail ("creation of auto-init assembly file """, - Macro_File_Name, """ failed"); - end if; - end; - - -- Invoke the macro-assembler - - if Verbose_Mode then - Write_Str ("Assembling auto-init assembly file """); - Write_Str (Macro_File_Name); - Write_Line (""""); - end if; - - Popen_Result := Popen (Command (Command'First)'Address, - Mode (Mode'First)'Address); - - if Popen_Result = Null_Address then - Fail ("assembly of auto-init assembly file """, - Macro_File_Name, """ failed"); - end if; - - -- Wait for the end of execution of the macro-assembler - - Pclose_Result := Pclose (Popen_Result); - - if Pclose_Result < 0 then - Fail ("assembly of auto init assembly file """, - Macro_File_Name, """ failed"); - end if; - - -- Add the generated object file to the list of objects to be - -- included in the library. - - Additional_Objects := - new Argument_List' - (1 => new String'(Lib_Filename & "$init.obj")); - end; - end if; - - -- Allocate the argument list and put the symbol file name, the - -- reference (if any) and the policy (if not autonomous). - - Arguments := new Argument_List (1 .. Ofiles'Length + 8); - - Last_Argument := 0; - - -- Verbosity - - if Verbose_Mode then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-v"); - end if; - - -- Version number (major ID) - - if Lib_Version /= "" then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-V"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Version); - end if; - - -- Symbol file - - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-s"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Opt_File_Name); - - -- Reference Symbol File - - if Symbol_Data.Reference /= No_Name then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-r"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := - new String'(Get_Name_String (Symbol_Data.Reference)); - end if; - - -- Policy - - case Symbol_Data.Symbol_Policy is - when Autonomous => - null; - - when Compliant => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-c"); - - when Controlled => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-C"); - end case; - - -- Add each relevant object file - - for Index in Ofiles'Range loop - if Is_Interface (Ofiles (Index).all) then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Ofiles (Index).all); - end if; - end loop; - - -- Spawn gnatsym - - Spawn (Program_Name => Gnatsym_Path.all, - Args => Arguments (1 .. Last_Argument), - Success => Success); - - if not Success then - Fail ("unable to create symbol file for library """, - Lib_Filename, """"); - end if; - - Free (Arguments); - - -- Move all the -l switches from Opts to Opts2 - - declare - Index : Natural := Opts'First; - Opt : String_Access; - - begin - while Index <= Last_Opt loop - Opt := Opts (Index); - - if Opt'Length > 2 and then - Opt (Opt'First .. Opt'First + 1) = "-l" - then - if Index < Last_Opt then - Opts (Index .. Last_Opt - 1) := - Opts (Index + 1 .. Last_Opt); - end if; - - Last_Opt := Last_Opt - 1; - - Last_Opt2 := Last_Opt2 + 1; - Opts2 (Last_Opt2) := Opt; - - else - Index := Index + 1; - end if; - end loop; - end; - - -- Invoke gcc to build the library - - Utl.Gcc - (Output_File => Lib_File, - Objects => Ofiles & Additional_Objects.all, - Options => VMS_Options, - Options_2 => Link_With_Shared_Libgcc.all & - Opts (Opts'First .. Last_Opt) & - Opts2 (Opts2'First .. Last_Opt2), - Driver_Name => Driver_Name); - - -- The auto-init object file need to be deleted, so that it will not - -- be included in the library as a regular object file, otherwise - -- it will be included twice when the library will be built next - -- time, which may lead to errors. - - if Auto_Init then - declare - Auto_Init_Object_File_Name : constant String := - Lib_Filename & "$init.obj"; - Disregard : Boolean; - - begin - if Verbose_Mode then - Write_Str ("deleting auto-init object file """); - Write_Str (Auto_Init_Object_File_Name); - Write_Line (""""); - end if; - - Delete_File (Auto_Init_Object_File_Name, Success => Disregard); - end; - end if; - end Build_Dynamic_Library; - - ------------------------- - -- Default_DLL_Address -- - ------------------------- - - function Default_DLL_Address return String is - begin - return ""; - end Default_DLL_Address; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return "exe"; - end DLL_Ext; - - -------------------- - -- Dynamic_Option -- - -------------------- - - function Dynamic_Option return String is - begin - return "-shared"; - end Dynamic_Option; - - ------------------- - -- Is_Object_Ext -- - ------------------- - - function Is_Object_Ext (Ext : String) return Boolean is - begin - return Ext = ".obj"; - end Is_Object_Ext; - - -------------- - -- Is_C_Ext -- - -------------- - - function Is_C_Ext (Ext : String) return Boolean is - begin - return Ext = ".c"; - end Is_C_Ext; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".olb" or else Ext = ".exe"; - end Is_Archive_Ext; - - ------------- - -- Libgnat -- - ------------- - - function Libgnat return String is - Libgnat_A : constant String := "libgnat.a"; - Libgnat_Olb : constant String := "libgnat.olb"; - - begin - Name_Len := Libgnat_A'Length; - Name_Buffer (1 .. Name_Len) := Libgnat_A; - - if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then - return Libgnat_A; - - else - return Libgnat_Olb; - end if; - end Libgnat; - - ------------------------ - -- Library_Exists_For -- - ------------------------ - - function Library_Exists_For (Project : Project_Id) return Boolean is - begin - if not Projects.Table (Project).Library then - Fail ("INTERNAL ERROR: Library_Exists_For called " & - "for non library project"); - return False; - - else - declare - Lib_Dir : constant String := - Get_Name_String (Projects.Table (Project).Library_Dir); - Lib_Name : constant String := - Get_Name_String (Projects.Table (Project).Library_Name); - - begin - if Projects.Table (Project).Library_Kind = Static then - return Is_Regular_File - (Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - return Is_Regular_File - (Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - end; - end if; - end Library_Exists_For; - - --------------------------- - -- Library_File_Name_For -- - --------------------------- - - function Library_File_Name_For (Project : Project_Id) return Name_Id is - begin - if not Projects.Table (Project).Library then - Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & - "for non library project"); - return No_Name; - - else - declare - Lib_Name : constant String := - Get_Name_String (Projects.Table (Project).Library_Name); - - begin - Name_Len := 3; - Name_Buffer (1 .. Name_Len) := "lib"; - - if Projects.Table (Project).Library_Kind = Static then - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - - return Name_Find; - end; - end if; - end Library_File_Name_For; - - ---------------- - -- Object_Ext -- - ---------------- - - function Object_Ext return String is - begin - return "obj"; - end Object_Ext; - - ---------------- - -- PIC_Option -- - ---------------- - - function PIC_Option return String is - begin - return ""; - end PIC_Option; - - ----------------------------------------------- - -- Standalone_Library_Auto_Init_Is_Supported -- - ----------------------------------------------- - - function Standalone_Library_Auto_Init_Is_Supported return Boolean is - begin - return True; - end Standalone_Library_Auto_Init_Is_Supported; - - --------------------------- - -- Support_For_Libraries -- - --------------------------- - - function Support_For_Libraries return Library_Support is - begin - return Full; - end Support_For_Libraries; - -end MLib.Tgt; diff --git a/gcc/ada/5vosinte.adb b/gcc/ada/5vosinte.adb deleted file mode 100644 index 0b806daa809..00000000000 --- a/gcc/ada/5vosinte.adb +++ /dev/null @@ -1,78 +0,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 OpenVMS/Alpha version of this package. - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with Interfaces.C; use Interfaces.C; -with System.Machine_Code; use System.Machine_Code; - -package body System.OS_Interface is - - ------------------ - -- pthread_self -- - ------------------ - - function pthread_self return pthread_t is - use ASCII; - Self : pthread_t; - - begin - Asm ("call_pal 0x9e" & LF & HT & - "bis $31, $0, %0", - Outputs => pthread_t'Asm_Output ("=r", Self), - Clobber => "$0"); - return Self; - end pthread_self; - - ----------------- - -- sched_yield -- - ----------------- - - function sched_yield return int is - procedure sched_yield_base; - pragma Import (C, sched_yield_base, "PTHREAD_YIELD_NP"); - - begin - sched_yield_base; - return 0; - end sched_yield; - -end System.OS_Interface; diff --git a/gcc/ada/5vosinte.ads b/gcc/ada/5vosinte.ads deleted file mode 100644 index 333e02a37b8..00000000000 --- a/gcc/ada/5vosinte.ads +++ /dev/null @@ -1,646 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 a OpenVMS/Alpha version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Unchecked_Conversion; - -package System.OS_Interface is - pragma Preelaborate; - - pragma Linker_Options ("--for-linker=sys$library:pthread$rtl.exe"); - -- Link in the DEC threads library. - - -- pragma Linker_Options ("--for-linker=/threads_enable"); - -- Enable upcalls and multiple kernel threads. - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------------------------- - -- Signals (Interrupt IDs) -- - ----------------------------- - - -- Type signal has an arbitrary limit of 31 - - Max_Interrupt : constant := 31; - type Signal is new unsigned range 0 .. Max_Interrupt; - for Signal'Size use unsigned'Size; - - type sigset_t is array (Signal) of Boolean; - pragma Pack (sigset_t); - - -- Interrupt_Number_Type - -- Unsigned long integer denoting the number of an interrupt - - subtype Interrupt_Number_Type is unsigned_long; - - -- OpenVMS system services return values of type Cond_Value_Type. - - subtype Cond_Value_Type is unsigned_long; - subtype Short_Cond_Value_Type is unsigned_short; - - type IO_Status_Block_Type is record - Status : Short_Cond_Value_Type; - Count : unsigned_short; - Dev_Info : unsigned_long; - end record; - - type AST_Handler is access procedure (Param : Address); - No_AST_Handler : constant AST_Handler := null; - - CMB_M_READONLY : constant := 16#00000001#; - CMB_M_WRITEONLY : constant := 16#00000002#; - AGN_M_READONLY : constant := 16#00000001#; - AGN_M_WRITEONLY : constant := 16#00000002#; - - IO_WRITEVBLK : constant := 48; -- WRITE VIRTUAL BLOCK - IO_READVBLK : constant := 49; -- READ VIRTUAL BLOCK - - ---------------- - -- Sys_Assign -- - ---------------- - -- - -- Assign I/O Channel - -- - -- Status = returned status - -- Devnam = address of device name or logical name string - -- descriptor - -- Chan = address of word to receive channel number assigned - -- Acmode = access mode associated with channel - -- Mbxnam = address of mailbox logical name string descriptor, if - -- mailbox associated with device - -- Flags = optional channel flags longword for specifying options - -- for the $ASSIGN operation - -- - - procedure Sys_Assign - (Status : out Cond_Value_Type; - Devnam : in String; - Chan : out unsigned_short; - Acmode : in unsigned_short := 0; - Mbxnam : in String := String'Null_Parameter; - Flags : in unsigned_long := 0); - pragma Interface (External, Sys_Assign); - pragma Import_Valued_Procedure - (Sys_Assign, "SYS$ASSIGN", - (Cond_Value_Type, String, unsigned_short, - unsigned_short, String, unsigned_long), - (Value, Descriptor (s), Reference, - Value, Descriptor (s), Value), - Flags); - - ---------------- - -- Sys_Cantim -- - ---------------- - -- - -- Cancel Timer - -- - -- Status = returned status - -- Reqidt = ID of timer to be cancelled - -- Acmode = Access mode - -- - procedure Sys_Cantim - (Status : out Cond_Value_Type; - Reqidt : in Address; - Acmode : in unsigned); - pragma Interface (External, Sys_Cantim); - pragma Import_Valued_Procedure - (Sys_Cantim, "SYS$CANTIM", - (Cond_Value_Type, Address, unsigned), - (Value, Value, Value)); - - ---------------- - -- Sys_Crembx -- - ---------------- - -- - -- Create mailbox - -- - -- Status = returned status - -- Prmflg = permanent flag - -- Chan = channel - -- Maxmsg = maximum message - -- Bufquo = buufer quote - -- Promsk = protection mast - -- Acmode = access mode - -- Lognam = logical name - -- Flags = flags - -- - procedure Sys_Crembx - (Status : out Cond_Value_Type; - Prmflg : in Boolean; - Chan : out unsigned_short; - Maxmsg : in unsigned_long := 0; - Bufquo : in unsigned_long := 0; - Promsk : in unsigned_short := 0; - Acmode : in unsigned_short := 0; - Lognam : in String; - Flags : in unsigned_long := 0); - pragma Interface (External, Sys_Crembx); - pragma Import_Valued_Procedure - (Sys_Crembx, "SYS$CREMBX", - (Cond_Value_Type, Boolean, unsigned_short, - unsigned_long, unsigned_long, unsigned_short, - unsigned_short, String, unsigned_long), - (Value, Value, Reference, - Value, Value, Value, - Value, Descriptor (s), Value)); - - ------------- - -- Sys_QIO -- - ------------- - -- - -- Queue I/O - -- - -- Status = Returned status of call - -- EFN = event flag to be set when I/O completes - -- Chan = channel - -- Func = function - -- Iosb = I/O status block - -- Astadr = system trap to be generated when I/O completes - -- Astprm = AST parameter - -- P1-6 = optional parameters - - procedure Sys_QIO - (Status : out Cond_Value_Type; - EFN : in unsigned_long := 0; - Chan : in unsigned_short; - Func : in unsigned_long := 0; - Iosb : out IO_Status_Block_Type; - Astadr : in AST_Handler := No_AST_Handler; - Astprm : in Address := Null_Address; - P1 : in unsigned_long := 0; - P2 : in unsigned_long := 0; - P3 : in unsigned_long := 0; - P4 : in unsigned_long := 0; - P5 : in unsigned_long := 0; - P6 : in unsigned_long := 0); - - procedure Sys_QIO - (Status : out Cond_Value_Type; - EFN : in unsigned_long := 0; - Chan : in unsigned_short; - Func : in unsigned_long := 0; - Iosb : in Address := Null_Address; - Astadr : in AST_Handler := No_AST_Handler; - Astprm : in Address := Null_Address; - P1 : in unsigned_long := 0; - P2 : in unsigned_long := 0; - P3 : in unsigned_long := 0; - P4 : in unsigned_long := 0; - P5 : in unsigned_long := 0; - P6 : in unsigned_long := 0); - - pragma Interface (External, Sys_QIO); - pragma Import_Valued_Procedure - (Sys_QIO, "SYS$QIO", - (Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long, - IO_Status_Block_Type, AST_Handler, Address, - unsigned_long, unsigned_long, unsigned_long, - unsigned_long, unsigned_long, unsigned_long), - (Value, Value, Value, Value, - Reference, Value, Value, - Value, Value, Value, - Value, Value, Value)); - - pragma Import_Valued_Procedure - (Sys_QIO, "SYS$QIO", - (Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long, - Address, AST_Handler, Address, - unsigned_long, unsigned_long, unsigned_long, - unsigned_long, unsigned_long, unsigned_long), - (Value, Value, Value, Value, - Value, Value, Value, - Value, Value, Value, - Value, Value, Value)); - - ---------------- - -- Sys_Setimr -- - ---------------- - -- - -- Set Timer - -- - -- Status = Returned status of call - -- EFN = event flag to be set when timer expires - -- Tim = expiration time - -- AST = system trap to be generated when timer expires - -- Redidt = returned ID of timer (e.g. to cancel timer) - -- Flags = flags - -- - procedure Sys_Setimr - (Status : out Cond_Value_Type; - EFN : in unsigned_long; - Tim : in Long_Integer; - AST : in AST_Handler; - Reqidt : in Address; - Flags : in unsigned_long); - pragma Interface (External, Sys_Setimr); - pragma Import_Valued_Procedure - (Sys_Setimr, "SYS$SETIMR", - (Cond_Value_Type, unsigned_long, Long_Integer, - AST_Handler, Address, unsigned_long), - (Value, Value, Reference, - Value, Value, Value)); - - Interrupt_ID_0 : constant := 0; - Interrupt_ID_1 : constant := 1; - Interrupt_ID_2 : constant := 2; - Interrupt_ID_3 : constant := 3; - Interrupt_ID_4 : constant := 4; - Interrupt_ID_5 : constant := 5; - Interrupt_ID_6 : constant := 6; - Interrupt_ID_7 : constant := 7; - Interrupt_ID_8 : constant := 8; - Interrupt_ID_9 : constant := 9; - Interrupt_ID_10 : constant := 10; - Interrupt_ID_11 : constant := 11; - Interrupt_ID_12 : constant := 12; - Interrupt_ID_13 : constant := 13; - Interrupt_ID_14 : constant := 14; - Interrupt_ID_15 : constant := 15; - Interrupt_ID_16 : constant := 16; - Interrupt_ID_17 : constant := 17; - Interrupt_ID_18 : constant := 18; - Interrupt_ID_19 : constant := 19; - Interrupt_ID_20 : constant := 20; - Interrupt_ID_21 : constant := 21; - Interrupt_ID_22 : constant := 22; - Interrupt_ID_23 : constant := 23; - Interrupt_ID_24 : constant := 24; - Interrupt_ID_25 : constant := 25; - Interrupt_ID_26 : constant := 26; - Interrupt_ID_27 : constant := 27; - Interrupt_ID_28 : constant := 28; - Interrupt_ID_29 : constant := 29; - Interrupt_ID_30 : constant := 30; - Interrupt_ID_31 : constant := 31; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EINTR : constant := 4; -- Interrupted system call - EAGAIN : constant := 11; -- No more processes - ENOMEM : constant := 12; -- Not enough core - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 1; - SCHED_RR : constant := 2; - SCHED_OTHER : constant := 3; - SCHED_BG : constant := 4; - SCHED_LFI : constant := 5; - SCHED_LRR : constant := 6; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill); - - function getpid return pid_t; - pragma Import (C, getpid); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_JOINABLE : constant := 0; - PTHREAD_CREATE_DETACHED : constant := 1; - - PTHREAD_CANCEL_DISABLE : constant := 0; - PTHREAD_CANCEL_ENABLE : constant := 1; - - PTHREAD_CANCEL_DEFERRED : constant := 0; - PTHREAD_CANCEL_ASYNCHRONOUS : constant := 1; - - -- Don't use ERRORCHECK mutexes, they don't work when a thread is not - -- the owner. AST's, at least, unlock others threads mutexes. Even - -- if the error is ignored, they don't work. - PTHREAD_MUTEX_NORMAL_NP : constant := 0; - PTHREAD_MUTEX_RECURSIVE_NP : constant := 1; - PTHREAD_MUTEX_ERRORCHECK_NP : constant := 2; - - PTHREAD_INHERIT_SCHED : constant := 0; - PTHREAD_EXPLICIT_SCHED : constant := 1; - - function pthread_cancel (thread : pthread_t) return int; - pragma Import (C, pthread_cancel, "PTHREAD_CANCEL"); - - procedure pthread_testcancel; - pragma Import (C, pthread_testcancel, "PTHREAD_TESTCANCEL"); - - function pthread_setcancelstate - (newstate : int; oldstate : access int) return int; - pragma Import (C, pthread_setcancelstate, "PTHREAD_SETCANCELSTATE"); - - function pthread_setcanceltype - (newtype : int; oldtype : access int) return int; - pragma Import (C, pthread_setcanceltype, "PTHREAD_SETCANCELTYPE"); - - --------------------------- - -- POSIX.1c Section 3 -- - --------------------------- - - function pthread_lock_global_np return int; - pragma Import (C, pthread_lock_global_np, "PTHREAD_LOCK_GLOBAL_NP"); - - function pthread_unlock_global_np return int; - pragma Import (C, pthread_unlock_global_np, "PTHREAD_UNLOCK_GLOBAL_NP"); - - ---------------------------- - -- POSIX.1c Section 11 -- - ---------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "PTHREAD_MUTEXATTR_INIT"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "PTHREAD_MUTEXATTR_DESTROY"); - - function pthread_mutexattr_settype_np - (attr : access pthread_mutexattr_t; - mutextype : int) return int; - pragma Import (C, pthread_mutexattr_settype_np, - "PTHREAD_MUTEXATTR_SETTYPE_NP"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "PTHREAD_MUTEX_INIT"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "PTHREAD_MUTEX_DESTROY"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_lock, "PTHREAD_MUTEX_LOCK"); - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_unlock, "PTHREAD_MUTEX_UNLOCK"); - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "PTHREAD_CONDATTR_INIT"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "PTHREAD_CONDATTR_DESTROY"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "PTHREAD_COND_INIT"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "PTHREAD_COND_DESTROY"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "PTHREAD_COND_SIGNAL"); - - function pthread_cond_signal_int_np - (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal_int_np, - "PTHREAD_COND_SIGNAL_INT_NP"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait, "PTHREAD_COND_WAIT"); - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol, - "PTHREAD_MUTEXATTR_SETPROTOCOL"); - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - for struct_sched_param'Size use 8*4; - pragma Convention (C, struct_sched_param); - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Import (C, pthread_setschedparam, "PTHREAD_SETSCHEDPARAM"); - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "PTHREAD_ATTR_SETSCOPE"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import (C, pthread_attr_setinheritsched, - "PTHREAD_ATTR_SETINHERITSCHED"); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy, - "PTHREAD_ATTR_SETSCHEDPOLICY"); - - function pthread_attr_setschedparam - (attr : access pthread_attr_t; - sched_param : int) return int; - pragma Import (C, pthread_attr_setschedparam, "PTHREAD_ATTR_SETSCHEDPARAM"); - - function sched_yield return int; - - ----------------------------- - -- P1003.1c - Section 16 -- - ----------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "PTHREAD_ATTR_INIT"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "PTHREAD_ATTR_DESTROY"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Import (C, pthread_attr_setdetachstate, - "PTHREAD_ATTR_SETDETACHSTATE"); - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize, "PTHREAD_ATTR_SETSTACKSIZE"); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "PTHREAD_CREATE"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "PTHREAD_EXIT"); - - function pthread_self return pthread_t; - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "PTHREAD_SETSPECIFIC"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Import (C, pthread_getspecific, "PTHREAD_GETSPECIFIC"); - - type destructor_pointer is access procedure (arg : System.Address); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "PTHREAD_KEY_CREATE"); - -private - - type pid_t is new int; - - type pthreadLongAddr_p is mod 2 ** Long_Integer'Size; - - type pthreadLongAddr_t is mod 2 ** Long_Integer'Size; - type pthreadLongAddr_t_ptr is mod 2 ** Long_Integer'Size; - - type pthreadLongString_t is mod 2 ** Long_Integer'Size; - - type pthreadLongUint_t is mod 2 ** Long_Integer'Size; - type pthreadLongUint_array is array (Natural range <>) - of pthreadLongUint_t; - - type pthread_t is mod 2 ** Long_Integer'Size; - - type pthread_cond_t is record - state : unsigned; - valid : unsigned; - name : pthreadLongString_t; - arg : unsigned; - sequence : unsigned; - block : pthreadLongAddr_t_ptr; - end record; - for pthread_cond_t'Size use 8*32; - pragma Convention (C, pthread_cond_t); - - type pthread_attr_t is record - valid : long; - name : pthreadLongString_t; - arg : pthreadLongUint_t; - reserved : pthreadLongUint_array (0 .. 18); - end record; - for pthread_attr_t'Size use 8*176; - pragma Convention (C, pthread_attr_t); - - type pthread_mutex_t is record - lock : unsigned; - valid : unsigned; - name : pthreadLongString_t; - arg : unsigned; - sequence : unsigned; - block : pthreadLongAddr_p; - owner : unsigned; - depth : unsigned; - end record; - for pthread_mutex_t'Size use 8*40; - pragma Convention (C, pthread_mutex_t); - - type pthread_mutexattr_t is record - valid : long; - reserved : pthreadLongUint_array (0 .. 14); - end record; - for pthread_mutexattr_t'Size use 8*128; - pragma Convention (C, pthread_mutexattr_t); - - type pthread_condattr_t is record - valid : long; - reserved : pthreadLongUint_array (0 .. 12); - end record; - for pthread_condattr_t'Size use 8*112; - pragma Convention (C, pthread_condattr_t); - - type pthread_key_t is new unsigned; - - pragma Inline (pthread_self); - -end System.OS_Interface; diff --git a/gcc/ada/5vosprim.adb b/gcc/ada/5vosprim.adb deleted file mode 100644 index c49c861bf34..00000000000 --- a/gcc/ada/5vosprim.adb +++ /dev/null @@ -1,193 +0,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-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 the OpenVMS/Alpha version of this file - -with System.Aux_DEC; - -package body System.OS_Primitives is - - -------------------------------------- - -- Local functions and declarations -- - -------------------------------------- - - function Get_GMToff return Integer; - pragma Import (C, Get_GMToff, "get_gmtoff"); - -- Get the offset from GMT for this timezone - - VMS_Epoch_Offset : constant Long_Integer := - 10_000_000 * - (3_506_716_800 + Long_Integer (Get_GMToff)); - -- The offset between the Unix Epoch and the VMS Epoch - - subtype Cond_Value_Type is System.Aux_DEC.Unsigned_Longword; - -- Condition Value return type - - ---------------- - -- Sys_Schdwk -- - ---------------- - -- - -- Schedule Wakeup - -- - -- status = returned status - -- pidadr = address of process id to be woken up - -- prcnam = name of process to be woken up - -- daytim = time to wake up - -- reptim = repitition interval of wakeup calls - -- - - procedure Sys_Schdwk - ( - Status : out Cond_Value_Type; - Pidadr : in Address := Null_Address; - Prcnam : in String := String'Null_Parameter; - Daytim : in Long_Integer; - Reptim : in Long_Integer := Long_Integer'Null_Parameter - ); - - pragma Interface (External, Sys_Schdwk); - -- VMS system call to schedule a wakeup event - pragma Import_Valued_Procedure - (Sys_Schdwk, "SYS$SCHDWK", - (Cond_Value_Type, Address, String, Long_Integer, Long_Integer), - (Value, Value, Descriptor (S), Reference, Reference) - ); - - ---------------- - -- Sys_Gettim -- - ---------------- - -- - -- Get System Time - -- - -- status = returned status - -- tim = current system time - -- - - procedure Sys_Gettim - ( - Status : out Cond_Value_Type; - Tim : out OS_Time - ); - -- VMS system call to get the current system time - pragma Interface (External, Sys_Gettim); - pragma Import_Valued_Procedure - (Sys_Gettim, "SYS$GETTIM", - (Cond_Value_Type, OS_Time), - (Value, Reference) - ); - - --------------- - -- Sys_Hiber -- - --------------- - - -- Hibernate (until woken up) - - -- status = returned status - - procedure Sys_Hiber (Status : out Cond_Value_Type); - -- VMS system call to hibernate the current process - pragma Interface (External, Sys_Hiber); - pragma Import_Valued_Procedure - (Sys_Hiber, "SYS$HIBER", - (Cond_Value_Type), - (Value) - ); - - ----------- - -- Clock -- - ----------- - - function OS_Clock return OS_Time is - Status : Cond_Value_Type; - T : OS_Time; - begin - Sys_Gettim (Status, T); - return (T); - end OS_Clock; - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - begin - return To_Duration (OS_Clock, Absolute_Calendar); - end Clock; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration renames Clock; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Sleep_Time : OS_Time; - Status : Cond_Value_Type; - - begin - Sleep_Time := To_OS_Time (Time, Mode); - Sys_Schdwk (Status => Status, Daytim => Sleep_Time); - Sys_Hiber (Status); - end Timed_Delay; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (T : OS_Time; Mode : Integer) return Duration is - pragma Warnings (Off, Mode); - begin - return Duration'Fixed_Value (T - VMS_Epoch_Offset) * 100; - end To_Duration; - - ---------------- - -- To_OS_Time -- - ---------------- - - function To_OS_Time (D : Duration; Mode : Integer) return OS_Time is - begin - if Mode = Relative then - return -(Long_Integer'Integer_Value (D) / 100); - else - return Long_Integer'Integer_Value (D) / 100 + VMS_Epoch_Offset; - end if; - end To_OS_Time; - -end System.OS_Primitives; diff --git a/gcc/ada/5vosprim.ads b/gcc/ada/5vosprim.ads deleted file mode 100644 index a777bea3b83..00000000000 --- a/gcc/ada/5vosprim.ads +++ /dev/null @@ -1,106 +0,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 -- --- -- --- S p e c -- --- -- --- 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 package provides low level primitives used to implement clock and --- delays in non tasking applications on Alpha/VMS - --- The choice of the real clock/delay implementation (depending on whether --- tasking is involved or not) is done via soft links (see s-tasoli.ads) - --- NEVER add any dependency to tasking packages here - -package System.OS_Primitives is - - subtype OS_Time is Long_Integer; - -- System time on VMS is used for performance reasons. - -- Note that OS_Time is *not* the same as Ada.Calendar.Time, the - -- difference being that relative OS_Time is negative, but relative - -- Calendar.Time is positive. - -- See Ada.Calendar.Delays for more information on VMS Time. - - Max_Sensible_Delay : constant Duration := - Duration'Min (183 * 24 * 60 * 60.0, - Duration'Last); - -- Max of half a year delay, needed to prevent exceptions for large - -- delay values. It seems unlikely that any test will notice this - -- restriction, except in the case of applications setting the clock at - -- at run time (see s-tastim.adb). Also note that a larger value might - -- cause problems (e.g overflow, or more likely OS limitation in the - -- primitives used). In the case where half a year is too long (which - -- occurs in high integrity mode with 32-bit words, and possibly on - -- some specific ports of GNAT), Duration'Last is used instead. - - function OS_Clock return OS_Time; - -- Returns "absolute" time, represented as an offset - -- relative to "the Epoch", which is Nov 17, 1858 on VMS. - - function Clock return Duration; - pragma Inline (Clock); - -- Returns "absolute" time, represented as an offset - -- relative to "the Epoch", which is Jan 1, 1970 on unixes. - -- This implementation is affected by system's clock changes. - - function Monotonic_Clock return Duration; - pragma Inline (Monotonic_Clock); - -- Returns "absolute" time, represented as an offset - -- relative to "the Epoch", which is Jan 1, 1970. - -- This clock implementation is immune to the system's clock changes. - - Relative : constant := 0; - Absolute_Calendar : constant := 1; - Absolute_RT : constant := 2; - -- Values for Mode call below. Note that the compiler (exp_ch9.adb) - -- relies on these values. So any change here must be reflected in - -- corresponding changes in the compiler. - - procedure Timed_Delay (Time : Duration; Mode : Integer); - -- Implements the semantics of the delay statement when no tasking is - -- used in the application. - -- - -- Mode is one of the three values above - -- - -- Time is a relative or absolute duration value, depending on Mode. - -- - -- Note that currently Ada.Real_Time always uses the tasking run time, so - -- this procedure should never be called with Mode set to Absolute_RT. - -- This may change in future or bare board implementations. - - function To_Duration (T : OS_Time; Mode : Integer) return Duration; - -- Convert VMS system time to Duration - -- Mode is one of the three values above - - function To_OS_Time (D : Duration; Mode : Integer) return OS_Time; - -- Convert Duration to VMS system time - -- Mode is one of the three values above - -end System.OS_Primitives; diff --git a/gcc/ada/5vparame.ads b/gcc/ada/5vparame.ads deleted file mode 100644 index 5b41ab79ec6..00000000000 --- a/gcc/ada/5vparame.ads +++ /dev/null @@ -1,202 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2003 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 version. --- Blank line intentional so that it lines up exactly with default. - --- This package defines some system dependent parameters for GNAT. These --- are values that are referenced by the runtime library and are therefore --- relevant to the target machine. - --- The parameters whose value is defined in the spec are not generally --- expected to be changed. If they are changed, it will be necessary to --- recompile the run-time library. - --- The parameters which are defined by functions can be changed by modifying --- the body of System.Parameters in file s-parame.adb. A change to this body --- requires only rebinding and relinking of the application. - --- Note: do not introduce any pragma Inline statements into this unit, since --- otherwise the relinking and rebinding capability would be deactivated. - -package System.Parameters is -pragma Pure (Parameters); - - --------------------------------------- - -- Task And Stack Allocation Control -- - --------------------------------------- - - type Task_Storage_Size is new Integer; - -- Type used in tasking units for task storage size - - type Size_Type is new Task_Storage_Size; - -- Type used to provide task storage size to runtime - - Unspecified_Size : constant Size_Type := Size_Type'First; - -- Value used to indicate that no size type is set - - subtype Ratio is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Ratio : constant Ratio := Dynamic; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - - function Default_Stack_Size return Size_Type; - -- Default task stack size used if none is specified - - function Minimum_Stack_Size return Size_Type; - -- Minimum task stack size permitted - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type; - -- Given the storage size stored in the TCB, return the Storage_Size - -- value required by the RM for the Storage_Size attribute. The - -- required adjustment is as follows: - -- - -- when Size = Unspecified_Size, return Default_Stack_Size - -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size - -- otherwise return given Size - - Default_Env_Stack_Size : constant Size_Type := 8_192_000; - -- Assumed size of the environment task, if no other information - -- is available. This value is used when stack checking is - -- enabled and no GNAT_STACK_LIMIT environment variable is set. - - Stack_Grows_Down : constant Boolean := True; - -- This constant indicates whether the stack grows up (False) or - -- down (True) in memory as functions are called. It is used for - -- proper implementation of the stack overflow check. - - ---------------------------------------------- - -- Characteristics of types in Interfaces.C -- - ---------------------------------------------- - - long_bits : constant := 32; - -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this is not true - -- of all targets. For example, in OpenVMS long /= Long_Integer. - - ---------------------------------------------- - -- Behavior of Pragma Finalize_Storage_Only -- - ---------------------------------------------- - - -- Garbage_Collected is a Boolean constant whose value indicates the - -- effect of the pragma Finalize_Storage_Entry on a controlled type. - - -- Garbage_Collected = False - - -- The system releases all storage on program termination only, - -- but not other garbage collection occurs, so finalization calls - -- are ommitted only for outer level onjects can be omitted if - -- pragma Finalize_Storage_Only is used. - - -- Garbage_Collected = True - - -- The system provides full garbage collection, so it is never - -- necessary to release storage for controlled objects for which - -- a pragma Finalize_Storage_Only is used. - - Garbage_Collected : constant Boolean := False; - -- The storage mode for this system (release on program exit) - - --------------------- - -- Tasking Profile -- - --------------------- - - -- In the following sections, constant parameters are defined to - -- allow some optimizations and fine tuning within the tasking run time - -- based on restrictions on the tasking features. - - ---------------------- - -- Locking Strategy -- - ---------------------- - - Single_Lock : constant Boolean := True; - -- Indicates whether a single lock should be used within the tasking - -- run-time to protect internal structures. If True, a single lock - -- will be used, meaning less locking/unlocking operations, but also - -- more global contention. In general, Single_Lock should be set to - -- True on single processor machines, and to False to multi-processor - -- systems, but this can vary from application to application and also - -- depends on the scheduling policy. - - ------------------- - -- Task Abortion -- - ------------------- - - No_Abort : constant Boolean := False; - -- This constant indicates whether abort statements and asynchronous - -- transfer of control (ATC) are disallowed. If set to True, it is - -- assumed that neither construct is used, and the run time does not - -- need to defer/undefer abort and check for pending actions at - -- completion points. A value of True for No_Abort corresponds to: - -- pragma Restrictions (No_Abort_Statements); - -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - - ---------------------- - -- Dynamic Priority -- - ---------------------- - - Dynamic_Priority_Support : constant Boolean := True; - -- This constant indicates whether dynamic changes of task priorities - -- are allowed (True means normal RM mode in which such changes are - -- allowed). In particular, if this is False, then we do not need to - -- poll for pending base priority changes at every abort completion - -- point. A value of False for Dynamic_Priority_Support corresponds - -- to pragma Restrictions (No_Dynamic_Priorities); - - --------------------- - -- Task Attributes -- - --------------------- - - Default_Attribute_Count : constant := 4; - -- Number of pre-allocated Address-sized task attributes stored in the - -- task control block. - - -------------------- - -- Runtime Traces -- - -------------------- - - Runtime_Traces : constant Boolean := False; - -- This constant indicates whether the runtime outputs traces to a - -- predefined output or not (True means that traces are output). - -- See System.Traces for more details. - -end System.Parameters; diff --git a/gcc/ada/5vsymbol.adb b/gcc/ada/5vsymbol.adb deleted file mode 100644 index c623e42b383..00000000000 --- a/gcc/ada/5vsymbol.adb +++ /dev/null @@ -1,743 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y M B O L S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003 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. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VMS version of this package - -with Ada.Exceptions; use Ada.Exceptions; -with Ada.Sequential_IO; -with Ada.Text_IO; use Ada.Text_IO; - -package body Symbols is - - Case_Sensitive : constant String := "case_sensitive="; - Symbol_Vector : constant String := "SYMBOL_VECTOR=("; - Equal_Data : constant String := "=DATA)"; - Equal_Procedure : constant String := "=PROCEDURE)"; - Gsmatch : constant String := "gsmatch=equal,"; - - Symbol_File_Name : String_Access := null; - -- Name of the symbol file - - Sym_Policy : Policy := Autonomous; - -- The symbol policy. Set by Initialize - - Major_ID : Integer := 1; - -- The Major ID. May be modified by Initialize if Library_Version is - -- specified or if it is read from the reference symbol file. - - Soft_Major_ID : Boolean := True; - -- False if library version is specified in procedure Initialize. - -- When True, Major_ID may be modified if found in the reference symbol - -- file. - - Minor_ID : Natural := 0; - -- The Minor ID. May be modified if read from the reference symbol file - - Soft_Minor_ID : Boolean := True; - -- False if symbol policy is Autonomous, if library version is specified - -- in procedure Initialize and is not the same as the major ID read from - -- the reference symbol file. When True, Minor_ID may be increased in - -- Compliant symbol policy. - - subtype Byte is Character; - -- Object files are stream of bytes, but some of these bytes, those for - -- the names of the symbols, are ASCII characters. - - package Byte_IO is new Ada.Sequential_IO (Byte); - use Byte_IO; - - type Number is mod 2**16; - -- 16 bits unsigned number for number of characters - - GSD : constant Number := 10; - -- Code for the Global Symbol Definition section - - C_SYM : constant Number := 1; - -- Code for a Symbol subsection - - V_DEF_Mask : constant Number := 2**1; - V_NORM_Mask : constant Number := 2**6; - - File : Byte_IO.File_Type; - -- Each object file is read as a stream of bytes (characters) - - B : Byte; - - Number_Of_Characters : Natural := 0; - -- The number of characters of each section - - -- The following variables are used by procedure Process when reading an - -- object file. - - Code : Number := 0; - Length : Natural := 0; - - Dummy : Number; - - Nchars : Natural := 0; - Flags : Number := 0; - - Symbol : String (1 .. 255); - LSymb : Natural; - - function Equal (Left, Right : Symbol_Data) return Boolean; - -- Test for equality of symbols - - procedure Get (N : out Number); - -- Read two bytes from the object file LSB first as unsigned 16 bit number - - procedure Get (N : out Natural); - -- Read two bytes from the object file, LSByte first, as a Natural - - - function Image (N : Integer) return String; - -- Returns the image of N, without the initial space - - ----------- - -- Equal -- - ----------- - - function Equal (Left, Right : Symbol_Data) return Boolean is - begin - return Left.Name /= null and then - Right.Name /= null and then - Left.Name.all = Right.Name.all and then - Left.Kind = Right.Kind and then - Left.Present = Right.Present; - end Equal; - - --------- - -- Get -- - --------- - - procedure Get (N : out Number) is - C : Byte; - LSByte : Number; - begin - Read (File, C); - LSByte := Byte'Pos (C); - Read (File, C); - N := LSByte + (256 * Byte'Pos (C)); - end Get; - - procedure Get (N : out Natural) is - Result : Number; - begin - Get (Result); - N := Natural (Result); - end Get; - - ----------- - -- Image -- - ----------- - - function Image (N : Integer) return String is - Result : constant String := N'Img; - begin - if Result (Result'First) = ' ' then - return Result (Result'First + 1 .. Result'Last); - - else - return Result; - end if; - end Image; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize - (Symbol_File : String; - Reference : String; - Symbol_Policy : Policy; - Quiet : Boolean; - Version : String; - Success : out Boolean) - is - File : Ada.Text_IO.File_Type; - Line : String (1 .. 1_000); - Last : Natural; - - begin - -- Record the symbol file name - - Symbol_File_Name := new String'(Symbol_File); - - -- Record the policy - - Sym_Policy := Symbol_Policy; - - -- Record the version (Major ID) - - if Version = "" then - Major_ID := 1; - Soft_Major_ID := True; - - else - begin - Major_ID := Integer'Value (Version); - Soft_Major_ID := False; - - if Major_ID <= 0 then - raise Constraint_Error; - end if; - - exception - when Constraint_Error => - if not Quiet then - Put_Line ("Version """ & Version & """ is illegal."); - Put_Line ("On VMS, version must be a positive number"); - end if; - - Success := False; - return; - end; - end if; - - Minor_ID := 0; - Soft_Minor_ID := Sym_Policy /= Autonomous; - - -- Empty the symbol tables - - Symbol_Table.Set_Last (Original_Symbols, 0); - Symbol_Table.Set_Last (Complete_Symbols, 0); - - -- Assume that everything will be fine - - Success := True; - - -- If policy is not autonomous, attempt to read the reference file - - if Sym_Policy /= Autonomous then - begin - Open (File, In_File, Reference); - - exception - when Ada.Text_IO.Name_Error => - return; - - when X : others => - if not Quiet then - Put_Line ("could not open """ & Reference & """"); - Put_Line (Exception_Message (X)); - end if; - - Success := False; - return; - end; - - -- Read line by line - - while not End_Of_File (File) loop - Get_Line (File, Line, Last); - - -- Ignore empty lines - - if Last = 0 then - null; - - -- Ignore lines starting with "case_sensitive=" - - elsif Last > Case_Sensitive'Length - and then Line (1 .. Case_Sensitive'Length) = Case_Sensitive - then - null; - - -- Line starting with "SYMBOL_VECTOR=(" - - elsif Last > Symbol_Vector'Length - and then Line (1 .. Symbol_Vector'Length) = Symbol_Vector - then - - -- SYMBOL_VECTOR=(=DATA) - - if Last > Symbol_Vector'Length + Equal_Data'Length and then - Line (Last - Equal_Data'Length + 1 .. Last) = Equal_Data - then - Symbol_Table.Increment_Last (Original_Symbols); - Original_Symbols.Table - (Symbol_Table.Last (Original_Symbols)) := - (Name => - new String'(Line (Symbol_Vector'Length + 1 .. - Last - Equal_Data'Length)), - Kind => Data, - Present => True); - - -- SYMBOL_VECTOR=(=PROCEDURE) - - elsif Last > Symbol_Vector'Length + Equal_Procedure'Length - and then - Line (Last - Equal_Procedure'Length + 1 .. Last) = - Equal_Procedure - then - Symbol_Table.Increment_Last (Original_Symbols); - Original_Symbols.Table - (Symbol_Table.Last (Original_Symbols)) := - (Name => - new String'(Line (Symbol_Vector'Length + 1 .. - Last - Equal_Procedure'Length)), - Kind => Proc, - Present => True); - - -- Anything else is incorrectly formatted - - else - if not Quiet then - Put_Line ("symbol file """ & Reference & - """ is incorrectly formatted:"); - Put_Line ("""" & Line (1 .. Last) & """"); - end if; - - Close (File); - Success := False; - return; - end if; - - -- Lines with "gsmatch=equal,, - - elsif Last > Gsmatch'Length - and then Line (1 .. Gsmatch'Length) = Gsmatch - then - declare - Start : Positive := Gsmatch'Length + 1; - Finish : Positive := Start; - OK : Boolean := True; - ID : Integer; - - begin - loop - if Line (Finish) not in '0' .. '9' - or else Finish >= Last - 1 - then - OK := False; - exit; - end if; - - exit when Line (Finish + 1) = ','; - - Finish := Finish + 1; - end loop; - - if OK then - ID := Integer'Value (Line (Start .. Finish)); - OK := ID /= 0; - - -- If Soft_Major_ID is True, it means that - -- Library_Version was not specified. - - if Soft_Major_ID then - Major_ID := ID; - - -- If the Major ID in the reference file is different - -- from the Library_Version, then the Minor ID will be 0 - -- because there is no point in taking the Minor ID in - -- the reference file, or incrementing it. So, we set - -- Soft_Minor_ID to False, so that we don't modify - -- the Minor_ID later. - - elsif Major_ID /= ID then - Soft_Minor_ID := False; - end if; - - Start := Finish + 2; - Finish := Start; - - loop - if Line (Finish) not in '0' .. '9' then - OK := False; - exit; - end if; - - exit when Finish = Last; - - Finish := Finish + 1; - end loop; - - -- Only set Minor_ID if Soft_Minor_ID is True (see above) - - if OK and then Soft_Minor_ID then - Minor_ID := Integer'Value (Line (Start .. Finish)); - end if; - end if; - - -- If OK is not True, that means the line is not correctly - -- formatted. - - if not OK then - if not Quiet then - Put_Line ("symbol file """ & Reference & - """ is incorrectly formatted"); - Put_Line ("""" & Line (1 .. Last) & """"); - end if; - - Close (File); - Success := False; - return; - end if; - end; - - -- Anything else is incorrectly formatted - - else - if not Quiet then - Put_Line ("unexpected line in symbol file """ & - Reference & """"); - Put_Line ("""" & Line (1 .. Last) & """"); - end if; - - Close (File); - Success := False; - return; - end if; - end loop; - - Close (File); - end if; - end Initialize; - - ------------- - -- Process -- - ------------- - - procedure Process - (Object_File : String; - Success : out Boolean) - is - begin - -- Open the object file with Byte_IO. Return with Success = False if - -- this fails. - - begin - Open (File, In_File, Object_File); - exception - when others => - Put_Line - ("*** Unable to open object file """ & Object_File & """"); - Success := False; - return; - end; - - -- Assume that the object file has a correct format - - Success := True; - - -- Get the different sections one by one from the object file - - while not End_Of_File (File) loop - - Get (Code); - Get (Number_Of_Characters); - Number_Of_Characters := Number_Of_Characters - 4; - - -- If this is not a Global Symbol Definition section, skip to the - -- next section. - - if Code /= GSD then - - for J in 1 .. Number_Of_Characters loop - Read (File, B); - end loop; - - else - - -- Skip over the next 4 bytes - - Get (Dummy); - Get (Dummy); - Number_Of_Characters := Number_Of_Characters - 4; - - -- Get each subsection in turn - - loop - Get (Code); - Get (Nchars); - Get (Dummy); - Get (Flags); - Number_Of_Characters := Number_Of_Characters - 8; - Nchars := Nchars - 8; - - -- If this is a symbol and the V_DEF flag is set, get the - -- symbol. - - if Code = C_SYM and then ((Flags and V_DEF_Mask) /= 0) then - -- First, reach the symbol length - - for J in 1 .. 25 loop - Read (File, B); - Nchars := Nchars - 1; - Number_Of_Characters := Number_Of_Characters - 1; - end loop; - - Length := Byte'Pos (B); - LSymb := 0; - - -- Get the symbol characters - - for J in 1 .. Nchars loop - Read (File, B); - Number_Of_Characters := Number_Of_Characters - 1; - if Length > 0 then - LSymb := LSymb + 1; - Symbol (LSymb) := B; - Length := Length - 1; - end if; - end loop; - - -- Create the new Symbol - - declare - S_Data : Symbol_Data; - begin - S_Data.Name := new String'(Symbol (1 .. LSymb)); - - -- The symbol kind (Data or Procedure) depends on the - -- V_NORM flag. - - if (Flags and V_NORM_Mask) = 0 then - S_Data.Kind := Data; - - else - S_Data.Kind := Proc; - end if; - - -- Put the new symbol in the table - - Symbol_Table.Increment_Last (Complete_Symbols); - Complete_Symbols.Table - (Symbol_Table.Last (Complete_Symbols)) := S_Data; - end; - - else - -- As it is not a symbol subsection, skip to the next - -- subsection. - - for J in 1 .. Nchars loop - Read (File, B); - Number_Of_Characters := Number_Of_Characters - 1; - end loop; - end if; - - -- Exit the GSD section when number of characters reaches 0 - - exit when Number_Of_Characters = 0; - end loop; - end if; - end loop; - - -- The object file has been processed, close it - - Close (File); - - exception - -- For any exception, output an error message, close the object file - -- and return with Success = False. - - when X : others => - Put_Line ("unexpected exception raised while processing """ - & Object_File & """"); - Put_Line (Exception_Information (X)); - Close (File); - Success := False; - end Process; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize - (Quiet : Boolean; - Success : out Boolean) - is - File : Ada.Text_IO.File_Type; - -- The symbol file - - S_Data : Symbol_Data; - -- A symbol - - Cur : Positive := 1; - -- Most probable index in the Complete_Symbols of the current symbol - -- in Original_Symbol. - - Found : Boolean; - - begin - -- Nothing to be done if Initialize has never been called - - if Symbol_File_Name = null then - Success := False; - - else - - -- First find if the symbols in the reference symbol file are also - -- in the object files. Note that this is not done if the policy is - -- Autonomous, because no reference symbol file has been read. - - -- Expect the first symbol in the symbol file to also be the first - -- in Complete_Symbols. - - Cur := 1; - - for Index_1 in 1 .. Symbol_Table.Last (Original_Symbols) loop - S_Data := Original_Symbols.Table (Index_1); - Found := False; - - First_Object_Loop : - for Index_2 in Cur .. Symbol_Table.Last (Complete_Symbols) loop - if Equal (S_Data, Complete_Symbols.Table (Index_2)) then - Cur := Index_2 + 1; - Complete_Symbols.Table (Index_2).Present := False; - Found := True; - exit First_Object_Loop; - end if; - end loop First_Object_Loop; - - -- If the symbol could not be found between Cur and Last, try - -- before Cur. - - if not Found then - Second_Object_Loop : - for Index_2 in 1 .. Cur - 1 loop - if Equal (S_Data, Complete_Symbols.Table (Index_2)) then - Cur := Index_2 + 1; - Complete_Symbols.Table (Index_2).Present := False; - Found := True; - exit Second_Object_Loop; - end if; - end loop Second_Object_Loop; - end if; - - -- If the symbol is not found, mark it as such in the table - - if not Found then - if (not Quiet) or else Sym_Policy = Controlled then - Put_Line ("symbol """ & S_Data.Name.all & - """ is no longer present in the object files"); - end if; - - if Sym_Policy = Controlled then - Success := False; - return; - - elsif Soft_Minor_ID then - Minor_ID := Minor_ID + 1; - Soft_Minor_ID := False; - end if; - - Original_Symbols.Table (Index_1).Present := False; - Free (Original_Symbols.Table (Index_1).Name); - - if Soft_Minor_ID then - Minor_ID := Minor_ID + 1; - Soft_Minor_ID := False; - end if; - end if; - end loop; - - -- Append additional symbols, if any, to the Original_Symbols table - - for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop - S_Data := Complete_Symbols.Table (Index); - - if S_Data.Present then - - if Sym_Policy = Controlled then - Put_Line ("symbol """ & S_Data.Name.all & - """ is not in the reference symbol file"); - Success := False; - return; - - elsif Soft_Minor_ID then - Minor_ID := Minor_ID + 1; - Soft_Minor_ID := False; - end if; - - Symbol_Table.Increment_Last (Original_Symbols); - Original_Symbols.Table (Symbol_Table.Last (Original_Symbols)) := - S_Data; - Complete_Symbols.Table (Index).Present := False; - end if; - end loop; - - -- Create the symbol file - - Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all); - - Put (File, Case_Sensitive); - Put_Line (File, "yes"); - - -- Put a line in the symbol file for each symbol in the symbol table - - for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop - if Original_Symbols.Table (Index).Present then - Put (File, Symbol_Vector); - Put (File, Original_Symbols.Table (Index).Name.all); - - if Original_Symbols.Table (Index).Kind = Data then - Put_Line (File, Equal_Data); - - else - Put_Line (File, Equal_Procedure); - end if; - - Free (Original_Symbols.Table (Index).Name); - end if; - end loop; - - Put (File, Case_Sensitive); - Put_Line (File, "NO"); - - -- Put the version IDs - - Put (File, Gsmatch); - Put (File, Image (Major_ID)); - Put (File, ','); - Put_Line (File, Image (Minor_ID)); - - -- And we are done - - Close (File); - - -- Reset both tables - - Symbol_Table.Set_Last (Original_Symbols, 0); - Symbol_Table.Set_Last (Complete_Symbols, 0); - - -- Clear the symbol file name - - Free (Symbol_File_Name); - - Success := True; - end if; - - exception - when X : others => - Put_Line ("unexpected exception raised while finalizing """ - & Symbol_File_Name.all & """"); - Put_Line (Exception_Information (X)); - Success := False; - end Finalize; - -end Symbols; diff --git a/gcc/ada/5vsystem.ads b/gcc/ada/5vsystem.ads deleted file mode 100644 index fc4fb2e6d6f..00000000000 --- a/gcc/ada/5vsystem.ads +++ /dev/null @@ -1,236 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (OpenVMS DEC Threads Version) -- --- -- --- Copyright (C) 1992-2004 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 := 0.01; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := False; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - Functions_Return_By_DSP : constant Boolean := False; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - OpenVMS : constant Boolean := True; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := True; - Stack_Check_Probes : constant Boolean := True; - 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 := False; - ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := False; - Front_End_ZCX_Support : constant Boolean := True; - - -- Obsolete entries, to be removed eventually (bootstrap issues!) - - High_Integrity_Mode : constant Boolean := False; - Long_Shifts_Inlined : constant Boolean := False; - - -------------------------- - -- Underlying Priorities -- - --------------------------- - - -- Important note: this section of the file must come AFTER the - -- definition of the system implementation parameters to ensure - -- that the value of these parameters is available for analysis - -- of the declarations here (using Rtsfind at compile time). - - -- The underlying priorities table provides a generalized mechanism - -- for mapping from Ada priorities to system priorities. In some - -- cases a 1-1 mapping is not the convenient or optimal choice. - - -- For DEC Threads OpenVMS, we use the full range of 31 priorities - -- in the Ada model, but map them by compression onto the more limited - -- range of priorities available in OpenVMS. - - -- To replace the default values of the Underlying_Priorities mapping, - -- copy this source file into your build directory, edit the file to - -- reflect your desired behavior, and recompile with the command: - - -- $ gcc -c -O3 -gnatpgn system.ads - - -- then recompile the run-time parts that depend on this package: - - -- $ gnatmake -a -gnatn -O3 - - -- then force rebuilding your application if you need different options: - - -- $ gnatmake -f - - type Priorities_Mapping is array (Any_Priority) of Integer; - pragma Suppress_Initialization (Priorities_Mapping); - -- Suppress initialization in case gnat.adc specifies Normalize_Scalars - - Underlying_Priorities : constant Priorities_Mapping := - - (Priority'First => 16, - - 1 => 17, - 2 => 18, - 3 => 18, - 4 => 18, - 5 => 18, - 6 => 19, - 7 => 19, - 8 => 19, - 9 => 20, - 10 => 20, - 11 => 21, - 12 => 21, - 13 => 22, - 14 => 23, - - Default_Priority => 24, - - 16 => 25, - 17 => 25, - 18 => 25, - 19 => 26, - 20 => 26, - 21 => 26, - 22 => 27, - 23 => 27, - 24 => 27, - 25 => 28, - 26 => 28, - 27 => 29, - 28 => 29, - 29 => 30, - - Priority'Last => 30, - - Interrupt_Priority => 31); - - ---------------------------- - -- Special VMS Interfaces -- - ---------------------------- - - procedure Lib_Stop (I : in Integer); - pragma Interface (C, Lib_Stop); - pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); - -- Interface to VMS condition handling. Used by RTSfind and pragma - -- {Import,Export}_Exception. Put here because this is the only - -- VMS specific package that doesn't drag in tasking. - -end System; diff --git a/gcc/ada/5vtaprop.adb b/gcc/ada/5vtaprop.adb deleted file mode 100644 index 5a7739d3abc..00000000000 --- a/gcc/ada/5vtaprop.adb +++ /dev/null @@ -1,1005 +0,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 . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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 a OpenVMS/Alpha version of this package - --- This package contains all the GNULL primitives that interface directly --- with the underlying OS. - -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.Tasking.Debug; --- used for Known_Tasks - -with Interfaces.C; --- used for int --- size_t - -with System.Parameters; --- used for Size_Type - -with System.Tasking; --- used for Ada_Task_Control_Block --- Task_ID - -with System.Soft_Links; --- used for Defer/Undefer_Abort --- Set_Exc_Stack_Addr - --- Note that we do not use System.Tasking.Initialization directly since --- this is a higher level package that we shouldn't depend on. For example --- when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Initialization - -with System.OS_Primitives; --- used for Delay_Modes - -with Unchecked_Conversion; -with Unchecked_Deallocation; - -package body System.Task_Primitives.Operations is - - use System.Tasking.Debug; - use System.Tasking; - use Interfaces.C; - use System.OS_Interface; - use System.Parameters; - use System.OS_Primitives; - use type System.OS_Primitives.OS_Time; - - package SSL renames System.Soft_Links; - - ------------------ - -- Local Data -- - ------------------ - - -- The followings are logically constants, but need to be initialized - -- at run time. - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_ID associated with a thread - - Environment_Task_ID : Task_ID; - -- A variable to hold Task_ID for the environment task. - - Time_Slice_Val : Integer; - pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - - Dispatching_Policy : Character; - pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - - FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; - -- Indicates whether FIFO_Within_Priorities is set. - - Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads). - - -------------------- - -- Local Packages -- - -------------------- - - package Specific is - - procedure Initialize (Environment_Task : Task_ID); - pragma Inline (Initialize); - -- Initialize various data needed by this package. - - function Is_Valid_Task return Boolean; - pragma Inline (Is_Valid_Task); - -- Does executing thread have a TCB? - - procedure Set (Self_Id : Task_ID); - pragma Inline (Set); - -- Set the self id for the current task - - function Self return Task_ID; - pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task - - end Specific; - - package body Specific is separate; - -- The body of this package is target specific. - - --------------------------------- - -- Support for foreign threads -- - --------------------------------- - - function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; - -- Allocate and Initialize a new ATCB for the current Thread - - function Register_Foreign_Thread - (Thread : Thread_Id) return Task_ID is separate; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID); - - function To_Address is new Unchecked_Conversion (Task_ID, System.Address); - - procedure Timer_Sleep_AST (ID : Address); - -- Signal the condition variable when AST fires. - - procedure Timer_Sleep_AST (ID : Address) is - Result : Interfaces.C.int; - Self_ID : constant Task_ID := To_Task_ID (ID); - begin - Self_ID.Common.LL.AST_Pending := False; - Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Timer_Sleep_AST; - - ----------------- - -- Stack_Guard -- - ----------------- - - -- The underlying thread system sets a guard page at the - -- bottom of a thread stack, so nothing is needed. - -- ??? Check the comment above - - procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is - pragma Unreferenced (T); - pragma Unreferenced (On); - begin - null; - end Stack_Guard; - - -------------------- - -- Get_Thread_Id -- - -------------------- - - function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_ID renames Specific.Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Initialize_TCB and the Storage_Error is - -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) - -- used in RTS is initialized before any status change of RTS. - -- Therefore rasing Storage_Error in the following routines - -- should be able to be handled safely. - - procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - L.Prio_Save := 0; - L.Prio := Interfaces.C.int (Prio); - - Result := pthread_mutex_init (L.L'Access, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is - pragma Unreferenced (Level); - - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - --- Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes??? --- Result := pthread_mutexattr_settype_np --- (Attributes'Access, PTHREAD_MUTEX_ERRORCHECK_NP); --- pragma Assert (Result = 0); - --- Result := pthread_mutexattr_setprotocol --- (Attributes'Access, PTHREAD_PRIO_PROTECT); --- pragma Assert (Result = 0); - --- Result := pthread_mutexattr_setprioceiling --- (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); --- pragma Assert (Result = 0); - - Result := pthread_mutex_init (L, Attributes'Access); - - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L.L'Access); - pragma Assert (Result = 0); - end Finalize_Lock; - - procedure Finalize_Lock (L : access RTS_Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0); - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - Self_ID : constant Task_ID := Self; - All_Tasks_Link : constant Task_ID := Self.Common.All_Tasks_Link; - Current_Prio : System.Any_Priority; - Result : Interfaces.C.int; - - begin - Current_Prio := Get_Priority (Self_ID); - - -- If there is no other tasks, no need to check priorities - - if All_Tasks_Link /= Null_Task - and then L.Prio < Interfaces.C.int (Current_Prio) - then - Ceiling_Violation := True; - return; - end if; - - Result := pthread_mutex_lock (L.L'Access); - pragma Assert (Result = 0); - - Ceiling_Violation := False; --- Why is this commented out ??? --- L.Prio_Save := Interfaces.C.int (Current_Prio); --- Set_Priority (Self_ID, System.Any_Priority (L.Prio)); - end Write_Lock; - - procedure Write_Lock - (L : access RTS_Lock; - Global_Lock : Boolean := False) - is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_lock (L); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - procedure Write_Lock (T : Task_ID) is - Result : Interfaces.C.int; - begin - if not Single_Lock then - Result := pthread_mutex_lock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - begin - Write_Lock (L, Ceiling_Violation); - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_unlock (L.L'Access); - pragma Assert (Result = 0); - end Unlock; - - procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); - end if; - end Unlock; - - procedure Unlock (T : Task_ID) is - Result : Interfaces.C.int; - begin - if not Single_Lock then - Result := pthread_mutex_unlock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Unlock; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : Task_ID; - Reason : System.Tasking.Task_States) - is - pragma Unreferenced (Reason); - Result : Interfaces.C.int; - - begin - if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; - - -- EINTR is not considered a failure - - pragma Assert (Result = 0 or else Result = EINTR); - - if Self_ID.Deferral_Level = 0 - and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - then - Unlock (Self_ID); - raise Standard'Abort_Signal; - end if; - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - procedure Timed_Sleep - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : System.Tasking.Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Unreferenced (Reason); - - Sleep_Time : OS_Time; - Result : Interfaces.C.int; - Status : Cond_Value_Type; - - -- The body below requires more comments ??? - - begin - Timedout := False; - Yielded := False; - - Sleep_Time := To_OS_Time (Time, Mode); - - if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change - then - return; - end if; - - Self_ID.Common.LL.AST_Pending := True; - - Sys_Setimr - (Status, 0, Sleep_Time, - Timer_Sleep_AST'Access, To_Address (Self_ID), 0); - - if (Status and 1) /= 1 then - raise Storage_Error; - end if; - - if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - pragma Assert (Result = 0); - - else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Yielded := True; - - if not Self_ID.Common.LL.AST_Pending then - Timedout := True; - else - Sys_Cantim (Status, To_Address (Self_ID), 0); - pragma Assert ((Status and 1) = 1); - end if; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes) - is - Sleep_Time : OS_Time; - Result : Interfaces.C.int; - Status : Cond_Value_Type; - Yielded : Boolean := False; - - begin - -- Only the little window between deferring abort and - -- locking Self_ID is the reason we need to - -- check for pending abort and priority change below! - - if Single_Lock then - Lock_RTS; - end if; - - -- More comments required in body below ??? - - SSL.Abort_Defer.all; - Write_Lock (Self_ID); - - if Time /= 0.0 or else Mode /= Relative then - Sleep_Time := To_OS_Time (Time, Mode); - - if Mode = Relative or else OS_Clock < Sleep_Time then - Self_ID.Common.State := Delay_Sleep; - Self_ID.Common.LL.AST_Pending := True; - - Sys_Setimr - (Status, 0, Sleep_Time, - Timer_Sleep_AST'Access, To_Address (Self_ID), 0); - - if (Status and 1) /= 1 then - raise Storage_Error; - end if; - - loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - - if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then - Sys_Cantim (Status, To_Address (Self_ID), 0); - pragma Assert ((Status and 1) = 1); - exit; - end if; - - if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - pragma Assert (Result = 0); - else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Yielded := True; - - exit when not Self_ID.Common.LL.AST_Pending; - end loop; - - Self_ID.Common.State := Runnable; - end if; - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - if not Yielded then - Result := sched_yield; - pragma Assert (Result = 0); - end if; - - SSL.Abort_Undefer.all; - end Timed_Delay; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration - renames System.OS_Primitives.Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - begin - return 10#1.0#E-3; - end RT_Resolution; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is - pragma Unreferenced (Reason); - - Result : Interfaces.C.int; - - begin - Result := pthread_cond_signal (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Wakeup; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - Result : Interfaces.C.int; - pragma Unreferenced (Result); - begin - if Do_Yield then - Result := sched_yield; - end if; - end Yield; - - ------------------ - -- Set_Priority -- - ------------------ - - procedure Set_Priority - (T : Task_ID; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) - is - pragma Unreferenced (Loss_Of_Inheritance); - - Result : Interfaces.C.int; - Param : aliased struct_sched_param; - - begin - T.Common.Current_Priority := Prio; - Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); - - if Time_Slice_Val > 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_RR, Param'Access); - - elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_FIFO, Param'Access); - - else - -- SCHED_OTHER priorities are restricted to the range 8 - 15. - -- Since the translation from Underlying priorities results - -- in a range of 16 - 31, dividing by 2 gives the correct result. - - Param.sched_priority := Param.sched_priority / 2; - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_OTHER, Param'Access); - end if; - - pragma Assert (Result = 0); - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_ID) return System.Any_Priority is - begin - return T.Common.Current_Priority; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (Self_ID : Task_ID) is - begin - Self_ID.Common.LL.Thread := pthread_self; - - Specific.Set (Self_ID); - - Lock_RTS; - - for J in Known_Tasks'Range loop - if Known_Tasks (J) = null then - Known_Tasks (J) := Self_ID; - Self_ID.Known_Tasks_Index := J; - exit; - end if; - end loop; - - Unlock_RTS; - end Enter_Task; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_ID is - begin - if Is_Valid_Task then - return Self; - else - return Register_Foreign_Thread (pthread_self); - end if; - end Register_Foreign_Thread; - - ---------------------- - -- Initialize_TCB -- - ---------------------- - - procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is - Mutex_Attr : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - Cond_Attr : aliased pthread_condattr_t; - - begin - -- More comments required in body below ??? - - if not Single_Lock then - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, - Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result = 0 then - Succeeded := True; - Self_ID.Common.LL.Exc_Stack_Ptr := new Exc_Stack_T; - SSL.Set_Exc_Stack_Addr - (To_Address (Self_ID), - Self_ID.Common.LL.Exc_Stack_Ptr (Exc_Stack_T'Last)'Address); - - else - if not Single_Lock then - Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Succeeded := False; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_ID; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - Attributes : aliased pthread_attr_t; - Adjusted_Stack_Size : Interfaces.C.size_t; - Result : Interfaces.C.int; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - begin - if Stack_Size = Unspecified_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size); - - elsif Stack_Size < Minimum_Stack_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); - - else - Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); - end if; - - -- Since the initial signal mask of a thread is inherited from the - -- creator, we need to set our local signal mask mask all signals - -- during the creation operation, to make sure the new thread is - -- not disturbed by signals before it has set its own Task_ID. - - Result := pthread_attr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_attr_setdetachstate - (Attributes'Access, PTHREAD_CREATE_DETACHED); - pragma Assert (Result = 0); - - Result := pthread_attr_setstacksize - (Attributes'Access, Adjusted_Stack_Size); - pragma Assert (Result = 0); - - -- This call may be unnecessary, not sure. ??? - - Result := - pthread_attr_setinheritsched - (Attributes'Access, PTHREAD_EXPLICIT_SCHED); - pragma Assert (Result = 0); - - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); - - -- ENOMEM is a valid run-time error. Don't shut down. - - pragma Assert (Result = 0 - or else Result = EAGAIN or else Result = ENOMEM); - - Succeeded := Result = 0; - - Result := pthread_attr_destroy (Attributes'Access); - pragma Assert (Result = 0); - - if Succeeded then - Set_Priority (T, Priority); - end if; - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_ID) is - Result : Interfaces.C.int; - Tmp : Task_ID := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); - - procedure Free is new Unchecked_Deallocation - (Exc_Stack_T, Exc_Stack_Ptr_T); - - begin - if not Single_Lock then - Result := pthread_mutex_destroy (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_cond_destroy (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - Free (T.Common.LL.Exc_Stack_Ptr); - - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - procedure Exit_Task is - begin - Specific.Set (null); - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_ID) is - begin - -- Interrupt Server_Tasks may be waiting on an event flag - - if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then - Wakeup (T, Interrupt_Server_Blocked_On_Event_Flag); - end if; - end Abort_Task; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy version - - function Check_Exit (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - - begin - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - - begin - return True; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_ID is - begin - return Environment_Task_ID; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) return Boolean - is - pragma Unreferenced (T); - pragma Unreferenced (Thread_Self); - - begin - return False; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) return Boolean - is - pragma Unreferenced (T); - pragma Unreferenced (Thread_Self); - begin - return False; - end Resume_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_ID) is - begin - Environment_Task_ID := Environment_Task; - - -- Initialize the lock used to synchronize chain of all ATCBs - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - - Specific.Initialize (Environment_Task); - - Enter_Task (Environment_Task); - end Initialize; - -end System.Task_Primitives.Operations; diff --git a/gcc/ada/5vtaspri.ads b/gcc/ada/5vtaspri.ads deleted file mode 100644 index 09179325c81..00000000000 --- a/gcc/ada/5vtaspri.ads +++ /dev/null @@ -1,105 +0,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-2000 Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a OpenVMS/Alpha version of this package. - --- This package provides low-level support for most tasking features. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with Interfaces.C; --- used for int --- size_t - -with System.OS_Interface; --- used for pthread_mutex_t --- pthread_cond_t --- pthread_t - -package System.Task_Primitives is - - type Lock is limited private; - -- Should be used for implementation of protected objects. - - type RTS_Lock is limited private; - -- Should be used inside the runtime system. - -- The difference between Lock and the RTS_Lock is that the later - -- one serves only as a semaphore so that do not check for - -- ceiling violations. - - type Task_Body_Access is access procedure; - -- Pointer to the task body's entry point (or possibly a wrapper - -- declared local to the GNARL). - - type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task - -- basis. A component of this type is guaranteed to be included - -- in the Ada_Task_Control_Block. - -private - - type Exc_Stack_T is array (0 .. 8192) of aliased Character; - for Exc_Stack_T'Alignment use Standard'Maximum_Alignment; - type Exc_Stack_Ptr_T is access all Exc_Stack_T; - - type Lock is record - L : aliased System.OS_Interface.pthread_mutex_t; - Prio : Interfaces.C.int; - Prio_Save : Interfaces.C.int; - end record; - - type RTS_Lock is new System.OS_Interface.pthread_mutex_t; - type Private_Data is record - Thread : aliased System.OS_Interface.pthread_t; - pragma Atomic (Thread); - -- Thread field may be updated by two different threads of control. - -- (See, Enter_Task and Create_Task in s-taprop.adb). - -- They put the same value (thr_self value). We do not want to - -- use lock on those operations and the only thing we have to - -- make sure is that they are updated in atomic fashion. - - CV : aliased System.OS_Interface.pthread_cond_t; - L : aliased RTS_Lock; - -- protection for all components is lock L - - Exc_Stack_Ptr : Exc_Stack_Ptr_T; - -- ??? This needs comments. - - AST_Pending : Boolean; - -- Used to detect delay and sleep timeouts - - end record; - -end System.Task_Primitives; diff --git a/gcc/ada/5vtpopde.adb b/gcc/ada/5vtpopde.adb deleted file mode 100644 index 89db8240ad8..00000000000 --- a/gcc/ada/5vtpopde.adb +++ /dev/null @@ -1,163 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-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 package is for OpenVMS/Alpha - -with System.OS_Interface; -with System.Parameters; -with System.Tasking; -with Unchecked_Conversion; -with System.Soft_Links; - -package body System.Task_Primitives.Operations.DEC is - - use System.OS_Interface; - use System.Parameters; - use System.Tasking; - use System.Aux_DEC; - use type Interfaces.C.int; - - package SSL renames System.Soft_Links; - - -- The FAB_RAB_Type specifies where the context field (the calling - -- task) is stored. Other fields defined for FAB_RAB arent' need and - -- so are ignored. - - type FAB_RAB_Type is record - CTX : Unsigned_Longword; - end record; - - for FAB_RAB_Type use record - CTX at 24 range 0 .. 31; - end record; - - for FAB_RAB_Type'Size use 224; - - type FAB_RAB_Access_Type is access all FAB_RAB_Type; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function To_Unsigned_Longword is new - Unchecked_Conversion (Task_ID, Unsigned_Longword); - - function To_Task_Id is new - Unchecked_Conversion (Unsigned_Longword, Task_ID); - - function To_FAB_RAB is new - Unchecked_Conversion (Address, FAB_RAB_Access_Type); - - --------------------------- - -- Interrupt_AST_Handler -- - --------------------------- - - procedure Interrupt_AST_Handler (ID : Address) is - Result : Interfaces.C.int; - AST_Self_ID : constant Task_ID := To_Task_ID (ID); - begin - Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Interrupt_AST_Handler; - - --------------------- - -- RMS_AST_Handler -- - --------------------- - - procedure RMS_AST_Handler (ID : Address) is - AST_Self_ID : constant Task_ID := To_Task_Id (To_FAB_RAB (ID).CTX); - Result : Interfaces.C.int; - - begin - AST_Self_ID.Common.LL.AST_Pending := False; - Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); - pragma Assert (Result = 0); - end RMS_AST_Handler; - - ---------- - -- Self -- - ---------- - - function Self return Unsigned_Longword is - Self_ID : constant Task_ID := Self; - begin - Self_ID.Common.LL.AST_Pending := True; - return To_Unsigned_Longword (Self); - end Self; - - ------------------------- - -- Starlet_AST_Handler -- - ------------------------- - - procedure Starlet_AST_Handler (ID : Address) is - Result : Interfaces.C.int; - AST_Self_ID : constant Task_ID := To_Task_ID (ID); - begin - AST_Self_ID.Common.LL.AST_Pending := False; - Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Starlet_AST_Handler; - - ---------------- - -- Task_Synch -- - ---------------- - - procedure Task_Synch is - Synch_Self_ID : constant Task_ID := Self; - - begin - if Single_Lock then - Lock_RTS; - else - Write_Lock (Synch_Self_ID); - end if; - - SSL.Abort_Defer.all; - Synch_Self_ID.Common.State := AST_Server_Sleep; - - while Synch_Self_ID.Common.LL.AST_Pending loop - Sleep (Synch_Self_ID, AST_Server_Sleep); - end loop; - - Synch_Self_ID.Common.State := Runnable; - - if Single_Lock then - Unlock_RTS; - else - Unlock (Synch_Self_ID); - end if; - - SSL.Abort_Undefer.all; - end Task_Synch; - -end System.Task_Primitives.Operations.DEC; diff --git a/gcc/ada/5vtpopde.ads b/gcc/ada/5vtpopde.ads deleted file mode 100644 index 46d92470f0b..00000000000 --- a/gcc/ada/5vtpopde.ads +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-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 package is for OpenVMS/Alpha. --- -with System.Aux_DEC; -package System.Task_Primitives.Operations.DEC is - - procedure Interrupt_AST_Handler (ID : Address); - -- Handles the AST for Ada95 Interrupts. - - procedure RMS_AST_Handler (ID : Address); - -- Handles the AST for RMS_Asynch_Operations. - - function Self return System.Aux_DEC.Unsigned_Longword; - -- Returns the task identification for the AST. - - procedure Starlet_AST_Handler (ID : Address); - -- Handles the AST for Starlet Tasking_Services. - - procedure Task_Synch; - -- Synchronizes the task after the system service completes. - -end System.Task_Primitives.Operations.DEC; diff --git a/gcc/ada/5vtraent.adb b/gcc/ada/5vtraent.adb deleted file mode 100644 index 532acad6e32..00000000000 --- a/gcc/ada/5vtraent.adb +++ /dev/null @@ -1,68 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K _ E N T R I E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003 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 body System.Traceback_Entries is - - ------------ - -- PC_For -- - ------------ - - function PC_For (TB_Entry : Traceback_Entry) return System.Address is - begin - return TB_Entry.PC; - end PC_For; - - ------------ - -- PV_For -- - ------------ - - function PV_For (TB_Entry : Traceback_Entry) return System.Address is - begin - return TB_Entry.PV; - end PV_For; - - ------------------ - -- TB_Entry_For -- - ------------------ - - function TB_Entry_For (PC : System.Address) return Traceback_Entry is - begin - return (PC => PC, PV => System.Null_Address); - end TB_Entry_For; - -end System.Traceback_Entries; - diff --git a/gcc/ada/5vtraent.ads b/gcc/ada/5vtraent.ads deleted file mode 100644 index 0d27c197fff..00000000000 --- a/gcc/ada/5vtraent.ads +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K _ E N T R I E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2003 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. -- --- -- ------------------------------------------------------------------------------- - --- This is the Alpha/OpenVMS version of this package - -package System.Traceback_Entries is - - type Traceback_Entry is record - PC : System.Address; - PV : System.Address; - end record; - - pragma Suppress_Initialization (Traceback_Entry); - - Null_TB_Entry : constant Traceback_Entry := - (PC => System.Null_Address, - PV => System.Null_Address); - - function PC_For (TB_Entry : Traceback_Entry) return System.Address; - function PV_For (TB_Entry : Traceback_Entry) return System.Address; - - function TB_Entry_For (PC : System.Address) return Traceback_Entry; - -end System.Traceback_Entries; - diff --git a/gcc/ada/5vvaflop.adb b/gcc/ada/5vvaflop.adb deleted file mode 100644 index 8b1bf031fa4..00000000000 --- a/gcc/ada/5vvaflop.adb +++ /dev/null @@ -1,621 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2000 Free Software Foundation, Inc. -- --- (Version for Alpha OpenVMS) -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 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. -- --- -- ------------------------------------------------------------------------------- - -with System.IO; use System.IO; -with System.Machine_Code; use System.Machine_Code; - -package body System.Vax_Float_Operations is - - -- Ensure this gets compiled with -O to avoid extra (and possibly - -- improper) memory stores. - - pragma Optimize (Time); - - -- Declare the functions that do the conversions between floating-point - -- formats. Call the operands IEEE float so they get passed in - -- FP registers. - - function Cvt_G_T (X : T) return T; - function Cvt_T_G (X : T) return T; - function Cvt_T_F (X : T) return S; - - pragma Import (C, Cvt_G_T, "OTS$CVT_FLOAT_G_T"); - pragma Import (C, Cvt_T_G, "OTS$CVT_FLOAT_T_G"); - pragma Import (C, Cvt_T_F, "OTS$CVT_FLOAT_T_F"); - - -- In each of the conversion routines that are done with OTS calls, - -- we define variables of the corresponding IEEE type so that they are - -- passed and kept in the proper register class. - - ------------ - -- D_To_G -- - ------------ - - function D_To_G (X : D) return G is - A, B : T; - C : G; - - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), D'Asm_Input ("m", X)); - Asm ("cvtdg %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B)); - return C; - end D_To_G; - - ------------ - -- F_To_G -- - ------------ - - function F_To_G (X : F) return G is - A : T; - B : G; - - begin - Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X)); - Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A)); - return B; - end F_To_G; - - ------------ - -- F_To_S -- - ------------ - - function F_To_S (X : F) return S is - A : T; - B : S; - - begin - -- Because converting to a wider FP format is a no-op, we say - -- A is 64-bit even though we are loading 32 bits into it. - Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X)); - - B := S (Cvt_G_T (A)); - return B; - end F_To_S; - - ------------ - -- G_To_D -- - ------------ - - function G_To_D (X : G) return D is - A, B : T; - C : D; - - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - Asm ("cvtgd %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - Asm ("stg %1,%0", D'Asm_Output ("=m", C), T'Asm_Input ("f", B)); - return C; - end G_To_D; - - ------------ - -- G_To_F -- - ------------ - - function G_To_F (X : G) return F is - A : T; - B : S; - C : F; - - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - Asm ("cvtgf %1,%0", S'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B)); - return C; - end G_To_F; - - ------------ - -- G_To_Q -- - ------------ - - function G_To_Q (X : G) return Q is - A : T; - B : Q; - - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - Asm ("cvtgq %1,%0", Q'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - return B; - end G_To_Q; - - ------------ - -- G_To_T -- - ------------ - - function G_To_T (X : G) return T is - A, B : T; - - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - B := Cvt_G_T (A); - return B; - end G_To_T; - - ------------ - -- F_To_Q -- - ------------ - - function F_To_Q (X : F) return Q is - begin - return G_To_Q (F_To_G (X)); - end F_To_Q; - - ------------ - -- Q_To_F -- - ------------ - - function Q_To_F (X : Q) return F is - A : S; - B : F; - - begin - Asm ("cvtqf %1,%0", S'Asm_Output ("=f", A), Q'Asm_Input ("f", X)); - Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A)); - return B; - end Q_To_F; - - ------------ - -- Q_To_G -- - ------------ - - function Q_To_G (X : Q) return G is - A : T; - B : G; - - begin - Asm ("cvtqg %1,%0", T'Asm_Output ("=f", A), Q'Asm_Input ("f", X)); - Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A)); - return B; - end Q_To_G; - - ------------ - -- S_To_F -- - ------------ - - function S_To_F (X : S) return F is - A : S; - B : F; - - begin - A := Cvt_T_F (T (X)); - Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A)); - return B; - end S_To_F; - - ------------ - -- T_To_D -- - ------------ - - function T_To_D (X : T) return D is - begin - return G_To_D (T_To_G (X)); - end T_To_D; - - ------------ - -- T_To_G -- - ------------ - - function T_To_G (X : T) return G is - A : T; - B : G; - - begin - A := Cvt_T_G (X); - Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A)); - return B; - end T_To_G; - - ----------- - -- Abs_F -- - ----------- - - function Abs_F (X : F) return F is - A, B : S; - C : F; - - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X)); - Asm ("cpys $f31,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A)); - Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B)); - return C; - end Abs_F; - - ----------- - -- Abs_G -- - ----------- - - function Abs_G (X : G) return G is - A, B : T; - C : G; - - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - Asm ("cpys $f31,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B)); - return C; - end Abs_G; - - ----------- - -- Add_F -- - ----------- - - function Add_F (X, Y : F) return F is - X1, Y1, R : S; - R1 : F; - - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("addf %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R)); - return R1; - end Add_F; - - ----------- - -- Add_G -- - ----------- - - function Add_G (X, Y : G) return G is - X1, Y1, R : T; - R1 : G; - - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("addg %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R)); - return R1; - end Add_G; - - -------------------- - -- Debug_Output_D -- - -------------------- - - procedure Debug_Output_D (Arg : D) is - begin - Put (D'Image (Arg)); - end Debug_Output_D; - - -------------------- - -- Debug_Output_F -- - -------------------- - - procedure Debug_Output_F (Arg : F) is - begin - Put (F'Image (Arg)); - end Debug_Output_F; - - -------------------- - -- Debug_Output_G -- - -------------------- - - procedure Debug_Output_G (Arg : G) is - begin - Put (G'Image (Arg)); - end Debug_Output_G; - - -------------------- - -- Debug_String_D -- - -------------------- - - Debug_String_Buffer : String (1 .. 32); - -- Buffer used by all Debug_String_x routines for returning result - - function Debug_String_D (Arg : D) return System.Address is - Image_String : constant String := D'Image (Arg) & ASCII.NUL; - Image_Size : constant Integer := Image_String'Length; - - begin - Debug_String_Buffer (1 .. Image_Size) := Image_String; - return Debug_String_Buffer (1)'Address; - end Debug_String_D; - - -------------------- - -- Debug_String_F -- - -------------------- - - function Debug_String_F (Arg : F) return System.Address is - Image_String : constant String := F'Image (Arg) & ASCII.NUL; - Image_Size : constant Integer := Image_String'Length; - - begin - Debug_String_Buffer (1 .. Image_Size) := Image_String; - return Debug_String_Buffer (1)'Address; - end Debug_String_F; - - -------------------- - -- Debug_String_G -- - -------------------- - - function Debug_String_G (Arg : G) return System.Address is - Image_String : constant String := G'Image (Arg) & ASCII.NUL; - Image_Size : constant Integer := Image_String'Length; - - begin - Debug_String_Buffer (1 .. Image_Size) := Image_String; - return Debug_String_Buffer (1)'Address; - end Debug_String_G; - - ----------- - -- Div_F -- - ----------- - - function Div_F (X, Y : F) return F is - X1, Y1, R : S; - - R1 : F; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("divf %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R)); - return R1; - end Div_F; - - ----------- - -- Div_G -- - ----------- - - function Div_G (X, Y : G) return G is - X1, Y1, R : T; - R1 : G; - - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("divg %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R)); - return R1; - end Div_G; - - ---------- - -- Eq_F -- - ---------- - - function Eq_F (X, Y : F) return Boolean is - X1, Y1, R : S; - - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("cmpgeq %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - return R /= 0.0; - end Eq_F; - - ---------- - -- Eq_G -- - ---------- - - function Eq_G (X, Y : G) return Boolean is - X1, Y1, R : T; - - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("cmpgeq %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - return R /= 0.0; - end Eq_G; - - ---------- - -- Le_F -- - ---------- - - function Le_F (X, Y : F) return Boolean is - X1, Y1, R : S; - - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("cmpgle %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - return R /= 0.0; - end Le_F; - - ---------- - -- Le_G -- - ---------- - - function Le_G (X, Y : G) return Boolean is - X1, Y1, R : T; - - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("cmpgle %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - return R /= 0.0; - end Le_G; - - ---------- - -- Lt_F -- - ---------- - - function Lt_F (X, Y : F) return Boolean is - X1, Y1, R : S; - - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("cmpglt %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - return R /= 0.0; - end Lt_F; - - ---------- - -- Lt_G -- - ---------- - - function Lt_G (X, Y : G) return Boolean is - X1, Y1, R : T; - - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("cmpglt %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - return R /= 0.0; - end Lt_G; - - ----------- - -- Mul_F -- - ----------- - - function Mul_F (X, Y : F) return F is - X1, Y1, R : S; - R1 : F; - - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("mulf %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R)); - return R1; - end Mul_F; - - ----------- - -- Mul_G -- - ----------- - - function Mul_G (X, Y : G) return G is - X1, Y1, R : T; - R1 : G; - - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("mulg %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R)); - return R1; - end Mul_G; - - ----------- - -- Neg_F -- - ----------- - - function Neg_F (X : F) return F is - A, B : S; - C : F; - - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X)); - Asm ("cpysn %1,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A)); - Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B)); - return C; - end Neg_F; - - ----------- - -- Neg_G -- - ----------- - - function Neg_G (X : G) return G is - A, B : T; - C : G; - - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - Asm ("cpysn %1,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B)); - return C; - end Neg_G; - - -------- - -- pd -- - -------- - - procedure pd (Arg : D) is - begin - Put_Line (D'Image (Arg)); - end pd; - - -------- - -- pf -- - -------- - - procedure pf (Arg : F) is - begin - Put_Line (F'Image (Arg)); - end pf; - - -------- - -- pg -- - -------- - - procedure pg (Arg : G) is - begin - Put_Line (G'Image (Arg)); - end pg; - - ----------- - -- Sub_F -- - ----------- - - function Sub_F (X, Y : F) return F is - X1, Y1, R : S; - R1 : F; - - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("subf %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R)); - return R1; - end Sub_F; - - ----------- - -- Sub_G -- - ----------- - - function Sub_G (X, Y : G) return G is - X1, Y1, R : T; - R1 : G; - - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("subg %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R)); - return R1; - end Sub_G; - -end System.Vax_Float_Operations; diff --git a/gcc/ada/5wdirval.adb b/gcc/ada/5wdirval.adb deleted file mode 100644 index a20ff177973..00000000000 --- a/gcc/ada/5wdirval.adb +++ /dev/null @@ -1,146 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I R E C T O R I E S . V A L I D I T Y -- --- -- --- B o d y -- --- (Windows Version) -- --- -- --- Copyright (C) 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 Windows version of this package - -with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; - -package body Ada.Directories.Validity is - - Invalid_Character : constant array (Character) of Boolean := - (NUL .. US => True, - '/' | ':' | '*' | '?' => True, - '"' | '<' | '>' | '|' => True, - DEL .. NBSP => True, - others => False); - - ------------------------ - -- Is_Valid_Path_Name -- - ------------------------ - - function Is_Valid_Path_Name (Name : String) return Boolean is - Start : Positive := Name'First; - Last : Natural; - - begin - -- A path name cannot be empty, cannot contain more than 256 characters, - -- cannot contain invalid characters and each directory/file name need - -- to be valid. - - if Name'Length = 0 or else Name'Length > 256 then - return False; - - else - -- A drive letter may be specified at the beginning - - if Name'Length >= 2 - and then Name (Start + 1) = ':' - and then - (Name (Start) in 'A' .. 'Z' or else - Name (Start) in 'a' .. 'z') - then - Start := Start + 2; - end if; - - loop - -- Look for the start of the next directory or file name - - while Start <= Name'Last and then Name (Start) = '\' loop - Start := Start + 1; - end loop; - - -- If all directories/file names are OK, return True - - exit when Start > Name'Last; - - Last := Start; - - -- Look for the end of the directory/file name - - while Last < Name'Last loop - exit when Name (Last + 1) = '\'; - Last := Last + 1; - end loop; - - -- Check if the directory/file name is valid - - if not Is_Valid_Simple_Name (Name (Start .. Last)) then - return False; - end if; - - -- Move to the next name - - Start := Last + 1; - end loop; - end if; - - -- If Name follows the rules, it is valid - - return True; - end Is_Valid_Path_Name; - - -------------------------- - -- Is_Valid_Simple_Name -- - -------------------------- - - function Is_Valid_Simple_Name (Name : String) return Boolean is - Only_Spaces : Boolean; - - begin - -- A file name cannot be empty, cannot contain more than 256 characters, - -- and cannot contain invalid characters, including '\' - - if Name'Length = 0 or else Name'Length > 256 then - return False; - - -- Name length is OK - - else - Only_Spaces := True; - for J in Name'Range loop - if Invalid_Character (Name (J)) or else Name (J) = '\' then - return False; - elsif Name (J) /= ' ' then - Only_Spaces := False; - end if; - end loop; - - -- If no invalid chars, and not all spaces, file name is valid. - - return not Only_Spaces; - end if; - end Is_Valid_Simple_Name; - -end Ada.Directories.Validity; - diff --git a/gcc/ada/5wgloloc.adb b/gcc/ada/5wgloloc.adb deleted file mode 100644 index 2b775b239db..00000000000 --- a/gcc/ada/5wgloloc.adb +++ /dev/null @@ -1,113 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . G L O B A L _ L O C K S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This implementation is specific to NT. - -with GNAT.Task_Lock; - -with Interfaces.C.Strings; -with System.OS_Interface; - -package body System.Global_Locks is - - package TSL renames GNAT.Task_Lock; - package OSI renames System.OS_Interface; - package ICS renames Interfaces.C.Strings; - - subtype Lock_File_Entry is OSI.HANDLE; - - Last_Lock : Lock_Type := Null_Lock; - Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry; - - ----------------- - -- Create_Lock -- - ----------------- - - procedure Create_Lock - (Lock : out Lock_Type; - Name : in String) - is - L : Lock_Type; - - begin - TSL.Lock; - Last_Lock := Last_Lock + 1; - L := Last_Lock; - TSL.Unlock; - - if L > Lock_Table'Last then - raise Lock_Error; - end if; - - Lock_Table (L) := - OSI.CreateMutex (null, OSI.BOOL (False), ICS.New_String (Name)); - Lock := L; - end Create_Lock; - - ------------------ - -- Acquire_Lock -- - ------------------ - - procedure Acquire_Lock - (Lock : in out Lock_Type) - is - use type OSI.DWORD; - - Res : OSI.DWORD; - begin - Res := OSI.WaitForSingleObject (Lock_Table (Lock), OSI.Wait_Infinite); - - if Res = OSI.WAIT_FAILED then - raise Lock_Error; - end if; - end Acquire_Lock; - - ------------------ - -- Release_Lock -- - ------------------ - - procedure Release_Lock - (Lock : in out Lock_Type) - is - use type OSI.BOOL; - - Res : OSI.BOOL; - begin - Res := OSI.ReleaseMutex (Lock_Table (Lock)); - - if Res = OSI.False then - raise Lock_Error; - end if; - end Release_Lock; - -end System.Global_Locks; diff --git a/gcc/ada/5wintman.adb b/gcc/ada/5wintman.adb deleted file mode 100644 index 362e50132ff..00000000000 --- a/gcc/ada/5wintman.adb +++ /dev/null @@ -1,78 +0,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) 1991-2000 Free Software Foundation, Inc. -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the NT version of this package - --- This file performs the system-dependent translation between machine --- exceptions and the Ada exceptions, if any, that should be raised when they --- occur. - --- PLEASE DO NOT add any dependences on other packages. --- 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. - -with System.OS_Interface; use System.OS_Interface; - -package body System.Interrupt_Management is - - --------------------------- - -- Initialize_Interrupts -- - --------------------------- - - -- Nothing needs to be done on this platform. - - procedure Initialize_Interrupts is - begin - null; - end Initialize_Interrupts; - -begin - -- "Reserve" all the interrupts, except those that are explicitely defined - - for J in Interrupt_ID'Range loop - Reserve (J) := True; - end loop; - - Reserve (SIGINT) := False; - Reserve (SIGILL) := False; - Reserve (SIGABRT) := False; - Reserve (SIGFPE) := False; - Reserve (SIGSEGV) := False; - Reserve (SIGTERM) := False; -end System.Interrupt_Management; diff --git a/gcc/ada/5wmemory.adb b/gcc/ada/5wmemory.adb deleted file mode 100644 index a81665a0a59..00000000000 --- a/gcc/ada/5wmemory.adb +++ /dev/null @@ -1,223 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M E M O R Y -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2003 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 version provides ways to limit the amount of used memory for systems --- that do not have OS support for that. - --- The amount of available memory available for dynamic allocation is limited --- by setting the environment variable GNAT_MEMORY_LIMIT to the number of --- kilobytes that can be used. --- --- Windows is currently using this version. - -with Ada.Exceptions; -with System.Soft_Links; - -package body System.Memory is - - use Ada.Exceptions; - use System.Soft_Links; - - function c_malloc (Size : size_t) return System.Address; - pragma Import (C, c_malloc, "malloc"); - - procedure c_free (Ptr : System.Address); - pragma Import (C, c_free, "free"); - - function c_realloc - (Ptr : System.Address; Size : size_t) return System.Address; - pragma Import (C, c_realloc, "realloc"); - - function msize (Ptr : System.Address) return size_t; - pragma Import (C, msize, "_msize"); - - function getenv (Str : String) return System.Address; - pragma Import (C, getenv); - - function atoi (Str : System.Address) return Integer; - pragma Import (C, atoi); - - Available_Memory : size_t := 0; - -- Amount of memory that is available for heap allocations. - -- A value of 0 means that the amount is not yet initialized. - - Msize_Accuracy : constant := 4096; - -- Defines the amount of memory to add to requested allocation sizes, - -- because malloc may return a bigger block than requested. As msize - -- is used when by Free, it must be used on allocation as well. To - -- prevent underflow of available_memory we need to use a reserve. - - procedure Check_Available_Memory (Size : size_t); - -- This routine must be called while holding the task lock. When the - -- memory limit is not yet initialized, it will be set to the value of - -- the GNAT_MEMORY_LIMIT environment variable or to unlimited if that - -- does not exist. If the size is larger than the amount of available - -- memory, the task lock will be freed and a storage_error exception - -- will be raised. - - ----------- - -- Alloc -- - ----------- - - function Alloc (Size : size_t) return System.Address is - Result : System.Address; - Actual_Size : size_t := Size; - - begin - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - -- Change size from zero to non-zero. We still want a proper pointer - -- for the zero case because pointers to zero length objects have to - -- be distinct, but we can't just go ahead and allocate zero bytes, - -- since some malloc's return zero for a zero argument. - - if Size = 0 then - Actual_Size := 1; - end if; - - Lock_Task.all; - - if Actual_Size + Msize_Accuracy >= Available_Memory then - Check_Available_Memory (Size + Msize_Accuracy); - end if; - - Result := c_malloc (Actual_Size); - - if Result /= System.Null_Address then - Available_Memory := Available_Memory - msize (Result); - end if; - - Unlock_Task.all; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Alloc; - - ---------------------------- - -- Check_Available_Memory -- - ---------------------------- - - procedure Check_Available_Memory (Size : size_t) is - Gnat_Memory_Limit : System.Address; - - begin - if Available_Memory = 0 then - - -- The amount of available memory hasn't been initialized yet - - Gnat_Memory_Limit := getenv ("GNAT_MEMORY_LIMIT" & ASCII.NUL); - - if Gnat_Memory_Limit /= System.Null_Address then - Available_Memory := - size_t (atoi (Gnat_Memory_Limit)) * 1024 + Msize_Accuracy; - else - Available_Memory := size_t'Last; - end if; - end if; - - if Size >= Available_Memory then - - -- There is a memory overflow - - Unlock_Task.all; - Raise_Exception - (Storage_Error'Identity, "heap memory limit exceeded"); - end if; - end Check_Available_Memory; - - ---------- - -- Free -- - ---------- - - procedure Free (Ptr : System.Address) is - begin - Lock_Task.all; - - if Ptr /= System.Null_Address then - Available_Memory := Available_Memory + msize (Ptr); - end if; - - c_free (Ptr); - - Unlock_Task.all; - end Free; - - ------------- - -- Realloc -- - ------------- - - function Realloc - (Ptr : System.Address; - Size : size_t) - return System.Address - is - Result : System.Address; - Actual_Size : constant size_t := Size; - Old_Size : size_t; - - begin - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - Lock_Task.all; - - Old_Size := msize (Ptr); - - -- Conservative check - no need to try to be precise here - - if Size + Msize_Accuracy >= Available_Memory then - Check_Available_Memory (Size + Msize_Accuracy); - end if; - - Result := c_realloc (Ptr, Actual_Size); - - if Result /= System.Null_Address then - Available_Memory := Available_Memory + Old_Size - msize (Result); - end if; - - Unlock_Task.all; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Realloc; - -end System.Memory; diff --git a/gcc/ada/5wml-tgt.adb b/gcc/ada/5wml-tgt.adb deleted file mode 100644 index 485be34bea6..00000000000 --- a/gcc/ada/5wml-tgt.adb +++ /dev/null @@ -1,347 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T -- --- (Windows Version) -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2004, 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. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a set of target dependent routines to build --- static, dynamic and shared libraries. - --- This is the Windows version of the body. - -with Namet; use Namet; -with Opt; -with Output; use Output; -with Prj.Com; - -with GNAT.OS_Lib; use GNAT.OS_Lib; - -with MDLL; -with MDLL.Utl; -with MLib.Fil; - -package body MLib.Tgt is - - --------------------- - -- Archive_Builder -- - --------------------- - - function Archive_Builder return String is - begin - return "ar"; - end Archive_Builder; - - ----------------------------- - -- Archive_Builder_Options -- - ----------------------------- - - function Archive_Builder_Options return String_List_Access is - begin - return new String_List'(1 => new String'("cr")); - end Archive_Builder_Options; - - ----------------- - -- Archive_Ext -- - ----------------- - - function Archive_Ext return String is - begin - return "a"; - end Archive_Ext; - - --------------------- - -- Archive_Indexer -- - --------------------- - - function Archive_Indexer return String is - begin - return "ranlib"; - end Archive_Indexer; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Foreign : Argument_List; - Afiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Address : String := ""; - Lib_Version : String := ""; - Relocatable : Boolean := False; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Ofiles); - pragma Unreferenced (Interfaces); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Driver_Name); - pragma Unreferenced (Lib_Version); - pragma Unreferenced (Auto_Init); - - Imp_File : constant String := - "lib" & MLib.Fil.Ext_To (Lib_Filename, Archive_Ext); - -- Name of the import library - - DLL_File : constant String := MLib.Fil.Ext_To (Lib_Filename, DLL_Ext); - -- Name of the DLL file - - Lib_File : constant String := Lib_Dir & Directory_Separator & DLL_File; - -- Full path of the DLL file - - Success : Boolean; - - begin - if Opt.Verbose_Mode then - if Relocatable then - Write_Str ("building relocatable shared library "); - else - Write_Str ("building non-relocatable shared library "); - end if; - - Write_Line (Lib_File); - end if; - - MDLL.Verbose := Opt.Verbose_Mode; - MDLL.Quiet := not MDLL.Verbose; - - MDLL.Utl.Locate; - - MDLL.Build_Dynamic_Library - (Foreign, Afiles, - MDLL.Null_Argument_List, MDLL.Null_Argument_List, Options, - Lib_Filename, Lib_Filename & ".def", - Lib_Address, True, Relocatable); - - -- Move the DLL and import library in the lib directory - - Copy_File (DLL_File, Lib_Dir, Success, Mode => Overwrite); - - if not Success then - Fail ("could not copy DLL to library dir"); - end if; - - Copy_File (Imp_File, Lib_Dir, Success, Mode => Overwrite); - - if not Success then - Fail ("could not copy import library to library dir"); - end if; - - -- Delete files - - Delete_File (DLL_File, Success); - - if not Success then - Fail ("could not delete DLL from build dir"); - end if; - - Delete_File (Imp_File, Success); - - if not Success then - Fail ("could not delete import library from build dir"); - end if; - end Build_Dynamic_Library; - - ------------------------- - -- Default_DLL_Address -- - ------------------------- - - function Default_DLL_Address return String is - begin - return "0x11000000"; - end Default_DLL_Address; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return "dll"; - end DLL_Ext; - - -------------------- - -- Dynamic_Option -- - -------------------- - - function Dynamic_Option return String is - begin - return ""; - end Dynamic_Option; - - ------------------- - -- Is_Object_Ext -- - ------------------- - - function Is_Object_Ext (Ext : String) return Boolean is - begin - return Ext = ".o"; - end Is_Object_Ext; - - -------------- - -- Is_C_Ext -- - -------------- - - function Is_C_Ext (Ext : String) return Boolean is - begin - return Ext = ".c"; - end Is_C_Ext; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".a"; - end Is_Archive_Ext; - - ------------- - -- Libgnat -- - ------------- - - function Libgnat return String is - begin - return "libgnat.a"; - end Libgnat; - - ------------------------ - -- Library_Exists_For -- - ------------------------ - - function Library_Exists_For (Project : Project_Id) return Boolean is - begin - if not Projects.Table (Project).Library then - Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & - "for non library project"); - return False; - - else - declare - Lib_Dir : constant String := - Get_Name_String (Projects.Table (Project).Library_Dir); - Lib_Name : constant String := - Get_Name_String (Projects.Table (Project).Library_Name); - - begin - if Projects.Table (Project).Library_Kind = Static then - - -- Static libraries are named : lib.a - - return Is_Regular_File - (Lib_Dir & Directory_Separator & "lib" & - MLib.Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - -- Shared libraries are named : .dll - - return Is_Regular_File - (Lib_Dir & Directory_Separator & - MLib.Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - end; - end if; - end Library_Exists_For; - - --------------------------- - -- Library_File_Name_For -- - --------------------------- - - function Library_File_Name_For (Project : Project_Id) return Name_Id is - begin - if not Projects.Table (Project).Library then - Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & - "for non library project"); - return No_Name; - - else - declare - Lib_Name : constant String := - Get_Name_String - (Projects.Table (Project).Library_Name); - - begin - if Projects.Table (Project).Library_Kind = Static then - - -- Static libraries are named : lib.a - - Name_Len := 3; - Name_Buffer (1 .. Name_Len) := "lib"; - - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - -- Shared libraries are named : .dll - - Name_Len := 0; - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - - return Name_Find; - end; - end if; - end Library_File_Name_For; - - ---------------- - -- Object_Ext -- - ---------------- - - function Object_Ext return String is - begin - return "o"; - end Object_Ext; - - ---------------- - -- PIC_Option -- - ---------------- - - function PIC_Option return String is - begin - return ""; - end PIC_Option; - - ----------------------------------------------- - -- Standalone_Library_Auto_Init_Is_Supported -- - ----------------------------------------------- - - function Standalone_Library_Auto_Init_Is_Supported return Boolean is - begin - return False; - end Standalone_Library_Auto_Init_Is_Supported; - - --------------------------- - -- Support_For_Libraries -- - --------------------------- - - function Support_For_Libraries return Library_Support is - begin - return Full; - end Support_For_Libraries; - -end MLib.Tgt; diff --git a/gcc/ada/5wosinte.ads b/gcc/ada/5wosinte.ads deleted file mode 100644 index eec2e6ead98..00000000000 --- a/gcc/ada/5wosinte.ads +++ /dev/null @@ -1,451 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 a NT (native) version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with Interfaces.C.Strings; -with Unchecked_Conversion; - -package System.OS_Interface is -pragma Preelaborate; - - pragma Linker_Options ("-mthreads"); - - subtype int is Interfaces.C.int; - subtype long is Interfaces.C.long; - - ------------------- - -- General Types -- - ------------------- - - type DWORD is new Interfaces.C.unsigned_long; - type WORD is new Interfaces.C.unsigned_short; - - -- The LARGE_INTEGER type is actually a fixed point type - -- that only can represent integers. The reason for this is - -- easier conversion to Duration or other fixed point types. - -- (See Operations.Clock) - - type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0; - - subtype PSZ is Interfaces.C.Strings.chars_ptr; - subtype PCHAR is Interfaces.C.Strings.chars_ptr; - subtype PVOID is System.Address; - - Null_Void : constant PVOID := System.Null_Address; - - type PLONG is access all Interfaces.C.long; - type PDWORD is access all DWORD; - - type BOOL is new Boolean; - for BOOL'Size use Interfaces.C.unsigned_long'Size; - - ------------------------- - -- Handles for objects -- - ------------------------- - - type HANDLE is new Interfaces.C.long; - type PHANDLE is access all HANDLE; - - subtype Thread_Id is HANDLE; - - ----------- - -- Errno -- - ----------- - - NO_ERROR : constant := 0; - FUNC_ERR : constant := -1; - - ------------- - -- Signals -- - ------------- - - Max_Interrupt : constant := 31; - type Signal is new int range 0 .. Max_Interrupt; - for Signal'Size use int'Size; - - SIGINT : constant := 2; -- interrupt (Ctrl-C) - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGFPE : constant := 8; -- floating point exception - SIGSEGV : constant := 11; -- segmentation violation - SIGTERM : constant := 15; -- software termination signal from kill - SIGBREAK : constant := 21; -- break (Ctrl-Break) - SIGABRT : constant := 22; -- used by abort, replace SIGIOT in the future - - type sigset_t is private; - - type isr_address is access procedure (sig : int); - - function intr_attach (sig : int; handler : isr_address) return long; - pragma Import (C, intr_attach, "signal"); - - Intr_Attach_Reset : constant Boolean := True; - -- True if intr_attach is reset after an interrupt handler is called - - procedure kill (sig : Signal); - pragma Import (C, kill, "raise"); - - --------------------- - -- Time Management -- - --------------------- - - procedure Sleep (dwMilliseconds : DWORD); - pragma Import (Stdcall, Sleep, External_Name => "Sleep"); - - type SYSTEMTIME is record - wYear : WORD; - wMonth : WORD; - wDayOfWeek : WORD; - wDay : WORD; - wHour : WORD; - wMinute : WORD; - wSecond : WORD; - wMilliseconds : WORD; - end record; - - procedure GetSystemTime (pSystemTime : access SYSTEMTIME); - pragma Import (Stdcall, GetSystemTime, "GetSystemTime"); - - procedure GetSystemTimeAsFileTime (lpFileTime : access Long_Long_Integer); - pragma Import (Stdcall, GetSystemTimeAsFileTime, "GetSystemTimeAsFileTime"); - - function SetSystemTime (pSystemTime : access SYSTEMTIME) return BOOL; - pragma Import (Stdcall, SetSystemTime, "SetSystemTime"); - - function FileTimeToSystemTime - (lpFileTime : access Long_Long_Integer; - lpSystemTime : access SYSTEMTIME) return BOOL; - pragma Import (Stdcall, FileTimeToSystemTime, "FileTimeToSystemTime"); - - function SystemTimeToFileTime - (lpSystemTime : access SYSTEMTIME; - lpFileTime : access Long_Long_Integer) return BOOL; - pragma Import (Stdcall, SystemTimeToFileTime, "SystemTimeToFileTime"); - - function FileTimeToLocalFileTime - (lpFileTime : access Long_Long_Integer; - lpLocalFileTime : access Long_Long_Integer) return BOOL; - pragma Import (Stdcall, FileTimeToLocalFileTime, "FileTimeToLocalFileTime"); - - function LocalFileTimeToFileTime - (lpFileTime : access Long_Long_Integer; - lpLocalFileTime : access Long_Long_Integer) return BOOL; - pragma Import (Stdcall, LocalFileTimeToFileTime, "LocalFileTimeToFileTime"); - - function QueryPerformanceCounter - (lpPerformanceCount : access LARGE_INTEGER) return BOOL; - pragma Import - (Stdcall, QueryPerformanceCounter, "QueryPerformanceCounter"); - - function QueryPerformanceFrequency - (lpFrequency : access LARGE_INTEGER) return BOOL; - pragma Import - (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency"); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - procedure SwitchToThread; - pragma Import (Stdcall, SwitchToThread, "SwitchToThread"); - - ----------------------- - -- Critical sections -- - ----------------------- - - type CRITICAL_SECTION is private; - type PCRITICAL_SECTION is access all CRITICAL_SECTION; - - procedure InitializeCriticalSection (pCriticalSection : PCRITICAL_SECTION); - pragma Import - (Stdcall, InitializeCriticalSection, "InitializeCriticalSection"); - - procedure EnterCriticalSection (pCriticalSection : PCRITICAL_SECTION); - pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection"); - - procedure LeaveCriticalSection (pCriticalSection : PCRITICAL_SECTION); - pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection"); - - procedure DeleteCriticalSection (pCriticalSection : PCRITICAL_SECTION); - pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection"); - - ------------------------------------------------------------- - -- Thread Creation, Activation, Suspension And Termination -- - ------------------------------------------------------------- - - type PTHREAD_START_ROUTINE is access function - (pThreadParameter : PVOID) return DWORD; - pragma Convention (Stdcall, PTHREAD_START_ROUTINE); - - function To_PTHREAD_START_ROUTINE is new - Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE); - - type SECURITY_ATTRIBUTES is record - nLength : DWORD; - pSecurityDescriptor : PVOID; - bInheritHandle : BOOL; - end record; - - type PSECURITY_ATTRIBUTES is access all SECURITY_ATTRIBUTES; - - function CreateThread - (pThreadAttributes : PSECURITY_ATTRIBUTES; - dwStackSize : DWORD; - pStartAddress : PTHREAD_START_ROUTINE; - pParameter : PVOID; - dwCreationFlags : DWORD; - pThreadId : PDWORD) return HANDLE; - pragma Import (Stdcall, CreateThread, "CreateThread"); - - function BeginThreadEx - (pThreadAttributes : PSECURITY_ATTRIBUTES; - dwStackSize : DWORD; - pStartAddress : PTHREAD_START_ROUTINE; - pParameter : PVOID; - dwCreationFlags : DWORD; - pThreadId : PDWORD) return HANDLE; - pragma Import (C, BeginThreadEx, "_beginthreadex"); - - Debug_Process : constant := 16#00000001#; - Debug_Only_This_Process : constant := 16#00000002#; - Create_Suspended : constant := 16#00000004#; - Detached_Process : constant := 16#00000008#; - Create_New_Console : constant := 16#00000010#; - - Create_New_Process_Group : constant := 16#00000200#; - - Create_No_window : constant := 16#08000000#; - - Profile_User : constant := 16#10000000#; - Profile_Kernel : constant := 16#20000000#; - Profile_Server : constant := 16#40000000#; - - function GetExitCodeThread - (hThread : HANDLE; - pExitCode : PDWORD) return BOOL; - pragma Import (Stdcall, GetExitCodeThread, "GetExitCodeThread"); - - function ResumeThread (hThread : HANDLE) return DWORD; - pragma Import (Stdcall, ResumeThread, "ResumeThread"); - - function SuspendThread (hThread : HANDLE) return DWORD; - pragma Import (Stdcall, SuspendThread, "SuspendThread"); - - procedure ExitThread (dwExitCode : DWORD); - pragma Import (Stdcall, ExitThread, "ExitThread"); - - procedure EndThreadEx (dwExitCode : DWORD); - pragma Import (C, EndThreadEx, "_endthreadex"); - - function TerminateThread - (hThread : HANDLE; - dwExitCode : DWORD) return BOOL; - pragma Import (Stdcall, TerminateThread, "TerminateThread"); - - function GetCurrentThread return HANDLE; - pragma Import (Stdcall, GetCurrentThread, "GetCurrentThread"); - - function GetCurrentProcess return HANDLE; - pragma Import (Stdcall, GetCurrentProcess, "GetCurrentProcess"); - - function GetCurrentThreadId return DWORD; - pragma Import (Stdcall, GetCurrentThreadId, "GetCurrentThreadId"); - - function TlsAlloc return DWORD; - pragma Import (Stdcall, TlsAlloc, "TlsAlloc"); - - function TlsGetValue (dwTlsIndex : DWORD) return PVOID; - pragma Import (Stdcall, TlsGetValue, "TlsGetValue"); - - function TlsSetValue (dwTlsIndex : DWORD; pTlsValue : PVOID) return BOOL; - pragma Import (Stdcall, TlsSetValue, "TlsSetValue"); - - function TlsFree (dwTlsIndex : DWORD) return BOOL; - pragma Import (Stdcall, TlsFree, "TlsFree"); - - TLS_Nothing : constant := DWORD'Last; - - procedure ExitProcess (uExitCode : Interfaces.C.unsigned); - pragma Import (Stdcall, ExitProcess, "ExitProcess"); - - function WaitForSingleObject - (hHandle : HANDLE; - dwMilliseconds : DWORD) return DWORD; - pragma Import (Stdcall, WaitForSingleObject, "WaitForSingleObject"); - - function WaitForSingleObjectEx - (hHandle : HANDLE; - dwMilliseconds : DWORD; - fAlertable : BOOL) return DWORD; - pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx"); - - Wait_Infinite : constant := DWORD'Last; - WAIT_TIMEOUT : constant := 16#0000_0102#; - WAIT_FAILED : constant := 16#FFFF_FFFF#; - - ------------------------------------ - -- Semaphores, Events and Mutexes -- - ------------------------------------ - - function CloseHandle (hObject : HANDLE) return BOOL; - pragma Import (Stdcall, CloseHandle, "CloseHandle"); - - function CreateSemaphore - (pSemaphoreAttributes : PSECURITY_ATTRIBUTES; - lInitialCount : Interfaces.C.long; - lMaximumCount : Interfaces.C.long; - pName : PSZ) return HANDLE; - pragma Import (Stdcall, CreateSemaphore, "CreateSemaphoreA"); - - function OpenSemaphore - (dwDesiredAccess : DWORD; - bInheritHandle : BOOL; - pName : PSZ) return HANDLE; - pragma Import (Stdcall, OpenSemaphore, "OpenSemaphoreA"); - - function ReleaseSemaphore - (hSemaphore : HANDLE; - lReleaseCount : Interfaces.C.long; - pPreviousCount : PLONG) return BOOL; - pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore"); - - function CreateEvent - (pEventAttributes : PSECURITY_ATTRIBUTES; - bManualReset : BOOL; - bInitialState : BOOL; - pName : PSZ) return HANDLE; - pragma Import (Stdcall, CreateEvent, "CreateEventA"); - - function OpenEvent - (dwDesiredAccess : DWORD; - bInheritHandle : BOOL; - pName : PSZ) return HANDLE; - pragma Import (Stdcall, OpenEvent, "OpenEventA"); - - function SetEvent (hEvent : HANDLE) return BOOL; - pragma Import (Stdcall, SetEvent, "SetEvent"); - - function ResetEvent (hEvent : HANDLE) return BOOL; - pragma Import (Stdcall, ResetEvent, "ResetEvent"); - - function PulseEvent (hEvent : HANDLE) return BOOL; - pragma Import (Stdcall, PulseEvent, "PulseEvent"); - - function CreateMutex - (pMutexAttributes : PSECURITY_ATTRIBUTES; - bInitialOwner : BOOL; - pName : PSZ) return HANDLE; - pragma Import (Stdcall, CreateMutex, "CreateMutexA"); - - function OpenMutex - (dwDesiredAccess : DWORD; - bInheritHandle : BOOL; - pName : PSZ) return HANDLE; - pragma Import (Stdcall, OpenMutex, "OpenMutexA"); - - function ReleaseMutex (hMutex : HANDLE) return BOOL; - pragma Import (Stdcall, ReleaseMutex, "ReleaseMutex"); - - --------------------------------------------------- - -- Accessing properties of Threads and Processes -- - --------------------------------------------------- - - ----------------- - -- Priorities -- - ----------------- - - function SetThreadPriority - (hThread : HANDLE; - nPriority : Interfaces.C.int) return BOOL; - pragma Import (Stdcall, SetThreadPriority, "SetThreadPriority"); - - function GetThreadPriority (hThread : HANDLE) return Interfaces.C.int; - pragma Import (Stdcall, GetThreadPriority, "GetThreadPriority"); - - function SetPriorityClass - (hProcess : HANDLE; - dwPriorityClass : DWORD) return BOOL; - pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass"); - - procedure SetThreadPriorityBoost - (hThread : HANDLE; - DisablePriorityBoost : BOOL); - pragma Import (Stdcall, SetThreadPriorityBoost, "SetThreadPriorityBoost"); - - Normal_Priority_Class : constant := 16#00000020#; - Idle_Priority_Class : constant := 16#00000040#; - High_Priority_Class : constant := 16#00000080#; - Realtime_Priority_Class : constant := 16#00000100#; - - Thread_Priority_Idle : constant := -15; - Thread_Priority_Lowest : constant := -2; - Thread_Priority_Below_Normal : constant := -1; - Thread_Priority_Normal : constant := 0; - Thread_Priority_Above_Normal : constant := 1; - Thread_Priority_Highest : constant := 2; - Thread_Priority_Time_Critical : constant := 15; - Thread_Priority_Error_Return : constant := Interfaces.C.long'Last; - - function GetLastError return DWORD; - pragma Import (Stdcall, GetLastError, "GetLastError"); - -private - - type sigset_t is new Interfaces.C.unsigned_long; - - type CRITICAL_SECTION is record - DebugInfo : System.Address; - -- The following three fields control entering and - -- exiting the critical section for the resource - LockCount : Long_Integer; - RecursionCount : Long_Integer; - OwningThread : HANDLE; - LockSemaphore : HANDLE; - Reserved : DWORD; - end record; - -end System.OS_Interface; diff --git a/gcc/ada/5wosprim.adb b/gcc/ada/5wosprim.adb deleted file mode 100644 index 07a8ca79eab..00000000000 --- a/gcc/ada/5wosprim.adb +++ /dev/null @@ -1,286 +0,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 is the NT version of this package - -with Ada.Exceptions; -with Interfaces.C; - -package body System.OS_Primitives is - - --------------------------- - -- Win32 API Definitions -- - --------------------------- - - -- These definitions are copied from System.OS_Interface because we do not - -- want to depend on gnarl here. - - type DWORD is new Interfaces.C.unsigned_long; - - type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0; - - type BOOL is new Boolean; - for BOOL'Size use Interfaces.C.unsigned_long'Size; - - procedure GetSystemTimeAsFileTime (lpFileTime : access Long_Long_Integer); - pragma Import (Stdcall, GetSystemTimeAsFileTime, "GetSystemTimeAsFileTime"); - - function QueryPerformanceCounter - (lpPerformanceCount : access LARGE_INTEGER) return BOOL; - pragma Import - (Stdcall, QueryPerformanceCounter, "QueryPerformanceCounter"); - - function QueryPerformanceFrequency - (lpFrequency : access LARGE_INTEGER) return BOOL; - pragma Import - (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency"); - - procedure Sleep (dwMilliseconds : DWORD); - pragma Import (Stdcall, Sleep, External_Name => "Sleep"); - - ---------------------------------------- - -- Data for the high resolution clock -- - ---------------------------------------- - - -- Declare some pointers to access multi-word data above. This is needed - -- to workaround a limitation in the GNU/Linker auto-import feature used - -- to build the GNAT runtime DLLs. In fact the Clock and Monotonic_Clock - -- routines are inlined and they are using some multi-word variables. - -- GNU/Linker will fail to auto-import those variables when building - -- libgnarl.dll. The indirection level introduced here has no measurable - -- penalties. - -- - -- Note that access variables below must not be declared as constant - -- otherwise the compiler optimization will remove this indirect access. - - type DA is access all Duration; - -- Use to have indirect access to multi-word variables - - type LIA is access all LARGE_INTEGER; - -- Use to have indirect access to multi-word variables - - type LLIA is access all Long_Long_Integer; - -- Use to have indirect access to multi-word variables - - Tick_Frequency : aliased LARGE_INTEGER; - TFA : constant LIA := Tick_Frequency'Access; - -- Holds frequency of high-performance counter used by Clock - -- Windows NT uses a 1_193_182 Hz counter on PCs. - - Base_Ticks : aliased LARGE_INTEGER; - BTA : constant LIA := Base_Ticks'Access; - -- Holds the Tick count for the base time. - - Base_Monotonic_Ticks : aliased LARGE_INTEGER; - BMTA : constant LIA := Base_Monotonic_Ticks'Access; - -- Holds the Tick count for the base monotonic time - - Base_Clock : aliased Duration; - BCA : constant DA := Base_Clock'Access; - -- Holds the current clock for the standard clock's base time - - Base_Monotonic_Clock : aliased Duration; - BMCA : constant DA := Base_Monotonic_Clock'Access; - -- Holds the current clock for monotonic clock's base time - - Base_Time : aliased Long_Long_Integer; - BTiA : constant LLIA := Base_Time'Access; - -- Holds the base time used to check for system time change, used with - -- the standard clock. - - procedure Get_Base_Time; - -- Retrieve the base time and base ticks. These values will be used by - -- clock to compute the current time by adding to it a fraction of the - -- performance counter. This is for the implementation of a - -- high-resolution clock. Note that this routine does not change the base - -- monotonic values used by the monotonic clock. - - ----------- - -- Clock -- - ----------- - - -- This implementation of clock provides high resolution timer values - -- using QueryPerformanceCounter. This call return a 64 bits values (based - -- on the 8253 16 bits counter). This counter is updated every 1/1_193_182 - -- times per seconds. The call to QueryPerformanceCounter takes 6 - -- microsecs to complete. - - function Clock return Duration is - Max_Shift : constant Duration := 2.0; - Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7; - Current_Ticks : aliased LARGE_INTEGER; - Elap_Secs_Tick : Duration; - Elap_Secs_Sys : Duration; - Now : aliased Long_Long_Integer; - - begin - if not QueryPerformanceCounter (Current_Ticks'Access) then - return 0.0; - end if; - - GetSystemTimeAsFileTime (Now'Access); - - Elap_Secs_Sys := - Duration (Long_Long_Float (abs (Now - BTiA.all)) / - Hundreds_Nano_In_Sec); - - Elap_Secs_Tick := - Duration (Long_Long_Float (Current_Ticks - BTA.all) / - Long_Long_Float (TFA.all)); - - -- If we have a shift of more than Max_Shift seconds we resynchonize the - -- Clock. This is probably due to a manual Clock adjustment, an DST - -- adjustment or an NTP synchronisation. And we want to adjust the - -- time for this system (non-monotonic) clock. - - if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then - Get_Base_Time; - - Elap_Secs_Tick := - Duration (Long_Long_Float (Current_Ticks - BTA.all) / - Long_Long_Float (TFA.all)); - end if; - - return BCA.all + Elap_Secs_Tick; - end Clock; - - ------------------- - -- Get_Base_Time -- - ------------------- - - procedure Get_Base_Time is - -- The resolution for GetSystemTime is 1 millisecond. - - -- The time to get both base times should take less than 1 millisecond. - -- Therefore, the elapsed time reported by GetSystemTime between both - -- actions should be null. - - Max_Elapsed : constant := 0; - - Test_Now : aliased Long_Long_Integer; - - epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch - system_time_ns : constant := 100; -- 100 ns per tick - Sec_Unit : constant := 10#1#E9; - - begin - -- Here we must be sure that both of these calls are done in a short - -- amount of time. Both are base time and should in theory be taken - -- at the very same time. - - loop - GetSystemTimeAsFileTime (Base_Time'Access); - - if not QueryPerformanceCounter (Base_Ticks'Access) then - pragma Assert - (Standard.False, - "Could not query high performance counter in Clock"); - null; - end if; - - GetSystemTimeAsFileTime (Test_Now'Access); - - exit when Test_Now - Base_Time = Max_Elapsed; - end loop; - - Base_Clock := Duration - (Long_Long_Float ((Base_Time - epoch_1970) * system_time_ns) / - Long_Long_Float (Sec_Unit)); - end Get_Base_Time; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration is - Current_Ticks : aliased LARGE_INTEGER; - Elap_Secs_Tick : Duration; - begin - if not QueryPerformanceCounter (Current_Ticks'Access) then - return 0.0; - end if; - - Elap_Secs_Tick := - Duration (Long_Long_Float (Current_Ticks - BMTA.all) / - Long_Long_Float (TFA.all)); - - return BMCA.all + Elap_Secs_Tick; - end Monotonic_Clock; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay (Time : Duration; Mode : Integer) is - Rel_Time : Duration; - Abs_Time : Duration; - Check_Time : Duration := Monotonic_Clock; - - 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 - Sleep (DWORD (Rel_Time * 1000.0)); - Check_Time := Monotonic_Clock; - - exit when Abs_Time <= Check_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - --- Package elaboration, get starting time as base - -begin - if not QueryPerformanceFrequency (Tick_Frequency'Access) then - Ada.Exceptions.Raise_Exception - (Program_Error'Identity, - "cannot get high performance counter frequency"); - end if; - - Get_Base_Time; - - -- Keep base clock and ticks for the monotonic clock. These values should - -- never be changed to ensure proper behavior of the monotonic clock. - - Base_Monotonic_Clock := Base_Clock; - Base_Monotonic_Ticks := Base_Ticks; -end System.OS_Primitives; diff --git a/gcc/ada/5wsystem.ads b/gcc/ada/5wsystem.ads deleted file mode 100644 index 2a7496a9843..00000000000 --- a/gcc/ada/5wsystem.ads +++ /dev/null @@ -1,208 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (NT Version) -- --- -- --- 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 := 0.01; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - 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 := False; - 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; - - --------------------------- - -- Underlying Priorities -- - --------------------------- - - -- Important note: this section of the file must come AFTER the - -- definition of the system implementation parameters to ensure - -- that the value of these parameters is available for analysis - -- of the declarations here (using Rtsfind at compile time). - - -- The underlying priorities table provides a generalized mechanism - -- for mapping from Ada priorities to system priorities. In some - -- cases a 1-1 mapping is not the convenient or optimal choice. - - type Priorities_Mapping is array (Any_Priority) of Integer; - pragma Suppress_Initialization (Priorities_Mapping); - -- Suppress initialization in case gnat.adc specifies Normalize_Scalars - - -- On NT, the default mapping preserves the standard 31 priorities - -- of the Ada model, but maps them using compression onto the 7 - -- priority levels available in NT. - - -- To replace the default values of the Underlying_Priorities mapping, - -- copy this source file into your build directory, edit the file to - -- reflect your desired behavior, and recompile with the command: - - -- $ gcc -c -O3 -gnatpgn system.ads - - -- then recompile the run-time parts that depend on this package: - - -- $ gnatmake -a -gnatn -O3 - - -- then force rebuilding your application if you need different options: - - -- $ gnatmake -f - - Underlying_Priorities : constant Priorities_Mapping := - - (Priority'First .. 1 => -15, - - 2 .. Default_Priority - 2 => -2, - - Default_Priority - 1 => -1, - - Default_Priority => 0, - - Default_Priority + 1 .. 19 => 1, - - 20 .. Priority'Last => 2, - - Interrupt_Priority => 15); - - pragma Linker_Options ("-Wl,--stack=0x2000000"); - -- This is used to change the default stack (32 MB) size for non tasking - -- programs. We change this value for GNAT on Windows here because the - -- binutils on this platform have switched to a too low value for Ada - -- programs. Note that we also set the stack size for tasking programs in - -- System.Task_Primitives.Operations. - -end System; diff --git a/gcc/ada/5wtaprop.adb b/gcc/ada/5wtaprop.adb deleted file mode 100644 index 1e24de0c6ec..00000000000 --- a/gcc/ada/5wtaprop.adb +++ /dev/null @@ -1,1106 +0,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 . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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 a NT (native) version of this package - --- This package contains all the GNULL primitives that interface directly --- with the underlying OS. - -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.Tasking.Debug; --- used for Known_Tasks - -with Interfaces.C; --- used for int --- size_t - -with Interfaces.C.Strings; --- used for Null_Ptr - -with System.OS_Interface; --- used for various type, constant, and operations - -with System.Parameters; --- used for Size_Type - -with System.Tasking; --- used for Ada_Task_Control_Block --- Task_ID - -with System.Soft_Links; --- used for Defer/Undefer_Abort --- to initialize TSD for a C thread, in function Self - --- Note that we do not use System.Tasking.Initialization directly since --- this is a higher level package that we shouldn't depend on. For example --- when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Initialization - -with System.OS_Primitives; --- used for Delay_Modes - -with System.Task_Info; --- used for Unspecified_Task_Info - -with Unchecked_Deallocation; - -package body System.Task_Primitives.Operations is - - use System.Tasking.Debug; - use System.Tasking; - use Interfaces.C; - use Interfaces.C.Strings; - use System.OS_Interface; - use System.Parameters; - use System.OS_Primitives; - - pragma Link_With ("-Xlinker --stack=0x800000,0x1000"); - -- Change the stack size (8 MB) for tasking programs on Windows. This - -- permit to have more than 30 tasks running at the same time. Note that - -- we set the stack size for non tasking programs on System unit. - - package SSL renames System.Soft_Links; - - ---------------- - -- Local Data -- - ---------------- - - Environment_Task_ID : Task_ID; - -- A variable to hold Task_ID for the environment task. - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - - Time_Slice_Val : Integer; - pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - - Dispatching_Policy : Character; - pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - - FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; - -- Indicates whether FIFO_Within_Priorities is set. - - Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads). - - ------------------------------------ - -- The thread local storage index -- - ------------------------------------ - - TlsIndex : DWORD; - pragma Export (Ada, TlsIndex); - -- To ensure that this variable won't be local to this package, since - -- in some cases, inlining forces this variable to be global anyway. - - -------------------- - -- Local Packages -- - -------------------- - - package Specific is - - function Is_Valid_Task return Boolean; - pragma Inline (Is_Valid_Task); - -- Does executing thread have a TCB? - - procedure Set (Self_Id : Task_ID); - pragma Inline (Set); - -- Set the self id for the current task. - - end Specific; - - package body Specific is - - function Is_Valid_Task return Boolean is - begin - return TlsGetValue (TlsIndex) /= System.Null_Address; - end Is_Valid_Task; - - procedure Set (Self_Id : Task_ID) is - Succeeded : BOOL; - begin - Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id)); - pragma Assert (Succeeded = True); - end Set; - - end Specific; - - --------------------------------- - -- Support for foreign threads -- - --------------------------------- - - function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; - -- Allocate and Initialize a new ATCB for the current Thread. - - function Register_Foreign_Thread - (Thread : Thread_Id) return Task_ID is separate; - - ---------------------------------- - -- Condition Variable Functions -- - ---------------------------------- - - procedure Initialize_Cond (Cond : access Condition_Variable); - -- Initialize given condition variable Cond - - procedure Finalize_Cond (Cond : access Condition_Variable); - -- Finalize given condition variable Cond. - - procedure Cond_Signal (Cond : access Condition_Variable); - -- Signal condition variable Cond - - procedure Cond_Wait - (Cond : access Condition_Variable; - L : access RTS_Lock); - -- Wait on conditional variable Cond, using lock L - - procedure Cond_Timed_Wait - (Cond : access Condition_Variable; - L : access RTS_Lock; - Rel_Time : Duration; - Timed_Out : out Boolean; - Status : out Integer); - -- Do timed wait on condition variable Cond using lock L. The duration - -- of the timed wait is given by Rel_Time. When the condition is - -- signalled, Timed_Out shows whether or not a time out occurred. - -- Status is only valid if Timed_Out is False, in which case it - -- shows whether Cond_Timed_Wait completed successfully. - - --------------------- - -- Initialize_Cond -- - --------------------- - - procedure Initialize_Cond (Cond : access Condition_Variable) is - hEvent : HANDLE; - - begin - hEvent := CreateEvent (null, True, False, Null_Ptr); - pragma Assert (hEvent /= 0); - Cond.all := Condition_Variable (hEvent); - end Initialize_Cond; - - ------------------- - -- Finalize_Cond -- - ------------------- - - -- No such problem here, DosCloseEventSem has been derived. - -- What does such refer to in above comment??? - - procedure Finalize_Cond (Cond : access Condition_Variable) is - Result : BOOL; - begin - Result := CloseHandle (HANDLE (Cond.all)); - pragma Assert (Result = True); - end Finalize_Cond; - - ----------------- - -- Cond_Signal -- - ----------------- - - procedure Cond_Signal (Cond : access Condition_Variable) is - Result : BOOL; - begin - Result := SetEvent (HANDLE (Cond.all)); - pragma Assert (Result = True); - end Cond_Signal; - - --------------- - -- Cond_Wait -- - --------------- - - -- Pre-assertion: Cond is posted - -- L is locked. - - -- Post-assertion: Cond is posted - -- L is locked. - - procedure Cond_Wait - (Cond : access Condition_Variable; - L : access RTS_Lock) - is - Result : DWORD; - Result_Bool : BOOL; - - begin - -- Must reset Cond BEFORE L is unlocked. - - Result_Bool := ResetEvent (HANDLE (Cond.all)); - pragma Assert (Result_Bool = True); - Unlock (L); - - -- No problem if we are interrupted here: if the condition is signaled, - -- WaitForSingleObject will simply not block - - Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite); - pragma Assert (Result = 0); - - Write_Lock (L); - end Cond_Wait; - - --------------------- - -- Cond_Timed_Wait -- - --------------------- - - -- Pre-assertion: Cond is posted - -- L is locked. - - -- Post-assertion: Cond is posted - -- L is locked. - - procedure Cond_Timed_Wait - (Cond : access Condition_Variable; - L : access RTS_Lock; - Rel_Time : Duration; - Timed_Out : out Boolean; - Status : out Integer) - is - Time_Out_Max : constant DWORD := 16#FFFF0000#; - -- NT 4 cannot handle timeout values that are too large, - -- e.g. DWORD'Last - 1 - - Time_Out : DWORD; - Result : BOOL; - Wait_Result : DWORD; - - begin - -- Must reset Cond BEFORE L is unlocked. - - Result := ResetEvent (HANDLE (Cond.all)); - pragma Assert (Result = True); - Unlock (L); - - -- No problem if we are interrupted here: if the condition is signaled, - -- WaitForSingleObject will simply not block - - if Rel_Time <= 0.0 then - Timed_Out := True; - Wait_Result := 0; - - else - if Rel_Time >= Duration (Time_Out_Max) / 1000 then - Time_Out := Time_Out_Max; - else - Time_Out := DWORD (Rel_Time * 1000); - end if; - - Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out); - - if Wait_Result = WAIT_TIMEOUT then - Timed_Out := True; - Wait_Result := 0; - else - Timed_Out := False; - end if; - end if; - - Write_Lock (L); - - -- Ensure post-condition - - if Timed_Out then - Result := SetEvent (HANDLE (Cond.all)); - pragma Assert (Result = True); - end if; - - Status := Integer (Wait_Result); - end Cond_Timed_Wait; - - ------------------ - -- Stack_Guard -- - ------------------ - - -- The underlying thread system sets a guard page at the - -- bottom of a thread stack, so nothing is needed. - -- ??? Check the comment above - - procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is - pragma Warnings (Off, T); - pragma Warnings (Off, On); - - begin - null; - end Stack_Guard; - - -------------------- - -- Get_Thread_Id -- - -------------------- - - function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_ID is - Self_Id : constant Task_ID := To_Task_ID (TlsGetValue (TlsIndex)); - begin - if Self_Id = null then - return Register_Foreign_Thread (GetCurrentThread); - else - return Self_Id; - end if; - end Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Intialize_TCB and the Storage_Error is handled. - -- Other mutexes (such as RTS_Lock, Memory_Lock...) used in - -- the RTS is initialized before any status change of RTS. - -- Therefore raising Storage_Error in the following routines - -- should be able to be handled safely. - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : access Lock) - is - begin - InitializeCriticalSection (L.Mutex'Access); - L.Owner_Priority := 0; - L.Priority := Prio; - end Initialize_Lock; - - procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is - pragma Unreferenced (Level); - - begin - InitializeCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : access Lock) is - begin - DeleteCriticalSection (L.Mutex'Access); - end Finalize_Lock; - - procedure Finalize_Lock (L : access RTS_Lock) is - begin - DeleteCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - begin - L.Owner_Priority := Get_Priority (Self); - - if L.Priority < L.Owner_Priority then - Ceiling_Violation := True; - return; - end if; - - EnterCriticalSection (L.Mutex'Access); - - Ceiling_Violation := False; - end Write_Lock; - - procedure Write_Lock - (L : access RTS_Lock; - Global_Lock : Boolean := False) - is - begin - if not Single_Lock or else Global_Lock then - EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); - end if; - end Write_Lock; - - procedure Write_Lock (T : Task_ID) is - begin - if not Single_Lock then - EnterCriticalSection - (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access); - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - begin - Write_Lock (L, Ceiling_Violation); - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : access Lock) is - begin - LeaveCriticalSection (L.Mutex'Access); - end Unlock; - - procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is - begin - if not Single_Lock or else Global_Lock then - LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); - end if; - end Unlock; - - procedure Unlock (T : Task_ID) is - begin - if not Single_Lock then - LeaveCriticalSection - (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access); - end if; - end Unlock; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : Task_ID; - Reason : System.Tasking.Task_States) - is - pragma Unreferenced (Reason); - - begin - pragma Assert (Self_ID = Self); - - if Single_Lock then - Cond_Wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; - - if Self_ID.Deferral_Level = 0 - and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - then - Unlock (Self_ID); - raise Standard'Abort_Signal; - end if; - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - -- This is for use within the run-time system, so abort is - -- assumed to be already deferred, and the caller should be - -- holding its own ATCB lock. - - procedure Timed_Sleep - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : System.Tasking.Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Unreferenced (Reason); - Check_Time : Duration := Monotonic_Clock; - Rel_Time : Duration; - Abs_Time : Duration; - Result : Integer; - - Local_Timedout : Boolean; - - begin - Timedout := True; - Yielded := False; - - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; - - if Single_Lock then - Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, Rel_Time, Local_Timedout, Result); - else - Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result); - end if; - - Check_Time := Monotonic_Clock; - exit when Abs_Time <= Check_Time; - - if not Local_Timedout then - - -- Somebody may have called Wakeup for us - - Timedout := False; - exit; - end if; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes) - is - Check_Time : Duration := Monotonic_Clock; - Rel_Time : Duration; - Abs_Time : Duration; - Result : Integer; - Timedout : Boolean; - - begin - -- Only the little window between deferring abort and - -- locking Self_ID is the reason we need to - -- check for pending abort and priority change below! - - SSL.Abort_Defer.all; - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - - 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 - Self_ID.Common.State := Delay_Sleep; - - loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - if Single_Lock then - Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, Rel_Time, Timedout, Result); - else - Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result); - end if; - - Check_Time := Monotonic_Clock; - exit when Abs_Time <= Check_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - - Self_ID.Common.State := Runnable; - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - Yield; - SSL.Abort_Undefer.all; - end Timed_Delay; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is - pragma Unreferenced (Reason); - - begin - Cond_Signal (T.Common.LL.CV'Access); - end Wakeup; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - begin - if Do_Yield then - Sleep (0); - end if; - end Yield; - - ------------------ - -- Set_Priority -- - ------------------ - - type Prio_Array_Type is array (System.Any_Priority) of Integer; - pragma Atomic_Components (Prio_Array_Type); - - Prio_Array : Prio_Array_Type; - -- Global array containing the id of the currently running task for - -- each priority. - -- - -- Note: we assume that we are on a single processor with run-til-blocked - -- scheduling. - - procedure Set_Priority - (T : Task_ID; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) - is - Res : BOOL; - Array_Item : Integer; - - begin - Res := SetThreadPriority - (T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio))); - pragma Assert (Res = True); - - if FIFO_Within_Priorities then - - -- Annex D requirement [RM D.2.2 par. 9]: - -- If the task drops its priority due to the loss of inherited - -- priority, it is added at the head of the ready queue for its - -- new active priority. - - if Loss_Of_Inheritance - and then Prio < T.Common.Current_Priority - then - Array_Item := Prio_Array (T.Common.Base_Priority) + 1; - Prio_Array (T.Common.Base_Priority) := Array_Item; - - loop - -- Let some processes a chance to arrive - - Yield; - - -- Then wait for our turn to proceed - - exit when Array_Item = Prio_Array (T.Common.Base_Priority) - or else Prio_Array (T.Common.Base_Priority) = 1; - end loop; - - Prio_Array (T.Common.Base_Priority) := - Prio_Array (T.Common.Base_Priority) - 1; - end if; - end if; - - T.Common.Current_Priority := Prio; - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_ID) return System.Any_Priority is - begin - return T.Common.Current_Priority; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - -- There were two paths were we needed to call Enter_Task : - -- 1) from System.Task_Primitives.Operations.Initialize - -- 2) from System.Tasking.Stages.Task_Wrapper - -- - -- The thread initialisation has to be done only for the first case. - -- - -- This is because the GetCurrentThread NT call does not return the - -- real thread handler but only a "pseudo" one. It is not possible to - -- release the thread handle and free the system ressources from this - -- "pseudo" handle. So we really want to keep the real thread handle - -- set in System.Task_Primitives.Operations.Create_Task during the - -- thread creation. - - procedure Enter_Task (Self_ID : Task_ID) is - procedure Init_Float; - pragma Import (C, Init_Float, "__gnat_init_float"); - -- Properly initializes the FPU for x86 systems. - - begin - Specific.Set (Self_ID); - Init_Float; - - Self_ID.Common.LL.Thread_Id := GetCurrentThreadId; - - Lock_RTS; - - for J in Known_Tasks'Range loop - if Known_Tasks (J) = null then - Known_Tasks (J) := Self_ID; - Self_ID.Known_Tasks_Index := J; - exit; - end if; - end loop; - - Unlock_RTS; - end Enter_Task; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_ID is - begin - if Is_Valid_Task then - return Self; - else - return Register_Foreign_Thread (GetCurrentThread); - end if; - end Register_Foreign_Thread; - - -------------------- - -- Initialize_TCB -- - -------------------- - - procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is - begin - -- Initialize thread ID to 0, this is needed to detect threads that - -- are not yet activated. - - Self_ID.Common.LL.Thread := 0; - - Initialize_Cond (Self_ID.Common.LL.CV'Access); - - if not Single_Lock then - Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); - end if; - - Succeeded := True; - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_ID; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - hTask : HANDLE; - TaskId : aliased DWORD; - pTaskParameter : System.OS_Interface.PVOID; - dwStackSize : DWORD; - Result : DWORD; - Entry_Point : PTHREAD_START_ROUTINE; - - begin - pTaskParameter := To_Address (T); - - if Stack_Size = Unspecified_Size then - dwStackSize := DWORD (Default_Stack_Size); - - elsif Stack_Size < Minimum_Stack_Size then - dwStackSize := DWORD (Minimum_Stack_Size); - - else - dwStackSize := DWORD (Stack_Size); - end if; - - Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper); - - hTask := CreateThread - (null, - dwStackSize, - Entry_Point, - pTaskParameter, - DWORD (Create_Suspended), - TaskId'Unchecked_Access); - - -- Step 1: Create the thread in blocked mode - - if hTask = 0 then - raise Storage_Error; - end if; - - -- Step 2: set its TCB - - T.Common.LL.Thread := hTask; - - -- Step 3: set its priority (child has inherited priority from parent) - - Set_Priority (T, Priority); - - if Time_Slice_Val = 0 or else FIFO_Within_Priorities then - -- Here we need Annex E semantics so we disable the NT priority - -- boost. A priority boost is temporarily given by the system to a - -- thread when it is taken out of a wait state. - - SetThreadPriorityBoost (hTask, DisablePriorityBoost => True); - end if; - - -- Step 4: Now, start it for good: - - Result := ResumeThread (hTask); - pragma Assert (Result = 1); - - Succeeded := Result = 1; - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_ID) is - Self_ID : Task_ID := T; - Result : DWORD; - Succeeded : BOOL; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); - - begin - if not Single_Lock then - Finalize_Lock (T.Common.LL.L'Access); - end if; - - Finalize_Cond (T.Common.LL.CV'Access); - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - if Self_ID.Common.LL.Thread /= 0 then - - -- This task has been activated. Wait for the thread to terminate - -- then close it. this is needed to release system ressources. - - Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite); - pragma Assert (Result /= WAIT_FAILED); - Succeeded := CloseHandle (T.Common.LL.Thread); - pragma Assert (Succeeded = True); - end if; - - Free (Self_ID); - - if Is_Self then - Specific.Set (null); - end if; - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - procedure Exit_Task is - begin - Specific.Set (null); - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_ID) is - pragma Unreferenced (T); - begin - null; - end Abort_Task; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_ID is - begin - return Environment_Task_ID; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_ID) is - Discard : BOOL; - pragma Unreferenced (Discard); - - begin - Environment_Task_ID := Environment_Task; - - if Time_Slice_Val = 0 or else FIFO_Within_Priorities then - - -- Here we need Annex E semantics, switch the current process to the - -- High_Priority_Class. - - Discard := - OS_Interface.SetPriorityClass - (GetCurrentProcess, High_Priority_Class); - - -- ??? In theory it should be possible to use the priority class - -- Realtime_Prioriry_Class but we suspect a bug in the NT scheduler - -- which prevents (in some obscure cases) a thread to get on top of - -- the running queue by another thread of lower priority. For - -- example cxd8002 ACATS test freeze. - end if; - - TlsIndex := TlsAlloc; - - -- Initialize the lock used to synchronize chain of all ATCBs. - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - - Environment_Task.Common.LL.Thread := GetCurrentThread; - Enter_Task (Environment_Task); - end Initialize; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration - renames System.OS_Primitives.Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - begin - return 0.000_001; -- 1 micro-second - end RT_Resolution; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy versions. The only currently working versions is for solaris - -- (native). - - function Check_Exit (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - - begin - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - - begin - return True; - end Check_No_Locks; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) return Boolean - is - begin - if T.Common.LL.Thread /= Thread_Self then - return SuspendThread (T.Common.LL.Thread) = NO_ERROR; - else - return True; - end if; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) return Boolean - is - begin - if T.Common.LL.Thread /= Thread_Self then - return ResumeThread (T.Common.LL.Thread) = NO_ERROR; - else - return True; - end if; - end Resume_Task; - -end System.Task_Primitives.Operations; diff --git a/gcc/ada/5wtaspri.ads b/gcc/ada/5wtaspri.ads deleted file mode 100644 index 01cde2c6910..00000000000 --- a/gcc/ada/5wtaspri.ads +++ /dev/null @@ -1,97 +0,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-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 a NT (native) version of this package. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with System.OS_Interface; --- used for pthread_mutex_t --- pthread_cond_t --- pthread_t - -package System.Task_Primitives is - - type Lock is limited private; - -- Should be used for implementation of protected objects. - - type RTS_Lock is limited private; - -- Should be used inside the runtime system. - -- The difference between Lock and the RTS_Lock is that the later - -- one serves only as a semaphore so that do not check for - -- ceiling violations. - - type Task_Body_Access is access procedure; - -- Pointer to the task body's entry point (or possibly a wrapper - -- declared local to the GNARL). - - type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task - -- basis. A component of this type is guaranteed to be included - -- in the Ada_Task_Control_Block. - -private - - type Lock is record - Mutex : aliased System.OS_Interface.CRITICAL_SECTION; - Priority : Integer; - Owner_Priority : Integer; - end record; - - type Condition_Variable is new System.OS_Interface.HANDLE; - - type RTS_Lock is new System.OS_Interface.CRITICAL_SECTION; - - type Private_Data is record - Thread : aliased System.OS_Interface.HANDLE; - 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. - - Thread_Id : aliased System.OS_Interface.DWORD; - -- The purpose of this field is to provide a better tasking support - -- in gdb. - - CV : aliased Condition_Variable; - -- Condition Variable used to implement Sleep/Wakeup - - L : aliased RTS_Lock; - -- Protection for all components is lock L - end record; - -end System.Task_Primitives; diff --git a/gcc/ada/5xparame.ads b/gcc/ada/5xparame.ads deleted file mode 100644 index d1d48188176..00000000000 --- a/gcc/ada/5xparame.ads +++ /dev/null @@ -1,203 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2003 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 version for restricted tasking. - --- Blank line intentional so that it lines up exactly with default. - --- This package defines some system dependent parameters for GNAT. These --- are values that are referenced by the runtime library and are therefore --- relevant to the target machine. - --- The parameters whose value is defined in the spec are not generally --- expected to be changed. If they are changed, it will be necessary to --- recompile the run-time library. - --- The parameters which are defined by functions can be changed by modifying --- the body of System.Parameters in file s-parame.adb. A change to this body --- requires only rebinding and relinking of the application. - --- Note: do not introduce any pragma Inline statements into this unit, since --- otherwise the relinking and rebinding capability would be deactivated. - -package System.Parameters is -pragma Pure (Parameters); - - --------------------------------------- - -- Task And Stack Allocation Control -- - --------------------------------------- - - type Task_Storage_Size is new Integer; - -- Type used in tasking units for task storage size - - type Size_Type is new Task_Storage_Size; - -- Type used to provide task storage size to runtime - - Unspecified_Size : constant Size_Type := Size_Type'First; - -- Value used to indicate that no size type is set - - subtype Ratio is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Ratio : constant Ratio := Dynamic; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - - function Default_Stack_Size return Size_Type; - -- Default task stack size used if none is specified - - function Minimum_Stack_Size return Size_Type; - -- Minimum task stack size permitted - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type; - -- Given the storage size stored in the TCB, return the Storage_Size - -- value required by the RM for the Storage_Size attribute. The - -- required adjustment is as follows: - -- - -- when Size = Unspecified_Size, return Default_Stack_Size - -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size - -- otherwise return given Size - - Default_Env_Stack_Size : constant Size_Type := 8_192_000; - -- Assumed size of the environment task, if no other information - -- is available. This value is used when stack checking is - -- enabled and no GNAT_STACK_LIMIT environment variable is set. - - Stack_Grows_Down : constant Boolean := True; - -- This constant indicates whether the stack grows up (False) or - -- down (True) in memory as functions are called. It is used for - -- proper implementation of the stack overflow check. - - ---------------------------------------------- - -- Characteristics of types in Interfaces.C -- - ---------------------------------------------- - - long_bits : constant := 32; - -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this is not true - -- of all targets. For example, in OpenVMS long /= Long_Integer. - - ---------------------------------------------- - -- Behavior of Pragma Finalize_Storage_Only -- - ---------------------------------------------- - - -- Garbage_Collected is a Boolean constant whose value indicates the - -- effect of the pragma Finalize_Storage_Entry on a controlled type. - - -- Garbage_Collected = False - - -- The system releases all storage on program termination only, - -- but not other garbage collection occurs, so finalization calls - -- are ommitted only for outer level onjects can be omitted if - -- pragma Finalize_Storage_Only is used. - - -- Garbage_Collected = True - - -- The system provides full garbage collection, so it is never - -- necessary to release storage for controlled objects for which - -- a pragma Finalize_Storage_Only is used. - - Garbage_Collected : constant Boolean := False; - -- The storage mode for this system (release on program exit) - - --------------------- - -- Tasking Profile -- - --------------------- - - -- In the following sections, constant parameters are defined to - -- allow some optimizations and fine tuning within the tasking run time - -- based on restrictions on the tasking features. - - ---------------------- - -- Locking Strategy -- - ---------------------- - - Single_Lock : constant Boolean := True; - -- Indicates whether a single lock should be used within the tasking - -- run-time to protect internal structures. If True, a single lock - -- will be used, meaning less locking/unlocking operations, but also - -- more global contention. In general, Single_Lock should be set to - -- True on single processor machines, and to False to multi-processor - -- systems, but this can vary from application to application and also - -- depends on the scheduling policy. - - ------------------- - -- Task Abortion -- - ------------------- - - No_Abort : constant Boolean := True; - -- This constant indicates whether abort statements and asynchronous - -- transfer of control (ATC) are disallowed. If set to True, it is - -- assumed that neither construct is used, and the run time does not - -- need to defer/undefer abort and check for pending actions at - -- completion points. A value of True for No_Abort corresponds to: - -- pragma Restrictions (No_Abort_Statements); - -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - - ---------------------- - -- Dynamic Priority -- - ---------------------- - - Dynamic_Priority_Support : constant Boolean := False; - -- This constant indicates whether dynamic changes of task priorities - -- are allowed (True means normal RM mode in which such changes are - -- allowed). In particular, if this is False, then we do not need to - -- poll for pending base priority changes at every abort completion - -- point. A value of False for Dynamic_Priority_Support corresponds - -- to pragma Restrictions (No_Dynamic_Priorities); - - --------------------- - -- Task Attributes -- - --------------------- - - Default_Attribute_Count : constant := 4; - -- Number of pre-allocated Address-sized task attributes stored in the - -- task control block. - - -------------------- - -- Runtime Traces -- - -------------------- - - Runtime_Traces : constant Boolean := False; - -- This constant indicates whether the runtime outputs traces to a - -- predefined output or not (True means that traces are output). - -- See System.Traces for more details. - -end System.Parameters; diff --git a/gcc/ada/5xsystem.ads b/gcc/ada/5xsystem.ads deleted file mode 100644 index 3ba5e692195..00000000000 --- a/gcc/ada/5xsystem.ads +++ /dev/null @@ -1,236 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (OpenVMS GCC_ZCX DEC Threads Version) -- --- -- --- Copyright (C) 2002-2004 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 := 0.01; - - -- Storage-related Declarations - - type Address is private; - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -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 := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := False; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - Functions_Return_By_DSP : constant Boolean := False; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - OpenVMS : constant Boolean := True; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := True; - Stack_Check_Probes : constant Boolean := True; - 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 := False; - ZCX_By_Default : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; - 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; - - -------------------------- - -- Underlying Priorities -- - --------------------------- - - -- Important note: this section of the file must come AFTER the - -- definition of the system implementation parameters to ensure - -- that the value of these parameters is available for analysis - -- of the declarations here (using Rtsfind at compile time). - - -- The underlying priorities table provides a generalized mechanism - -- for mapping from Ada priorities to system priorities. In some - -- cases a 1-1 mapping is not the convenient or optimal choice. - - -- For DEC Threads OpenVMS, we use the full range of 31 priorities - -- in the Ada model, but map them by compression onto the more limited - -- range of priorities available in OpenVMS. - - -- To replace the default values of the Underlying_Priorities mapping, - -- copy this source file into your build directory, edit the file to - -- reflect your desired behavior, and recompile with the command: - - -- $ gcc -c -O3 -gnatpgn system.ads - - -- then recompile the run-time parts that depend on this package: - - -- $ gnatmake -a -gnatn -O3 - - -- then force rebuilding your application if you need different options: - - -- $ gnatmake -f - - type Priorities_Mapping is array (Any_Priority) of Integer; - pragma Suppress_Initialization (Priorities_Mapping); - -- Suppress initialization in case gnat.adc specifies Normalize_Scalars - - Underlying_Priorities : constant Priorities_Mapping := - - (Priority'First => 16, - - 1 => 17, - 2 => 18, - 3 => 18, - 4 => 18, - 5 => 18, - 6 => 19, - 7 => 19, - 8 => 19, - 9 => 20, - 10 => 20, - 11 => 21, - 12 => 21, - 13 => 22, - 14 => 23, - - Default_Priority => 24, - - 16 => 25, - 17 => 25, - 18 => 25, - 19 => 26, - 20 => 26, - 21 => 26, - 22 => 27, - 23 => 27, - 24 => 27, - 25 => 28, - 26 => 28, - 27 => 29, - 28 => 29, - 29 => 30, - - Priority'Last => 30, - - Interrupt_Priority => 31); - - ---------------------------- - -- Special VMS Interfaces -- - ---------------------------- - - procedure Lib_Stop (I : in Integer); - pragma Interface (C, Lib_Stop); - pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); - -- Interface to VMS condition handling. Used by RTSfind and pragma - -- {Import,Export}_Exception. Put here because this is the only - -- VMS specific package that doesn't drag in tasking. - -end System; diff --git a/gcc/ada/5xvxwork.ads b/gcc/ada/5xvxwork.ads deleted file mode 100644 index 4183ee6bb1f..00000000000 --- a/gcc/ada/5xvxwork.ads +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . V X W O R K S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-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 the Xscale VxWorks version of this package. - -package System.VxWorks is - pragma Preelaborate (System.VxWorks); - - -- Floating point context record. Xscale version - - -- There is no floating point unit on Xscale. The record definition - -- below matches what arch/arm/fppArmLib.h says. - - type FP_CONTEXT is record - Dummy : Integer; - end record; - - for FP_CONTEXT'Alignment use 4; - pragma Convention (C, FP_CONTEXT); - - Num_HW_Interrupts : constant := 256; - -- Number of entries in hardware interrupt vector table. - -end System.VxWorks; diff --git a/gcc/ada/5yparame.ads b/gcc/ada/5yparame.ads deleted file mode 100644 index af397c2aeb7..00000000000 --- a/gcc/ada/5yparame.ads +++ /dev/null @@ -1,203 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2003 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 default VxWorks AE 653 version of the package.` - --- This package defines some system dependent parameters for GNAT. These --- are values that are referenced by the runtime library and are therefore --- relevant to the target machine. - --- The parameters whose value is defined in the spec are not generally --- expected to be changed. If they are changed, it will be necessary to --- recompile the run-time library. - --- The parameters which are defined by functions can be changed by modifying --- the body of System.Parameters in file s-parame.adb. A change to this body --- requires only rebinding and relinking of the application. - --- Note: do not introduce any pragma Inline statements into this unit, since --- otherwise the relinking and rebinding capability would be deactivated. - -package System.Parameters is -pragma Pure (Parameters); - - --------------------------------------- - -- Task And Stack Allocation Control -- - --------------------------------------- - - type Task_Storage_Size is new Integer; - -- Type used in tasking units for task storage size - - type Size_Type is new Task_Storage_Size; - -- Type used to provide task storage size to runtime - - Unspecified_Size : constant Size_Type := Size_Type'First; - -- Value used to indicate that no size type is set - - subtype Ratio is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Ratio : constant Ratio := 50; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - - function Default_Stack_Size return Size_Type; - -- Default task stack size used if none is specified - - function Minimum_Stack_Size return Size_Type; - -- Minimum task stack size permitted - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type; - -- Given the storage size stored in the TCB, return the Storage_Size - -- value required by the RM for the Storage_Size attribute. The - -- required adjustment is as follows: - -- - -- when Size = Unspecified_Size, return Default_Stack_Size - -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size - -- otherwise return given Size - - Default_Env_Stack_Size : constant Size_Type := 14_336; - -- Assumed size of the environment task, if no other information - -- is available. This value is used when stack checking is - -- enabled and no GNAT_STACK_LIMIT environment variable is set. - -- This value is chosen as the VxWorks default stack size is 20kB, - -- and a little more than 4kB is necessary for the run time. - - Stack_Grows_Down : constant Boolean := True; - -- This constant indicates whether the stack grows up (False) or - -- down (True) in memory as functions are called. It is used for - -- proper implementation of the stack overflow check. - - ---------------------------------------------- - -- Characteristics of types in Interfaces.C -- - ---------------------------------------------- - - long_bits : constant := Long_Integer'Size; - -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this is not true - -- of all targets. For example, in OpenVMS long /= Long_Integer. - - ---------------------------------------------- - -- Behavior of Pragma Finalize_Storage_Only -- - ---------------------------------------------- - - -- Garbage_Collected is a Boolean constant whose value indicates the - -- effect of the pragma Finalize_Storage_Entry on a controlled type. - - -- Garbage_Collected = False - - -- The system releases all storage on program termination only, - -- but not other garbage collection occurs, so finalization calls - -- are ommitted only for outer level onjects can be omitted if - -- pragma Finalize_Storage_Only is used. - - -- Garbage_Collected = True - - -- The system provides full garbage collection, so it is never - -- necessary to release storage for controlled objects for which - -- a pragma Finalize_Storage_Only is used. - - Garbage_Collected : constant Boolean := False; - -- The storage mode for this system (release on program exit) - - --------------------- - -- Tasking Profile -- - --------------------- - - -- In the following sections, constant parameters are defined to - -- allow some optimizations and fine tuning within the tasking run time - -- based on restrictions on the tasking features. - - ---------------------- - -- Locking Strategy -- - ---------------------- - - Single_Lock : constant Boolean := False; - -- Indicates whether a single lock should be used within the tasking - -- run-time to protect internal structures. If True, a single lock - -- will be used, meaning less locking/unlocking operations, but also - -- more global contention. In general, Single_Lock should be set to - -- True on single processor machines, and to False to multi-processor - -- systems, but this can vary from application to application and also - -- depends on the scheduling policy. - - ------------------- - -- Task Abortion -- - ------------------- - - No_Abort : constant Boolean := False; - -- This constant indicates whether abort statements and asynchronous - -- transfer of control (ATC) are disallowed. If set to True, it is - -- assumed that neither construct is used, and the run time does not - -- need to defer/undefer abort and check for pending actions at - -- completion points. A value of True for No_Abort corresponds to: - -- pragma Restrictions (No_Abort_Statements); - -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - - ---------------------- - -- Dynamic Priority -- - ---------------------- - - Dynamic_Priority_Support : constant Boolean := True; - -- This constant indicates whether dynamic changes of task priorities - -- are allowed (True means normal RM mode in which such changes are - -- allowed). In particular, if this is False, then we do not need to - -- poll for pending base priority changes at every abort completion - -- point. A value of False for Dynamic_Priority_Support corresponds - -- to pragma Restrictions (No_Dynamic_Priorities); - - --------------------- - -- Task Attributes -- - --------------------- - - Default_Attribute_Count : constant := 4; - -- Number of pre-allocated Address-sized task attributes stored in the - -- task control block. - - -------------------- - -- Runtime Traces -- - -------------------- - - Runtime_Traces : constant Boolean := False; - -- This constant indicates whether the runtime outputs traces to a - -- predefined output or not (True means that traces are output). - -- See System.Traces for more details. - -end System.Parameters; diff --git a/gcc/ada/5ysystem.ads b/gcc/ada/5ysystem.ads deleted file mode 100644 index 69602c86d78..00000000000 --- a/gcc/ada/5ysystem.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks Version PPC) -- --- -- --- 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 := 32; - Memory_Size : constant := 2 ** 32; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - - -- Priority-related Declarations (RM D.1) - - -- 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 := True; - 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; diff --git a/gcc/ada/5zinterr.adb b/gcc/ada/5zinterr.adb deleted file mode 100644 index 5898e6d7e26..00000000000 --- a/gcc/ada/5zinterr.adb +++ /dev/null @@ -1,1146 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . I N T E R R U P T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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. -- --- -- ------------------------------------------------------------------------------- - --- Invariants: - --- All user-handleable signals are masked at all times in all --- tasks/threads except possibly for the Interrupt_Manager task. - --- When a user task wants to have the effect of masking/unmasking an --- signal, it must call Block_Interrupt/Unblock_Interrupt, which --- will have the effect of unmasking/masking the signal in the --- Interrupt_Manager task. These comments do not apply to vectored --- hardware interrupts, which may be masked or unmasked using routined --- interfaced to the relevant VxWorks system calls. - --- Once we associate a Signal_Server_Task with an signal, the task never --- goes away, and we never remove the association. On the other hand, it --- is more convenient to terminate an associated Interrupt_Server_Task --- for a vectored hardware interrupt (since we use a binary semaphore --- for synchronization with the umbrella handler). - --- There is no more than one signal per Signal_Server_Task and no more than --- one Signal_Server_Task per signal. The same relation holds for hardware --- interrupts and Interrupt_Server_Task's at any given time. That is, --- only one non-terminated Interrupt_Server_Task exists for a give --- interrupt at any time. - --- Within this package, the lock L is used to protect the various status --- tables. If there is a Server_Task associated with a signal or interrupt, --- we use the per-task lock of the Server_Task instead so that we protect the --- status between Interrupt_Manager and Server_Task. Protection among --- service requests are ensured via user calls to the Interrupt_Manager --- entries. - --- This is the VxWorks version of this package, supporting vectored hardware --- interrupts. - -with Unchecked_Conversion; - -with System.OS_Interface; use System.OS_Interface; - -with Interfaces.VxWorks; - -with Ada.Task_Identification; --- used for Task_ID type - -with Ada.Exceptions; --- used for Raise_Exception - -with System.Interrupt_Management; --- used for Reserve - -with System.Task_Primitives.Operations; --- used for Write_Lock --- Unlock --- Abort --- Wakeup_Task --- Sleep --- Initialize_Lock - -with System.Storage_Elements; --- used for To_Address --- To_Integer --- Integer_Address - -with System.Tasking; --- used for Task_ID --- Task_Entry_Index --- Null_Task --- Self --- Interrupt_Manager_ID - -with System.Tasking.Utilities; --- used for Make_Independent - -with System.Tasking.Rendezvous; --- used for Call_Simple -pragma Elaborate_All (System.Tasking.Rendezvous); - -package body System.Interrupts is - - use Tasking; - use Ada.Exceptions; - - package POP renames System.Task_Primitives.Operations; - - function To_Ada is new Unchecked_Conversion - (System.Tasking.Task_ID, Ada.Task_Identification.Task_Id); - - function To_System is new Unchecked_Conversion - (Ada.Task_Identification.Task_Id, Task_ID); - - ----------------- - -- Local Tasks -- - ----------------- - - -- WARNING: System.Tasking.Stages performs calls to this task - -- with low-level constructs. Do not change this spec without synchro- - -- nizing it. - - task Interrupt_Manager is - entry Detach_Interrupt_Entries (T : Task_ID); - - entry Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False); - - entry Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean); - - entry Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean); - - entry Bind_Interrupt_To_Entry - (T : Task_ID; - E : Task_Entry_Index; - Interrupt : Interrupt_ID); - - pragma Interrupt_Priority (System.Interrupt_Priority'First); - end Interrupt_Manager; - - task type Interrupt_Server_Task - (Interrupt : Interrupt_ID; Int_Sema : SEM_ID) is - -- Server task for vectored hardware interrupt handling - pragma Interrupt_Priority (System.Interrupt_Priority'First + 2); - end Interrupt_Server_Task; - - type Interrupt_Task_Access is access Interrupt_Server_Task; - - ------------------------------- - -- Local Types and Variables -- - ------------------------------- - - type Entry_Assoc is record - T : Task_ID; - E : Task_Entry_Index; - end record; - - type Handler_Assoc is record - H : Parameterless_Handler; - Static : Boolean; -- Indicates static binding; - end record; - - User_Handler : array (Interrupt_ID) of Handler_Assoc := - (others => (null, Static => False)); - pragma Volatile_Components (User_Handler); - -- Holds the protected procedure handler (if any) and its Static - -- information for each interrupt or signal. A handler is static - -- iff it is specified through the pragma Attach_Handler. - - User_Entry : array (Interrupt_ID) of Entry_Assoc := - (others => (T => Null_Task, E => Null_Task_Entry)); - pragma Volatile_Components (User_Entry); - -- Holds the task and entry index (if any) for each interrupt / signal - - -- Type and Head, Tail of the list containing Registered Interrupt - -- Handlers. These definitions are used to register the handlers - -- specified by the pragma Interrupt_Handler. - - type Registered_Handler; - type R_Link is access all Registered_Handler; - - type Registered_Handler is record - H : System.Address := System.Null_Address; - Next : R_Link := null; - end record; - - Registered_Handler_Head : R_Link := null; - Registered_Handler_Tail : R_Link := null; - - Server_ID : array (Interrupt_ID) of System.Tasking.Task_ID := - (others => System.Tasking.Null_Task); - pragma Atomic_Components (Server_ID); - -- Holds the Task_ID of the Server_Task for each interrupt / signal. - -- Task_ID is needed to accomplish locking per interrupt base. Also - -- is needed to determine whether to create a new Server_Task. - - Semaphore_ID_Map : array - (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) - of SEM_ID := (others => 0); - -- Array of binary semaphores associated with vectored interrupts - -- Note that the last bound should be Max_HW_Interrupt, but this will raise - -- Storage_Error if Num_HW_Interrupts is null, so use an extra 4 bytes - -- instead. - - Interrupt_Access_Hold : Interrupt_Task_Access; - -- Variable for allocating an Interrupt_Server_Task - - Default_Handler : array (HW_Interrupt) of Interfaces.VxWorks.VOIDFUNCPTR; - -- Vectored interrupt handlers installed prior to program startup. - -- These are saved only when the umbrella handler is installed for - -- a given interrupt number. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID); - -- Check if Id is a reserved interrupt, and if so raise Program_Error - -- with an appropriate message, otherwise return. - - procedure Finalize_Interrupt_Servers; - -- Unbind the handlers for hardware interrupt server tasks at program - -- termination. - - function Is_Registered (Handler : Parameterless_Handler) return Boolean; - -- See if Handler has been "pragma"ed using Interrupt_Handler. - -- Always consider a null handler as registered. - - procedure Notify_Interrupt (Param : System.Address); - -- Umbrella handler for vectored interrupts (not signals) - - procedure Install_Default_Action (Interrupt : HW_Interrupt); - -- Restore a handler that was in place prior to program execution - - procedure Install_Umbrella_Handler - (Interrupt : HW_Interrupt; - Handler : Interfaces.VxWorks.VOIDFUNCPTR); - -- Install the runtime umbrella handler for a vectored hardware - -- interrupt - - procedure Unimplemented (Feature : String); - pragma No_Return (Unimplemented); - -- Used to mark a call to an unimplemented function. Raises Program_Error - -- with an appropriate message noting that Feature is unimplemented. - - -------------------- - -- Attach_Handler -- - -------------------- - - -- Calling this procedure with New_Handler = null and Static = True - -- means we want to detach the current handler regardless of the - -- previous handler's binding status (ie. do not care if it is a - -- dynamic or static handler). - - -- This option is needed so that during the finalization of a PO, we - -- can detach handlers attached through pragma Attach_Handler. - - procedure Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean := False) is - begin - Check_Reserved_Interrupt (Interrupt); - Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); - end Attach_Handler; - - ----------------------------- - -- Bind_Interrupt_To_Entry -- - ----------------------------- - - -- This procedure raises a Program_Error if it tries to - -- bind an interrupt to which an Entry or a Procedure is - -- already bound. - - procedure Bind_Interrupt_To_Entry - (T : Task_ID; - E : Task_Entry_Index; - Int_Ref : System.Address) - is - Interrupt : constant Interrupt_ID := - Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); - - begin - Check_Reserved_Interrupt (Interrupt); - Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); - end Bind_Interrupt_To_Entry; - - --------------------- - -- Block_Interrupt -- - --------------------- - - procedure Block_Interrupt (Interrupt : Interrupt_ID) is - begin - Unimplemented ("Block_Interrupt"); - end Block_Interrupt; - - ------------------------------ - -- Check_Reserved_Interrupt -- - ------------------------------ - - procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is - begin - if Is_Reserved (Interrupt) then - Raise_Exception - (Program_Error'Identity, - "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"); - else - return; - end if; - end Check_Reserved_Interrupt; - - --------------------- - -- Current_Handler -- - --------------------- - - function Current_Handler - (Interrupt : Interrupt_ID) return Parameterless_Handler is - begin - Check_Reserved_Interrupt (Interrupt); - - -- ??? Since Parameterless_Handler is not Atomic, the - -- current implementation is wrong. We need a new service in - -- Interrupt_Manager to ensure atomicity. - - return User_Handler (Interrupt).H; - end Current_Handler; - - -------------------- - -- Detach_Handler -- - -------------------- - - -- Calling this procedure with Static = True means we want to Detach the - -- current handler regardless of the previous handler's binding status - -- (i.e. do not care if it is a dynamic or static handler). - - -- This option is needed so that during the finalization of a PO, we can - -- detach handlers attached through pragma Attach_Handler. - - procedure Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean := False) is - begin - Check_Reserved_Interrupt (Interrupt); - Interrupt_Manager.Detach_Handler (Interrupt, Static); - end Detach_Handler; - - ------------------------------ - -- Detach_Interrupt_Entries -- - ------------------------------ - - procedure Detach_Interrupt_Entries (T : Task_ID) is - begin - Interrupt_Manager.Detach_Interrupt_Entries (T); - end Detach_Interrupt_Entries; - - ---------------------- - -- Exchange_Handler -- - ---------------------- - - -- Calling this procedure with New_Handler = null and Static = True - -- means we want to detach the current handler regardless of the - -- previous handler's binding status (ie. do not care if it is a - -- dynamic or static handler). - - -- This option is needed so that during the finalization of a PO, we - -- can detach handlers attached through pragma Attach_Handler. - - procedure Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean := False) is - begin - Check_Reserved_Interrupt (Interrupt); - Interrupt_Manager.Exchange_Handler - (Old_Handler, New_Handler, Interrupt, Static); - end Exchange_Handler; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Static_Interrupt_Protection) is - begin - -- ??? loop to be executed only when we're not doing library level - -- finalization, since in this case all interrupt / signal tasks are - -- gone. - - if not Interrupt_Manager'Terminated then - for N in reverse Object.Previous_Handlers'Range loop - Interrupt_Manager.Attach_Handler - (New_Handler => Object.Previous_Handlers (N).Handler, - Interrupt => Object.Previous_Handlers (N).Interrupt, - Static => Object.Previous_Handlers (N).Static, - Restoration => True); - end loop; - end if; - - Tasking.Protected_Objects.Entries.Finalize - (Tasking.Protected_Objects.Entries.Protection_Entries (Object)); - end Finalize; - - -------------------------------- - -- Finalize_Interrupt_Servers -- - -------------------------------- - - -- Restore default handlers for interrupt servers. - - -- This is called by the Interrupt_Manager task when it receives the abort - -- signal during program finalization. - - procedure Finalize_Interrupt_Servers is - HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0; - - begin - if HW_Interrupts then - for Int in HW_Interrupt loop - if Server_ID (Interrupt_ID (Int)) /= null - and then - not Ada.Task_Identification.Is_Terminated - (To_Ada (Server_ID (Interrupt_ID (Int)))) - then - Interrupt_Manager.Attach_Handler - (New_Handler => null, - Interrupt => Interrupt_ID (Int), - Static => True, - Restoration => True); - end if; - end loop; - end if; - end Finalize_Interrupt_Servers; - - ------------------------------------- - -- Has_Interrupt_Or_Attach_Handler -- - ------------------------------------- - - function Has_Interrupt_Or_Attach_Handler - (Object : access Dynamic_Interrupt_Protection) - return Boolean - is - pragma Unreferenced (Object); - - begin - return True; - end Has_Interrupt_Or_Attach_Handler; - - function Has_Interrupt_Or_Attach_Handler - (Object : access Static_Interrupt_Protection) - return Boolean - is - pragma Unreferenced (Object); - - begin - return True; - end Has_Interrupt_Or_Attach_Handler; - - ---------------------- - -- Ignore_Interrupt -- - ---------------------- - - procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is - begin - Unimplemented ("Ignore_Interrupt"); - end Ignore_Interrupt; - - ---------------------------- - -- Install_Default_Action -- - ---------------------------- - - procedure Install_Default_Action (Interrupt : HW_Interrupt) is - begin - -- Restore original interrupt handler - - Interfaces.VxWorks.intVecSet - (Interfaces.VxWorks.INUM_TO_IVEC (Integer (Interrupt)), - Default_Handler (Interrupt)); - Default_Handler (Interrupt) := null; - end Install_Default_Action; - - ---------------------- - -- Install_Handlers -- - ---------------------- - - procedure Install_Handlers - (Object : access Static_Interrupt_Protection; - New_Handlers : New_Handler_Array) is - begin - for N in New_Handlers'Range loop - -- We need a lock around this ??? - - Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt; - Object.Previous_Handlers (N).Static := User_Handler - (New_Handlers (N).Interrupt).Static; - - -- We call Exchange_Handler and not directly Interrupt_Manager. - -- Exchange_Handler so we get the Is_Reserved check. - - Exchange_Handler - (Old_Handler => Object.Previous_Handlers (N).Handler, - New_Handler => New_Handlers (N).Handler, - Interrupt => New_Handlers (N).Interrupt, - Static => True); - end loop; - end Install_Handlers; - - ------------------------------ - -- Install_Umbrella_Handler -- - ------------------------------ - - procedure Install_Umbrella_Handler - (Interrupt : HW_Interrupt; - Handler : Interfaces.VxWorks.VOIDFUNCPTR) - is - use Interfaces.VxWorks; - - Vec : constant Interrupt_Vector := - INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt)); - - Old_Handler : constant VOIDFUNCPTR := - intVecGet - (INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt))); - - Stat : Interfaces.VxWorks.STATUS; - pragma Unreferenced (Stat); - -- ??? shouldn't we test Stat at least in a pragma Assert? - - begin - -- Only install umbrella handler when no Ada handler has already been - -- installed. Note that the interrupt number is passed as a parameter - -- when an interrupt occurs, so the umbrella handler has a different - -- wrapper generated by intConnect for each interrupt number. - - if Default_Handler (Interrupt) = null then - Stat := - intConnect (Vec, Handler, System.Address (Interrupt)); - Default_Handler (Interrupt) := Old_Handler; - end if; - end Install_Umbrella_Handler; - - ---------------- - -- Is_Blocked -- - ---------------- - - function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is - begin - Unimplemented ("Is_Blocked"); - return False; - end Is_Blocked; - - ----------------------- - -- Is_Entry_Attached -- - ----------------------- - - function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is - begin - Check_Reserved_Interrupt (Interrupt); - return User_Entry (Interrupt).T /= Null_Task; - end Is_Entry_Attached; - - ------------------------- - -- Is_Handler_Attached -- - ------------------------- - - function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is - begin - Check_Reserved_Interrupt (Interrupt); - return User_Handler (Interrupt).H /= null; - end Is_Handler_Attached; - - ---------------- - -- Is_Ignored -- - ---------------- - - function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is - begin - Unimplemented ("Is_Ignored"); - return False; - end Is_Ignored; - - ------------------- - -- Is_Registered -- - ------------------- - - function Is_Registered (Handler : Parameterless_Handler) return Boolean is - type Fat_Ptr is record - Object_Addr : System.Address; - Handler_Addr : System.Address; - end record; - - function To_Fat_Ptr is new Unchecked_Conversion - (Parameterless_Handler, Fat_Ptr); - - Ptr : R_Link; - Fat : Fat_Ptr; - - begin - if Handler = null then - return True; - end if; - - Fat := To_Fat_Ptr (Handler); - - Ptr := Registered_Handler_Head; - - while Ptr /= null loop - if Ptr.H = Fat.Handler_Addr then - return True; - end if; - - Ptr := Ptr.Next; - end loop; - - return False; - end Is_Registered; - - ----------------- - -- Is_Reserved -- - ----------------- - - function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is - use System.Interrupt_Management; - begin - return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt)); - end Is_Reserved; - - ---------------------- - -- Notify_Interrupt -- - ---------------------- - - -- Umbrella handler for vectored hardware interrupts (as opposed to - -- signals and exceptions). As opposed to the signal implementation, - -- this handler is only installed in the vector table while there is - -- an active association of an Ada handler to the interrupt. - - -- Otherwise, the handler that existed prior to program startup is - -- in the vector table. This ensures that handlers installed by - -- the BSP are active unless explicitly replaced in the program text. - - -- Each Interrupt_Server_Task has an associated binary semaphore - -- on which it pends once it's been started. This routine determines - -- The appropriate semaphore and and issues a semGive call, waking - -- the server task. When a handler is unbound, - -- System.Interrupts.Unbind_Handler issues a semFlush, and the - -- server task deletes its semaphore and terminates. - - procedure Notify_Interrupt (Param : System.Address) is - Interrupt : constant Interrupt_ID := Interrupt_ID (Param); - - Discard_Result : STATUS; - pragma Unreferenced (Discard_Result); - - begin - Discard_Result := semGive (Semaphore_ID_Map (Interrupt)); - end Notify_Interrupt; - - --------------- - -- Reference -- - --------------- - - function Reference (Interrupt : Interrupt_ID) return System.Address is - begin - Check_Reserved_Interrupt (Interrupt); - return Storage_Elements.To_Address - (Storage_Elements.Integer_Address (Interrupt)); - end Reference; - - -------------------------------- - -- Register_Interrupt_Handler -- - -------------------------------- - - procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is - New_Node_Ptr : R_Link; - begin - -- This routine registers a handler as usable for dynamic - -- interrupt handler association. Routines attaching and detaching - -- handlers dynamically should determine whether the handler is - -- registered. Program_Error should be raised if it is not registered. - - -- Pragma Interrupt_Handler can only appear in a library - -- level PO definition and instantiation. Therefore, we do not need - -- to implement an unregister operation. Nor do we need to - -- protect the queue structure with a lock. - - pragma Assert (Handler_Addr /= System.Null_Address); - - New_Node_Ptr := new Registered_Handler; - New_Node_Ptr.H := Handler_Addr; - - if Registered_Handler_Head = null then - Registered_Handler_Head := New_Node_Ptr; - Registered_Handler_Tail := New_Node_Ptr; - - else - Registered_Handler_Tail.Next := New_Node_Ptr; - Registered_Handler_Tail := New_Node_Ptr; - end if; - end Register_Interrupt_Handler; - - ----------------------- - -- Unblock_Interrupt -- - ----------------------- - - procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is - begin - Unimplemented ("Unblock_Interrupt"); - end Unblock_Interrupt; - - ------------------ - -- Unblocked_By -- - ------------------ - - function Unblocked_By - (Interrupt : Interrupt_ID) return System.Tasking.Task_ID is - begin - Unimplemented ("Unblocked_By"); - return Null_Task; - end Unblocked_By; - - ------------------------ - -- Unignore_Interrupt -- - ------------------------ - - procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is - begin - Unimplemented ("Unignore_Interrupt"); - end Unignore_Interrupt; - - ------------------- - -- Unimplemented -- - ------------------- - - procedure Unimplemented (Feature : String) is - begin - Raise_Exception - (Program_Error'Identity, - Feature & " not implemented on VxWorks"); - end Unimplemented; - - ----------------------- - -- Interrupt_Manager -- - ----------------------- - - task body Interrupt_Manager is - - -------------------- - -- Local Routines -- - -------------------- - - procedure Bind_Handler (Interrupt : Interrupt_ID); - -- This procedure does not do anything if a signal is blocked. - -- Otherwise, we have to interrupt Server_Task for status change through - -- a wakeup signal. - - procedure Unbind_Handler (Interrupt : Interrupt_ID); - -- This procedure does not do anything if a signal is blocked. - -- Otherwise, we have to interrupt Server_Task for status change - -- through an abort signal. - - procedure Unprotected_Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False); - - procedure Unprotected_Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean); - - ------------------ - -- Bind_Handler -- - ------------------ - - procedure Bind_Handler (Interrupt : Interrupt_ID) is - begin - Install_Umbrella_Handler - (HW_Interrupt (Interrupt), Notify_Interrupt'Access); - end Bind_Handler; - - -------------------- - -- Unbind_Handler -- - -------------------- - - procedure Unbind_Handler (Interrupt : Interrupt_ID) is - S : STATUS; - use type STATUS; - - begin - -- Hardware interrupt - - Install_Default_Action (HW_Interrupt (Interrupt)); - - -- Flush server task off semaphore, allowing it to terminate - - S := semFlush (Semaphore_ID_Map (Interrupt)); - pragma Assert (S = 0); - end Unbind_Handler; - - -------------------------------- - -- Unprotected_Detach_Handler -- - -------------------------------- - - procedure Unprotected_Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean) - is - Old_Handler : Parameterless_Handler; - begin - if User_Entry (Interrupt).T /= Null_Task then - -- If an interrupt entry is installed raise - -- Program_Error. (propagate it to the caller). - - Raise_Exception (Program_Error'Identity, - "An interrupt entry is already installed"); - end if; - - -- Note : Static = True will pass the following check. This is the - -- case when we want to detach a handler regardless of the static - -- status of the Current_Handler. - - if not Static and then User_Handler (Interrupt).Static then - -- Trying to detach a static Interrupt Handler. - -- raise Program_Error. - - Raise_Exception (Program_Error'Identity, - "Trying to detach a static Interrupt Handler"); - end if; - - Old_Handler := User_Handler (Interrupt).H; - - -- The new handler - - User_Handler (Interrupt).H := null; - User_Handler (Interrupt).Static := False; - - if Old_Handler /= null then - Unbind_Handler (Interrupt); - end if; - end Unprotected_Detach_Handler; - - ---------------------------------- - -- Unprotected_Exchange_Handler -- - ---------------------------------- - - procedure Unprotected_Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False) is - begin - if User_Entry (Interrupt).T /= Null_Task then - -- If an interrupt entry is already installed, raise - -- Program_Error. (propagate it to the caller). - - Raise_Exception - (Program_Error'Identity, - "An interrupt is already installed"); - end if; - - -- Note : A null handler with Static = True will - -- pass the following check. This is the case when we want to - -- detach a handler regardless of the Static status - -- of Current_Handler. - -- We don't check anything if Restoration is True, since we - -- may be detaching a static handler to restore a dynamic one. - - if not Restoration and then not Static - and then (User_Handler (Interrupt).Static - - -- Trying to overwrite a static Interrupt Handler with a - -- dynamic Handler - - -- The new handler is not specified as an - -- Interrupt Handler by a pragma. - - or else not Is_Registered (New_Handler)) - then - Raise_Exception - (Program_Error'Identity, - "Trying to overwrite a static Interrupt Handler with a " & - "dynamic Handler"); - end if; - - -- Save the old handler - - Old_Handler := User_Handler (Interrupt).H; - - -- The new handler - - User_Handler (Interrupt).H := New_Handler; - - if New_Handler = null then - - -- The null handler means we are detaching the handler. - - User_Handler (Interrupt).Static := False; - - else - User_Handler (Interrupt).Static := Static; - end if; - - -- Invoke a corresponding Server_Task if not yet created. - -- Place Task_ID info in Server_ID array. - - if New_Handler /= null - and then - (Server_ID (Interrupt) = Null_Task - or else - Ada.Task_Identification.Is_Terminated - (To_Ada (Server_ID (Interrupt)))) - then - Interrupt_Access_Hold := - new Interrupt_Server_Task - (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY)); - Server_ID (Interrupt) := - To_System (Interrupt_Access_Hold.all'Identity); - end if; - - if (New_Handler = null) and then Old_Handler /= null then - -- Restore default handler - - Unbind_Handler (Interrupt); - - elsif Old_Handler = null then - -- Save default handler - - Bind_Handler (Interrupt); - end if; - end Unprotected_Exchange_Handler; - - -- Start of processing for Interrupt_Manager - - begin - -- By making this task independent of any master, when the process - -- goes away, the Interrupt_Manager will terminate gracefully. - - System.Tasking.Utilities.Make_Independent; - - loop - -- A block is needed to absorb Program_Error exception - - declare - Old_Handler : Parameterless_Handler; - - begin - select - accept Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False) - do - Unprotected_Exchange_Handler - (Old_Handler, New_Handler, Interrupt, Static, Restoration); - end Attach_Handler; - - or - accept Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean) - do - Unprotected_Exchange_Handler - (Old_Handler, New_Handler, Interrupt, Static); - end Exchange_Handler; - - or - accept Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean) - do - Unprotected_Detach_Handler (Interrupt, Static); - end Detach_Handler; - or - accept Bind_Interrupt_To_Entry - (T : Task_ID; - E : Task_Entry_Index; - Interrupt : Interrupt_ID) - do - -- If there is a binding already (either a procedure or an - -- entry), raise Program_Error (propagate it to the caller). - - if User_Handler (Interrupt).H /= null - or else User_Entry (Interrupt).T /= Null_Task - then - Raise_Exception - (Program_Error'Identity, - "A binding for this interrupt is already present"); - end if; - - User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E); - - -- Indicate the attachment of interrupt entry in the ATCB. - -- This is needed so when an interrupt entry task terminates - -- the binding can be cleaned. The call to unbinding must be - -- make by the task before it terminates. - - T.Interrupt_Entry := True; - - -- Invoke a corresponding Server_Task if not yet created. - -- Place Task_ID info in Server_ID array. - - if Server_ID (Interrupt) = Null_Task - or else - Ada.Task_Identification.Is_Terminated - (To_Ada (Server_ID (Interrupt))) - then - Interrupt_Access_Hold := new Interrupt_Server_Task - (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY)); - Server_ID (Interrupt) := - To_System (Interrupt_Access_Hold.all'Identity); - end if; - - Bind_Handler (Interrupt); - end Bind_Interrupt_To_Entry; - - or - accept Detach_Interrupt_Entries (T : Task_ID) do - for Int in Interrupt_ID'Range loop - if not Is_Reserved (Int) then - if User_Entry (Int).T = T then - User_Entry (Int) := - Entry_Assoc' - (T => Null_Task, E => Null_Task_Entry); - Unbind_Handler (Int); - end if; - end if; - end loop; - - -- Indicate in ATCB that no interrupt entries are attached. - - T.Interrupt_Entry := False; - end Detach_Interrupt_Entries; - end select; - - exception - -- If there is a Program_Error we just want to propagate it to - -- the caller and do not want to stop this task. - - when Program_Error => - null; - - when others => - pragma Assert (False); - null; - end; - end loop; - - exception - when Standard'Abort_Signal => - -- Flush interrupt server semaphores, so they can terminate - Finalize_Interrupt_Servers; - raise; - end Interrupt_Manager; - - --------------------------- - -- Interrupt_Server_Task -- - --------------------------- - - -- Server task for vectored hardware interrupt handling - - task body Interrupt_Server_Task is - Self_Id : constant Task_ID := Self; - Tmp_Handler : Parameterless_Handler; - Tmp_ID : Task_ID; - Tmp_Entry_Index : Task_Entry_Index; - S : STATUS; - - use type STATUS; - - begin - System.Tasking.Utilities.Make_Independent; - Semaphore_ID_Map (Interrupt) := Int_Sema; - - loop - -- Pend on semaphore that will be triggered by the - -- umbrella handler when the associated interrupt comes in - - S := semTake (Int_Sema, WAIT_FOREVER); - pragma Assert (S = 0); - - if User_Handler (Interrupt).H /= null then - - -- Protected procedure handler - - Tmp_Handler := User_Handler (Interrupt).H; - Tmp_Handler.all; - - elsif User_Entry (Interrupt).T /= Null_Task then - - -- Interrupt entry handler - - Tmp_ID := User_Entry (Interrupt).T; - Tmp_Entry_Index := User_Entry (Interrupt).E; - System.Tasking.Rendezvous.Call_Simple - (Tmp_ID, Tmp_Entry_Index, System.Null_Address); - - else - -- Semaphore has been flushed by an unbind operation in - -- the Interrupt_Manager. Terminate the server task. - - -- Wait for the Interrupt_Manager to complete its work - - POP.Write_Lock (Self_Id); - - -- Delete the associated semaphore - - S := semDelete (Int_Sema); - - pragma Assert (S = 0); - - -- Set status for the Interrupt_Manager - - Semaphore_ID_Map (Interrupt) := 0; - Server_ID (Interrupt) := Null_Task; - POP.Unlock (Self_Id); - - exit; - end if; - end loop; - end Interrupt_Server_Task; - -begin - -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent. - - Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); -end System.Interrupts; diff --git a/gcc/ada/5zintman.adb b/gcc/ada/5zintman.adb deleted file mode 100644 index 411d86d0ae0..00000000000 --- a/gcc/ada/5zintman.adb +++ /dev/null @@ -1,194 +0,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-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. - --- It is likely to need tailoring to fit each operating system --- and machine architecture. - --- PLEASE DO NOT add any dependences on other packages. --- 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. - -with Interfaces.C; - -with System.OS_Interface; --- used for various Constants, Signal and types - -package body System.Interrupt_Management is - - use System.OS_Interface; - use type Interfaces.C.int; - - type Signal_List is array (Signal_ID range <>) of Signal_ID; - Exception_Signals : constant Signal_List (1 .. 4) := - (SIGFPE, SIGILL, SIGSEGV, SIGBUS); - - -- Keep these variables global so that they are initialized only once - -- What are "these variables" ???, I see only one - - Exception_Action : aliased struct_sigaction; - - procedure Map_And_Raise_Exception (signo : Signal); - pragma Import (C, Map_And_Raise_Exception, "__gnat_map_signal"); - -- Map signal to Ada exception and raise it. Different versions - -- of VxWorks need different mappings. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Notify_Exception (signo : Signal); - -- Identify the Ada exception to be raised using - -- the information when the system received a synchronous signal. - - ---------------------- - -- Notify_Exception -- - ---------------------- - - procedure Notify_Exception (signo : Signal) is - Mask : aliased sigset_t; - My_Id : t_id; - - Result : int; - pragma Unreferenced (Result); - - begin - Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access); - Result := sigdelset (Mask'Access, signo); - Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null); - - -- VxWorks will suspend the task when it gets a hardware - -- exception. We take the liberty of resuming the task - -- for the application. - - My_Id := taskIdSelf; - - if taskIsSuspended (My_Id) /= 0 then - Result := taskResume (My_Id); - end if; - - Map_And_Raise_Exception (signo); - end Notify_Exception; - - --------------------------- - -- Initialize_Interrupts -- - --------------------------- - - -- Since there is no signal inheritance between VxWorks tasks, we need - -- to initialize signal handling in each task. - - procedure Initialize_Interrupts is - Result : int; - old_act : aliased struct_sigaction; - - begin - for J in Exception_Signals'Range loop - Result := - sigaction - (Signal (Exception_Signals (J)), Exception_Action'Access, - old_act'Unchecked_Access); - pragma Assert (Result = 0); - end loop; - end Initialize_Interrupts; - -begin - declare - mask : aliased sigset_t; - Result : 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: - - 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 - -- Initialize signal handling - - -- Change this if you want to use another signal for task abort. - -- SIGTERM might be a good one. - - Abort_Task_Signal := SIGABRT; - - Exception_Action.sa_handler := Notify_Exception'Address; - Exception_Action.sa_flags := SA_ONSTACK; - Result := sigemptyset (mask'Access); - pragma Assert (Result = 0); - - for J in Exception_Signals'Range loop - Result := sigaddset (mask'Access, Signal (Exception_Signals (J))); - pragma Assert (Result = 0); - end loop; - - Exception_Action.sa_mask := mask; - - -- Initialize hardware interrupt handling - - pragma Assert (Reserve = (Interrupt_ID'Range => False)); - - -- Check all interrupts for state that requires keeping them reserved - - for J in Interrupt_ID'Range loop - if State (J) = Default or else State (J) = Runtime then - Reserve (J) := True; - end if; - end loop; - - -- Add exception signals to the set of unmasked signals - - for J in Exception_Signals'Range loop - Keep_Unmasked (Exception_Signals (J)) := True; - end loop; - - -- The abort signal must also be unmasked - - Keep_Unmasked (Abort_Task_Signal) := True; - end; -end System.Interrupt_Management; diff --git a/gcc/ada/5zintman.ads b/gcc/ada/5zintman.ads deleted file mode 100644 index b0a4c3c5bda..00000000000 --- a/gcc/ada/5zintman.ads +++ /dev/null @@ -1,123 +0,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 -- --- -- --- S p e c -- --- -- --- 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 VxWorks version of this package. - --- This package encapsulates and centralizes information about all --- uses of interrupts (or signals), including the target-dependent --- mapping of interrupts (or signals) to exceptions. - --- Unlike the original design, System.Interrupt_Management can only --- be used for tasking systems. - --- PLEASE DO NOT remove the Elaborate_Body pragma from this package. --- Elaboration of this package should happen early, as most other --- initializations depend on it. Forcing immediate elaboration of --- the body also helps to enforce the design assumption that this --- is a second-level package, just one level above System.OS_Interface --- with no cross-dependencies. - --- PLEASE DO NOT put any subprogram declarations with arguments of --- type Interrupt_ID into the visible part of this package. The type --- Interrupt_ID is used to derive the type in Ada.Interrupts, and --- adding more operations to that type would be illegal according --- to the Ada Reference Manual. This is the reason why the signals --- sets are implemeneted using visible arrays rather than functions. - -with System.OS_Interface; --- used for sigset_t - -with Interfaces.C; --- used for int - -package System.Interrupt_Management is - - pragma Elaborate_Body; - - type Interrupt_Mask is limited private; - - type Interrupt_ID is new Interfaces.C.int - range 0 .. System.OS_Interface.Max_Interrupt; - - type Interrupt_Set is array (Interrupt_ID) of Boolean; - - subtype Signal_ID is Interrupt_ID - range 0 .. Interfaces.C."-" (System.OS_Interface.NSIG, 1); - - type Signal_Set is array (Signal_ID) of Boolean; - - -- The following objects serve as constants, but are initialized - -- in the body to aid portability. This permits us to use more - -- portable names for interrupts, where distinct names may map to - -- the same interrupt ID value. - -- - -- For example, suppose SIGRARE is a signal that is not defined on - -- all systems, but is always reserved when it is defined. If we - -- have the convention that ID zero is not used for any "real" - -- signals, and SIGRARE = 0 when SIGRARE is not one of the locally - -- supported signals, we can write - -- Reserved (SIGRARE) := true; - -- and the initialization code will be portable. - - Abort_Task_Signal : Signal_ID; - -- The signal that is used to implement task abortion if - -- an interrupt is used for that purpose. This is one of the - -- reserved signals. - - Keep_Unmasked : Signal_Set := (others => False); - -- Keep_Unmasked (I) is true iff the signal I is one that must - -- that must be kept unmasked at all times, except (perhaps) for - -- short critical sections. This includes signals that are - -- mapped to exceptions, but may also include interrupts - -- (e.g. timer) that need to be kept unmasked for other - -- reasons. Where signal masking is per-task, the signal should be - -- unmasked in ALL TASKS. - - Reserve : Interrupt_Set := (others => False); - -- Reserve (I) is true iff the interrupt I is one that cannot be - -- permitted to be attached to a user handler. The possible reasons - -- are many. For example, it may be mapped to an exception used to - -- implement task abortion, or used to implement time delays. - - procedure Initialize_Interrupts; - -- On systems where there is no signal inheritance between tasks (e.g - -- VxWorks, GNU/LinuxThreads), this procedure is used to initialize - -- interrupts handling in each task. Otherwise this function should - -- only be called by initialize in this package body. - -private - type Interrupt_Mask is new System.OS_Interface.sigset_t; - -- In some implementation Interrupt_Mask can be represented - -- as a linked list. - -end System.Interrupt_Management; diff --git a/gcc/ada/5zml-tgt.adb b/gcc/ada/5zml-tgt.adb deleted file mode 100644 index 9b3f5757463..00000000000 --- a/gcc/ada/5zml-tgt.adb +++ /dev/null @@ -1,317 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T -- --- (VxWorks Version) -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-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. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a set of target dependent routines to build --- static libraries. - --- This is the VxWorks version of the body - -with MLib.Fil; -with Namet; use Namet; -with Prj.Com; -with Sdefault; - -package body MLib.Tgt is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Get_Target_Suffix return String; - -- Returns the required suffix for some utilities - -- (such as ar and ranlib) that depend on the real target. - - --------------------- - -- Archive_Builder -- - --------------------- - - function Archive_Builder return String is - begin - return "ar" & Get_Target_Suffix; - end Archive_Builder; - - ----------------------------- - -- Archive_Builder_Options -- - ----------------------------- - - function Archive_Builder_Options return String_List_Access is - begin - return new String_List'(1 => new String'("cr")); - end Archive_Builder_Options; - - ----------------- - -- Archive_Ext -- - ----------------- - - function Archive_Ext return String is - begin - return "a"; - end Archive_Ext; - - --------------------- - -- Archive_Indexer -- - --------------------- - - function Archive_Indexer return String is - begin - return "ranlib" & Get_Target_Suffix; - end Archive_Indexer; - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Foreign : Argument_List; - Afiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Address : String := ""; - Lib_Version : String := ""; - Relocatable : Boolean := False; - Auto_Init : Boolean := False) - is - pragma Unreferenced (Ofiles); - pragma Unreferenced (Foreign); - pragma Unreferenced (Afiles); - pragma Unreferenced (Options); - pragma Unreferenced (Interfaces); - pragma Unreferenced (Lib_Filename); - pragma Unreferenced (Lib_Dir); - pragma Unreferenced (Symbol_Data); - pragma Unreferenced (Driver_Name); - pragma Unreferenced (Lib_Address); - pragma Unreferenced (Lib_Version); - pragma Unreferenced (Relocatable); - pragma Unreferenced (Auto_Init); - - begin - null; - end Build_Dynamic_Library; - - ------------------------- - -- Default_DLL_Address -- - ------------------------- - - function Default_DLL_Address return String is - begin - return ""; - end Default_DLL_Address; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return ""; - end DLL_Ext; - - -------------------- - -- Dynamic_Option -- - -------------------- - - function Dynamic_Option return String is - begin - return ""; - end Dynamic_Option; - - ----------------------------- - -- Get_Target_Suffix -- - ----------------------------- - - function Get_Target_Suffix return String is - Target_Name : constant String_Ptr := Sdefault.Target_Name; - Index : Positive := Target_Name'First; - - begin - while Index < Target_Name'Last - and then Target_Name (Index + 1) /= '-' - loop - Index := Index + 1; - end loop; - - if Target_Name (Target_Name'First .. Index) = "m68k" then - return "68k"; - elsif Target_Name (Target_Name'First .. Index) = "mips" then - return "mips"; - elsif Target_Name (Target_Name'First .. Index) = "powerpc" then - return "ppc"; - elsif Target_Name (Target_Name'First .. Index) = "sparc" then - return "sparc"; - elsif Target_Name (Target_Name'First .. Index) = "sparc64" then - return "sparc64"; - elsif Target_Name (Target_Name'First .. Index) = "xscale" then - return "arm"; - else - return ""; - end if; - end Get_Target_Suffix; - - ------------------- - -- Is_Object_Ext -- - ------------------- - - function Is_Object_Ext (Ext : String) return Boolean is - begin - return Ext = ".o"; - end Is_Object_Ext; - - -------------- - -- Is_C_Ext -- - -------------- - - function Is_C_Ext (Ext : String) return Boolean is - begin - return Ext = ".c"; - end Is_C_Ext; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".a"; - end Is_Archive_Ext; - - ------------- - -- Libgnat -- - ------------- - - function Libgnat return String is - begin - return "libgnat.a"; - end Libgnat; - - ------------------------ - -- Library_Exists_For -- - ------------------------ - - function Library_Exists_For (Project : Project_Id) return Boolean is - begin - if not Projects.Table (Project).Library then - Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & - "for non library project"); - return False; -- To avoid warning; - - else - declare - Lib_Dir : constant String := - Get_Name_String (Projects.Table (Project).Library_Dir); - Lib_Name : constant String := - Get_Name_String (Projects.Table (Project).Library_Name); - - begin - if Projects.Table (Project).Library_Kind = Static then - return Is_Regular_File - (Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - return Is_Regular_File - (Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - end; - end if; - end Library_Exists_For; - - --------------------------- - -- Library_File_Name_For -- - --------------------------- - - function Library_File_Name_For (Project : Project_Id) return Name_Id is - begin - if not Projects.Table (Project).Library then - Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & - "for non library project"); - return No_Name; - - else - declare - Lib_Name : constant String := - Get_Name_String (Projects.Table (Project).Library_Name); - - begin - Name_Len := 3; - Name_Buffer (1 .. Name_Len) := "lib"; - - if Projects.Table (Project).Library_Kind = Static then - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); - - else - Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); - end if; - - return Name_Find; - end; - end if; - end Library_File_Name_For; - - ---------------- - -- Object_Ext -- - ---------------- - - function Object_Ext return String is - begin - return "o"; - end Object_Ext; - - ---------------- - -- PIC_Option -- - ---------------- - - function PIC_Option return String is - begin - return ""; - end PIC_Option; - - ----------------------------------------------- - -- Standalone_Library_Auto_Init_Is_Supported -- - ----------------------------------------------- - - function Standalone_Library_Auto_Init_Is_Supported return Boolean is - begin - return False; - end Standalone_Library_Auto_Init_Is_Supported; - - --------------------------- - -- Support_For_Libraries -- - --------------------------- - - function Support_For_Libraries return Library_Support is - begin - return Static_Only; - end Support_For_Libraries; - -end MLib.Tgt; diff --git a/gcc/ada/5zosinte.adb b/gcc/ada/5zosinte.adb deleted file mode 100644 index 7c665e7d2a4..00000000000 --- a/gcc/ada/5zosinte.adb +++ /dev/null @@ -1,164 +0,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) 1997-2002 Free Software Foundation -- --- -- --- GNARL is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- --- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNARL; see file COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- As a special exception, if other files instantiate generics from this -- --- unit, or you link this unit with other files to produce an executable, -- --- this unit does not by itself cause the resulting executable to be -- --- covered by the GNU General Public License. This exception does not -- --- however invalidate any other reasons why the executable file might be -- --- covered by the GNU Public License. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VxWorks version. - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -package body System.OS_Interface is - - use type Interfaces.C.int; - - Low_Priority : constant := 255; - -- VxWorks native (default) lowest scheduling priority. - - ------------- - -- sigwait -- - ------------- - - function sigwait - (set : access sigset_t; - sig : access Signal) return int - is - Result : int; - - function sigwaitinfo - (set : access sigset_t; sigvalue : System.Address) return int; - pragma Import (C, sigwaitinfo, "sigwaitinfo"); - - begin - Result := sigwaitinfo (set, System.Null_Address); - - if Result /= -1 then - sig.all := Signal (Result); - return 0; - else - sig.all := 0; - return errno; - end if; - end sigwait; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (TS : timespec) return Duration is - begin - return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; - 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'(ts_sec => S, - ts_nsec => long (Long_Long_Integer (F * 10#1#E9))); - end To_Timespec; - - ------------------------- - -- To_VxWorks_Priority -- - ------------------------- - - function To_VxWorks_Priority (Priority : in int) return int is - begin - return Low_Priority - Priority; - end To_VxWorks_Priority; - - -------------------- - -- To_Clock_Ticks -- - -------------------- - - -- ??? - For now, we'll always get the system clock rate - -- since it is allowed to be changed during run-time in - -- VxWorks. A better method would be to provide an operation - -- to set it that so we can always know its value. - -- - -- Another thing we should probably allow for is a resultant - -- tick count greater than int'Last. This should probably - -- be a procedure with two output parameters, one in the - -- range 0 .. int'Last, and another representing the overflow - -- count. - - function To_Clock_Ticks (D : Duration) return int is - Ticks : Long_Long_Integer; - Rate_Duration : Duration; - Ticks_Duration : Duration; - - begin - if D < 0.0 then - return -1; - end if; - - -- Ensure that the duration can be converted to ticks - -- at the current clock tick rate without overflowing. - - Rate_Duration := Duration (sysClkRateGet); - - if D > (Duration'Last / Rate_Duration) then - Ticks := Long_Long_Integer (int'Last); - else - Ticks_Duration := D * Rate_Duration; - Ticks := Long_Long_Integer (Ticks_Duration); - - if Ticks_Duration > Duration (Ticks) then - Ticks := Ticks + 1; - end if; - - if Ticks > Long_Long_Integer (int'Last) then - Ticks := Long_Long_Integer (int'Last); - end if; - end if; - - return int (Ticks); - end To_Clock_Ticks; - -end System.OS_Interface; diff --git a/gcc/ada/5zosinte.ads b/gcc/ada/5zosinte.ads deleted file mode 100644 index 7888cc18e68..00000000000 --- a/gcc/ada/5zosinte.ads +++ /dev/null @@ -1,371 +0,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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-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 package encapsulates all direct interfaces to OS services --- that are needed by children of System. - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; -with System.VxWorks; - -package System.OS_Interface is - pragma Preelaborate; - - subtype int is Interfaces.C.int; - subtype short is Short_Integer; - type long is new Long_Integer; - type unsigned_long is mod 2 ** long'Size; - type size_t is mod 2 ** Standard'Address_Size; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "errnoGet"); - - EINTR : constant := 4; - EAGAIN : constant := 35; - ENOMEM : constant := 12; - EINVAL : constant := 22; - ETIMEDOUT : constant := 60; - - FUNC_ERR : constant := -1; - - ---------------------------- - -- Signals and Interrupts -- - ---------------------------- - - NSIG : constant := 32; - -- Number of signals on the target OS - type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1); - - Max_HW_Interrupt : constant := System.VxWorks.Num_HW_Interrupts - 1; - type HW_Interrupt is new int range 0 .. Max_HW_Interrupt; - - Max_Interrupt : constant := Max_HW_Interrupt; - - SIGILL : constant := 4; -- illegal instruction (not reset) - SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future - SIGFPE : constant := 8; -- floating point exception - SIGBUS : constant := 10; -- bus error - SIGSEGV : constant := 11; -- segmentation violation - - ----------------------------------- - -- Signal processing definitions -- - ----------------------------------- - - -- The how in sigprocmask(). - SIG_BLOCK : constant := 1; - SIG_UNBLOCK : constant := 2; - SIG_SETMASK : constant := 3; - - -- The sa_flags in struct sigaction. - SA_SIGINFO : constant := 16#0002#; - SA_ONSTACK : constant := 16#0004#; - - SIG_DFL : constant := 0; - SIG_IGN : constant := 1; - - type sigset_t is private; - - type struct_sigaction is record - sa_handler : System.Address; - sa_mask : sigset_t; - sa_flags : int; - end record; - pragma Convention (C, struct_sigaction); - type struct_sigaction_ptr is access all struct_sigaction; - - function sigaddset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigaddset, "sigaddset"); - - function sigdelset (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigdelset, "sigdelset"); - - function sigfillset (set : access sigset_t) return int; - pragma Import (C, sigfillset, "sigfillset"); - - function sigismember (set : access sigset_t; sig : Signal) return int; - pragma Import (C, sigismember, "sigismember"); - - function sigemptyset (set : access sigset_t) return int; - pragma Import (C, sigemptyset, "sigemptyset"); - - function sigaction - (sig : Signal; - act : struct_sigaction_ptr; - oact : struct_sigaction_ptr) return int; - pragma Import (C, sigaction, "sigaction"); - - type isr_address is access procedure (sig : int); - - function c_signal (sig : Signal; handler : isr_address) return isr_address; - pragma Import (C, c_signal, "signal"); - - function sigwait (set : access sigset_t; sig : access Signal) return int; - pragma Inline (sigwait); - - type sigset_t_ptr is access all sigset_t; - - function pthread_sigmask - (how : int; - set : sigset_t_ptr; - oset : sigset_t_ptr) return int; - pragma Import (C, pthread_sigmask, "sigprocmask"); - - type t_id is new long; - subtype Thread_Id is t_id; - - function kill (pid : t_id; sig : Signal) return int; - pragma Import (C, kill, "kill"); - - -- VxWorks doesn't have getpid; taskIdSelf is the equivalent - -- routine. - function getpid return t_id; - pragma Import (C, getpid, "taskIdSelf"); - - ---------- - -- Time -- - ---------- - - type time_t is new unsigned_long; - - type timespec is record - ts_sec : time_t; - ts_nsec : long; - end record; - pragma Convention (C, timespec); - - type clockid_t is private; - - CLOCK_REALTIME : constant clockid_t; -- System wide realtime clock - - function To_Duration (TS : timespec) return Duration; - pragma Inline (To_Duration); - - function To_Timespec (D : Duration) return timespec; - pragma Inline (To_Timespec); - - function To_Clock_Ticks (D : Duration) return int; - -- Convert a duration value (in seconds) into clock ticks. - - function clock_gettime - (clock_id : clockid_t; tp : access timespec) return int; - pragma Import (C, clock_gettime, "clock_gettime"); - - type ULONG is new unsigned_long; - - procedure tickSet (ticks : ULONG); - pragma Import (C, tickSet, "tickSet"); - - function tickGet return ULONG; - pragma Import (C, tickGet, "tickGet"); - - ----------------------------------------------------- - -- Convenience routine to convert between VxWorks -- - -- priority and Ada priority. -- - ----------------------------------------------------- - - function To_VxWorks_Priority (Priority : in int) return int; - pragma Inline (To_VxWorks_Priority); - - -------------------------- - -- VxWorks specific API -- - -------------------------- - - subtype STATUS is int; - -- Equivalent of the C type STATUS - - OK : constant STATUS := 0; - ERROR : constant STATUS := Interfaces.C.int (-1); - - function taskIdVerify (tid : t_id) return STATUS; - pragma Import (C, taskIdVerify, "taskIdVerify"); - - function taskIdSelf return t_id; - pragma Import (C, taskIdSelf, "taskIdSelf"); - - function taskSuspend (tid : t_id) return int; - pragma Import (C, taskSuspend, "taskSuspend"); - - function taskResume (tid : t_id) return int; - pragma Import (C, taskResume, "taskResume"); - - function taskIsSuspended (tid : t_id) return int; - pragma Import (C, taskIsSuspended, "taskIsSuspended"); - - function taskVarAdd - (tid : t_id; pVar : access System.Address) return int; - pragma Import (C, taskVarAdd, "taskVarAdd"); - - function taskVarDelete - (tid : t_id; pVar : access System.Address) return int; - pragma Import (C, taskVarDelete, "taskVarDelete"); - - function taskVarSet - (tid : t_id; - pVar : access System.Address; - value : System.Address) return int; - pragma Import (C, taskVarSet, "taskVarSet"); - - function taskVarGet - (tid : t_id; - pVar : access System.Address) return int; - pragma Import (C, taskVarGet, "taskVarGet"); - - function taskDelay (ticks : int) return int; - procedure taskDelay (ticks : int); - pragma Import (C, taskDelay, "taskDelay"); - - function sysClkRateGet return int; - pragma Import (C, sysClkRateGet, "sysClkRateGet"); - - -- Option flags for taskSpawn - - VX_UNBREAKABLE : constant := 16#0002#; - VX_FP_TASK : constant := 16#0008#; - VX_FP_PRIVATE_ENV : constant := 16#0080#; - VX_NO_STACK_FILL : constant := 16#0100#; - - function taskSpawn - (name : System.Address; -- Pointer to task name - priority : int; - options : int; - stacksize : size_t; - start_routine : System.Address; - arg1 : System.Address; - arg2 : int := 0; - arg3 : int := 0; - arg4 : int := 0; - arg5 : int := 0; - arg6 : int := 0; - arg7 : int := 0; - arg8 : int := 0; - arg9 : int := 0; - arg10 : int := 0) return t_id; - pragma Import (C, taskSpawn, "taskSpawn"); - - procedure taskDelete (tid : t_id); - pragma Import (C, taskDelete, "taskDelete"); - - function kernelTimeSlice (ticks : int) return int; - pragma Import (C, kernelTimeSlice, "kernelTimeSlice"); - - function taskPrioritySet - (tid : t_id; newPriority : int) return int; - pragma Import (C, taskPrioritySet, "taskPrioritySet"); - - -- Semaphore creation flags. - - SEM_Q_FIFO : constant := 0; - SEM_Q_PRIORITY : constant := 1; - SEM_DELETE_SAFE : constant := 4; -- only valid for binary semaphore - SEM_INVERSION_SAFE : constant := 8; -- only valid for binary semaphore - - -- Semaphore initial state flags - - SEM_EMPTY : constant := 0; - SEM_FULL : constant := 1; - - -- Semaphore take (semTake) time constants. - - WAIT_FOREVER : constant := -1; - NO_WAIT : constant := 0; - - -- Error codes (errno). The lower level 16 bits are the - -- error code, with the upper 16 bits representing the - -- module number in which the error occurred. By convention, - -- the module number is 0 for UNIX errors. VxWorks reserves - -- module numbers 1-500, with the remaining module numbers - -- being available for user applications. - - M_objLib : constant := 61 * 2**16; - -- semTake() failure with ticks = NO_WAIT - S_objLib_OBJ_UNAVAILABLE : constant := M_objLib + 2; - -- semTake() timeout with ticks > NO_WAIT - S_objLib_OBJ_TIMEOUT : constant := M_objLib + 4; - - type SEM_ID is new System.Address; - -- typedef struct semaphore *SEM_ID; - - -- We use two different kinds of VxWorks semaphores: mutex - -- and binary semaphores. A null ID is returned when - -- a semaphore cannot be created. - - function semBCreate (options : int; initial_state : int) return SEM_ID; - -- Create a binary semaphore. Return ID, or 0 if memory could not - -- be allocated. - pragma Import (C, semBCreate, "semBCreate"); - - function semMCreate (options : int) return SEM_ID; - pragma Import (C, semMCreate, "semMCreate"); - - function semDelete (Sem : SEM_ID) return int; - -- Delete a semaphore - pragma Import (C, semDelete, "semDelete"); - - function semGive (Sem : SEM_ID) return int; - pragma Import (C, semGive, "semGive"); - - function semTake (Sem : SEM_ID; timeout : int) return int; - -- Attempt to take binary semaphore. Error is returned if operation - -- times out - pragma Import (C, semTake, "semTake"); - - function semFlush (SemID : SEM_ID) return STATUS; - -- Release all threads blocked on the semaphore - pragma Import (C, semFlush, "semFlush"); - - function taskLock return int; - pragma Import (C, taskLock, "taskLock"); - - function taskUnlock return int; - pragma Import (C, taskUnlock, "taskUnlock"); - -private - type sigset_t is new long; - - type pid_t is new int; - - ERROR_PID : constant pid_t := -1; - - type clockid_t is new int; - CLOCK_REALTIME : constant clockid_t := 0; - -end System.OS_Interface; diff --git a/gcc/ada/5zosprim.adb b/gcc/ada/5zosprim.adb deleted file mode 100644 index 0f32bbe6dce..00000000000 --- a/gcc/ada/5zosprim.adb +++ /dev/null @@ -1,161 +0,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-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 version is for VxWorks targets - -with System.OS_Interface; --- Since the thread library is part of the VxWorks kernel, using OS_Interface --- is not a problem here, as long as we only use System.OS_Interface as a --- set of C imported routines: using Ada routines from this package would --- create a dependency on libgnarl in libgnat, which is not desirable. - -with Interfaces.C; --- used for type int - -package body System.OS_Primitives is - - use System.OS_Interface; - use type Interfaces.C.int; - - -------------------------- - -- Internal functions -- - -------------------------- - - function To_Clock_Ticks (D : Duration) return int; - -- Convert a duration value (in seconds) into clock ticks. - -- Note that this routine is duplicated from System.OS_Interface since - -- as explained above, we do not want to depend on libgnarl - - function To_Clock_Ticks (D : Duration) return int is - Ticks : Long_Long_Integer; - Rate_Duration : Duration; - Ticks_Duration : Duration; - - begin - if D < 0.0 then - return -1; - end if; - - -- Ensure that the duration can be converted to ticks - -- at the current clock tick rate without overflowing. - - Rate_Duration := Duration (sysClkRateGet); - - if D > (Duration'Last / Rate_Duration) then - Ticks := Long_Long_Integer (int'Last); - else - Ticks_Duration := D * Rate_Duration; - Ticks := Long_Long_Integer (Ticks_Duration); - - if Ticks_Duration > Duration (Ticks) then - Ticks := Ticks + 1; - end if; - - if Ticks > Long_Long_Integer (int'Last) then - Ticks := Long_Long_Integer (int'Last); - end if; - end if; - - return int (Ticks); - end To_Clock_Ticks; - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - TS : aliased timespec; - Result : int; - - use type Interfaces.C.int; - - begin - Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); - pragma Assert (Result = 0); - return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; - end Clock; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration renames Clock; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Rel_Time : Duration; - Abs_Time : Duration; - Check_Time : Duration := Clock; - Ticks : int; - - Result : int; - 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 - Ticks := To_Clock_Ticks (Rel_Time); - - if Mode = Relative and then Ticks < int'Last then - -- The first tick will delay anytime between 0 and - -- 1 / sysClkRateGet seconds, so we need to add one to - -- be on the safe side. - - Ticks := Ticks + 1; - end if; - - Result := taskDelay (Ticks); - 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; diff --git a/gcc/ada/5zparame.ads b/gcc/ada/5zparame.ads deleted file mode 100644 index 774280f8307..00000000000 --- a/gcc/ada/5zparame.ads +++ /dev/null @@ -1,203 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2003 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 default VxWorks version of the package.` - --- This package defines some system dependent parameters for GNAT. These --- are values that are referenced by the runtime library and are therefore --- relevant to the target machine. - --- The parameters whose value is defined in the spec are not generally --- expected to be changed. If they are changed, it will be necessary to --- recompile the run-time library. - --- The parameters which are defined by functions can be changed by modifying --- the body of System.Parameters in file s-parame.adb. A change to this body --- requires only rebinding and relinking of the application. - --- Note: do not introduce any pragma Inline statements into this unit, since --- otherwise the relinking and rebinding capability would be deactivated. - -package System.Parameters is -pragma Pure (Parameters); - - --------------------------------------- - -- Task And Stack Allocation Control -- - --------------------------------------- - - type Task_Storage_Size is new Integer; - -- Type used in tasking units for task storage size - - type Size_Type is new Task_Storage_Size; - -- Type used to provide task storage size to runtime - - Unspecified_Size : constant Size_Type := Size_Type'First; - -- Value used to indicate that no size type is set - - subtype Ratio is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Ratio : constant Ratio := Dynamic; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - - function Default_Stack_Size return Size_Type; - -- Default task stack size used if none is specified - - function Minimum_Stack_Size return Size_Type; - -- Minimum task stack size permitted - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type; - -- Given the storage size stored in the TCB, return the Storage_Size - -- value required by the RM for the Storage_Size attribute. The - -- required adjustment is as follows: - -- - -- when Size = Unspecified_Size, return Default_Stack_Size - -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size - -- otherwise return given Size - - Default_Env_Stack_Size : constant Size_Type := 14_336; - -- Assumed size of the environment task, if no other information - -- is available. This value is used when stack checking is - -- enabled and no GNAT_STACK_LIMIT environment variable is set. - -- This value is chosen as the VxWorks default stack size is 20kB, - -- and a little more than 4kB is necessary for the run time. - - Stack_Grows_Down : constant Boolean := True; - -- This constant indicates whether the stack grows up (False) or - -- down (True) in memory as functions are called. It is used for - -- proper implementation of the stack overflow check. - - ---------------------------------------------- - -- Characteristics of types in Interfaces.C -- - ---------------------------------------------- - - long_bits : constant := Long_Integer'Size; - -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this is not true - -- of all targets. For example, in OpenVMS long /= Long_Integer. - - ---------------------------------------------- - -- Behavior of Pragma Finalize_Storage_Only -- - ---------------------------------------------- - - -- Garbage_Collected is a Boolean constant whose value indicates the - -- effect of the pragma Finalize_Storage_Entry on a controlled type. - - -- Garbage_Collected = False - - -- The system releases all storage on program termination only, - -- but not other garbage collection occurs, so finalization calls - -- are ommitted only for outer level onjects can be omitted if - -- pragma Finalize_Storage_Only is used. - - -- Garbage_Collected = True - - -- The system provides full garbage collection, so it is never - -- necessary to release storage for controlled objects for which - -- a pragma Finalize_Storage_Only is used. - - Garbage_Collected : constant Boolean := False; - -- The storage mode for this system (release on program exit) - - --------------------- - -- Tasking Profile -- - --------------------- - - -- In the following sections, constant parameters are defined to - -- allow some optimizations and fine tuning within the tasking run time - -- based on restrictions on the tasking features. - - ---------------------- - -- Locking Strategy -- - ---------------------- - - Single_Lock : constant Boolean := False; - -- Indicates whether a single lock should be used within the tasking - -- run-time to protect internal structures. If True, a single lock - -- will be used, meaning less locking/unlocking operations, but also - -- more global contention. In general, Single_Lock should be set to - -- True on single processor machines, and to False to multi-processor - -- systems, but this can vary from application to application and also - -- depends on the scheduling policy. - - ------------------- - -- Task Abortion -- - ------------------- - - No_Abort : constant Boolean := False; - -- This constant indicates whether abort statements and asynchronous - -- transfer of control (ATC) are disallowed. If set to True, it is - -- assumed that neither construct is used, and the run time does not - -- need to defer/undefer abort and check for pending actions at - -- completion points. A value of True for No_Abort corresponds to: - -- pragma Restrictions (No_Abort_Statements); - -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - - ---------------------- - -- Dynamic Priority -- - ---------------------- - - Dynamic_Priority_Support : constant Boolean := True; - -- This constant indicates whether dynamic changes of task priorities - -- are allowed (True means normal RM mode in which such changes are - -- allowed). In particular, if this is False, then we do not need to - -- poll for pending base priority changes at every abort completion - -- point. A value of False for Dynamic_Priority_Support corresponds - -- to pragma Restrictions (No_Dynamic_Priorities); - - --------------------- - -- Task Attributes -- - --------------------- - - Default_Attribute_Count : constant := 4; - -- Number of pre-allocated Address-sized task attributes stored in the - -- task control block. - - -------------------- - -- Runtime Traces -- - -------------------- - - Runtime_Traces : constant Boolean := False; - -- This constant indicates whether the runtime outputs traces to a - -- predefined output or not (True means that traces are output). - -- See System.Traces for more details. - -end System.Parameters; diff --git a/gcc/ada/5zstchop.adb b/gcc/ada/5zstchop.adb deleted file mode 100644 index b19bb56f274..00000000000 --- a/gcc/ada/5zstchop.adb +++ /dev/null @@ -1,255 +0,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; diff --git a/gcc/ada/5zsystem.ads b/gcc/ada/5zsystem.ads deleted file mode 100644 index 12bbec478ff..00000000000 --- a/gcc/ada/5zsystem.ads +++ /dev/null @@ -1,158 +0,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; diff --git a/gcc/ada/5ztaprop.adb b/gcc/ada/5ztaprop.adb deleted file mode 100644 index 8bbbf0e13b0..00000000000 --- a/gcc/ada/5ztaprop.adb +++ /dev/null @@ -1,1144 +0,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 . O P E R A T I O N S -- --- -- --- 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 VxWorks version of this package - --- This package contains all the GNULL primitives that interface directly --- with the underlying OS. - -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.Tasking.Debug; --- used for Known_Tasks - -with System.Interrupt_Management; --- used for Keep_Unmasked --- Abort_Task_Signal --- Signal_ID --- Initialize_Interrupts - -with System.Soft_Links; --- used for Defer/Undefer_Abort - --- Note that we do not use System.Tasking.Initialization directly since --- this is a higher level package that we shouldn't depend on. For example --- when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Initialization - -with System.OS_Interface; --- used for various type, constant, and operations - -with System.Parameters; --- used for Size_Type - -with System.Tasking; --- used for Ada_Task_Control_Block --- Task_ID --- ATCB components and types - -with Interfaces.C; - -with Unchecked_Conversion; -with Unchecked_Deallocation; - -package body System.Task_Primitives.Operations is - - use System.Tasking.Debug; - use System.Tasking; - use System.OS_Interface; - use System.Parameters; - use type Interfaces.C.int; - - package SSL renames System.Soft_Links; - - subtype int is System.OS_Interface.int; - - Relative : constant := 0; - - ---------------- - -- Local Data -- - ---------------- - - -- The followings are logically constants, but need to be initialized - -- at run time. - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - - ATCB_Key : aliased System.Address := System.Null_Address; - -- Key used to find the Ada Task_ID associated with a thread - - ATCB_Key_Addr : System.Address := ATCB_Key'Address; - pragma Export (Ada, ATCB_Key_Addr, "__gnat_ATCB_key_addr"); - -- Exported to support the temporary AE653 task registration - -- implementation. This mechanism is used to minimize impact on other - -- targets. - - Environment_Task_ID : Task_ID; - -- A variable to hold Task_ID for the environment task. - - Unblocked_Signal_Mask : aliased sigset_t; - -- The set of signals that should unblocked in all tasks - - -- The followings are internal configuration constants needed. - - Time_Slice_Val : Integer; - pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - - Locking_Policy : Character; - pragma Import (C, Locking_Policy, "__gl_locking_policy"); - - Dispatching_Policy : Character; - pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - - FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; - -- Indicates whether FIFO_Within_Priorities is set. - - Mutex_Protocol : Priority_Type; - - Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads). - - -------------------- - -- Local Packages -- - -------------------- - - package Specific is - - function Is_Valid_Task return Boolean; - pragma Inline (Is_Valid_Task); - -- Does executing thread have a TCB? - - procedure Set (Self_Id : Task_ID); - pragma Inline (Set); - -- Set the self id for the current task. - - function Self return Task_ID; - pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task. - - end Specific; - - package body Specific is separate; - -- The body of this package is target specific. - - --------------------------------- - -- Support for foreign threads -- - --------------------------------- - - function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; - -- Allocate and Initialize a new ATCB for the current Thread. - - function Register_Foreign_Thread - (Thread : Thread_Id) return Task_ID is separate; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Abort_Handler (signo : Signal); - -- Handler for the abort (SIGABRT) signal to handle asynchronous abortion. - - procedure Install_Signal_Handlers; - -- Install the default signal handlers for the current task - - function To_Address is new Unchecked_Conversion (Task_ID, System.Address); - - ------------------- - -- Abort_Handler -- - ------------------- - - procedure Abort_Handler (signo : Signal) is - pragma Unreferenced (signo); - - Self_ID : constant Task_ID := Self; - Result : int; - Old_Set : aliased sigset_t; - - begin - -- It is not safe to raise an exception when using ZCX and the GCC - -- exception handling mechanism. - - if ZCX_By_Default and then GCC_ZCX_Support then - return; - end if; - - if Self_ID.Deferral_Level = 0 - and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - and then not Self_ID.Aborting - then - Self_ID.Aborting := True; - - -- Make sure signals used for RTS internal purpose are unmasked - - Result := pthread_sigmask (SIG_UNBLOCK, - Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); - pragma Assert (Result = 0); - - raise Standard'Abort_Signal; - end if; - end Abort_Handler; - - ----------------- - -- Stack_Guard -- - ----------------- - - procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is - pragma Unreferenced (T); - pragma Unreferenced (On); - - begin - -- Nothing needed (why not???) - - null; - end Stack_Guard; - - ------------------- - -- Get_Thread_Id -- - ------------------- - - function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_ID renames Specific.Self; - - ----------------------------- - -- Install_Signal_Handlers -- - ----------------------------- - - procedure Install_Signal_Handlers is - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - Tmp_Set : aliased sigset_t; - Result : int; - - begin - act.sa_flags := 0; - act.sa_handler := Abort_Handler'Address; - - Result := sigemptyset (Tmp_Set'Access); - pragma Assert (Result = 0); - act.sa_mask := Tmp_Set; - - Result := - sigaction - (Signal (Interrupt_Management.Abort_Task_Signal), - act'Unchecked_Access, - old_act'Unchecked_Access); - pragma Assert (Result = 0); - - Interrupt_Management.Initialize_Interrupts; - end Install_Signal_Handlers; - - --------------------- - -- Initialize_Lock -- - --------------------- - - procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is - begin - L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); - L.Prio_Ceiling := int (Prio); - L.Protocol := Mutex_Protocol; - pragma Assert (L.Mutex /= 0); - end Initialize_Lock; - - procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is - pragma Unreferenced (Level); - - begin - L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); - L.Prio_Ceiling := int (System.Any_Priority'Last); - L.Protocol := Mutex_Protocol; - pragma Assert (L.Mutex /= 0); - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : access Lock) is - Result : int; - - begin - Result := semDelete (L.Mutex); - pragma Assert (Result = 0); - end Finalize_Lock; - - procedure Finalize_Lock (L : access RTS_Lock) is - Result : int; - - begin - Result := semDelete (L.Mutex); - pragma Assert (Result = 0); - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - Result : int; - - begin - if L.Protocol = Prio_Protect - and then int (Self.Common.Current_Priority) > L.Prio_Ceiling - then - Ceiling_Violation := True; - return; - else - Ceiling_Violation := False; - end if; - - Result := semTake (L.Mutex, WAIT_FOREVER); - pragma Assert (Result = 0); - end Write_Lock; - - procedure Write_Lock - (L : access RTS_Lock; - Global_Lock : Boolean := False) - is - Result : int; - - begin - if not Single_Lock or else Global_Lock then - Result := semTake (L.Mutex, WAIT_FOREVER); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - procedure Write_Lock (T : Task_ID) is - Result : int; - - begin - if not Single_Lock then - Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - begin - Write_Lock (L, Ceiling_Violation); - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : access Lock) is - Result : int; - - begin - Result := semGive (L.Mutex); - pragma Assert (Result = 0); - end Unlock; - - procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is - Result : int; - - begin - if not Single_Lock or else Global_Lock then - Result := semGive (L.Mutex); - pragma Assert (Result = 0); - end if; - end Unlock; - - procedure Unlock (T : Task_ID) is - Result : int; - - begin - if not Single_Lock then - Result := semGive (T.Common.LL.L.Mutex); - pragma Assert (Result = 0); - end if; - end Unlock; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is - pragma Unreferenced (Reason); - - Result : int; - - begin - pragma Assert (Self_ID = Self); - - -- Release the mutex before sleeping. - if Single_Lock then - Result := semGive (Single_RTS_Lock.Mutex); - else - Result := semGive (Self_ID.Common.LL.L.Mutex); - end if; - - pragma Assert (Result = 0); - - -- Perform a blocking operation to take the CV semaphore. - -- Note that a blocking operation in VxWorks will reenable - -- task scheduling. When we are no longer blocked and control - -- is returned, task scheduling will again be disabled. - - Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER); - pragma Assert (Result = 0); - - -- Take the mutex back. - if Single_Lock then - Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); - else - Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); - end if; - - pragma Assert (Result = 0); - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - -- This is for use within the run-time system, so abort is - -- assumed to be already deferred, and the caller should be - -- holding its own ATCB lock. - - procedure Timed_Sleep - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : System.Tasking.Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Unreferenced (Reason); - - Orig : constant Duration := Monotonic_Clock; - Absolute : Duration; - Ticks : int; - Result : int; - Wakeup : Boolean := False; - - begin - Timedout := False; - Yielded := True; - - if Mode = Relative then - Absolute := Orig + Time; - - -- Systematically add one since the first tick will delay - -- *at most* 1 / Rate_Duration seconds, so we need to add one to - -- be on the safe side. - - Ticks := To_Clock_Ticks (Time); - - if Ticks > 0 and then Ticks < int'Last then - Ticks := Ticks + 1; - end if; - - else - Absolute := Time; - Ticks := To_Clock_Ticks (Time - Monotonic_Clock); - end if; - - if Ticks > 0 then - loop - -- Release the mutex before sleeping. - if Single_Lock then - Result := semGive (Single_RTS_Lock.Mutex); - else - Result := semGive (Self_ID.Common.LL.L.Mutex); - end if; - - pragma Assert (Result = 0); - - -- Perform a blocking operation to take the CV semaphore. - -- Note that a blocking operation in VxWorks will reenable - -- task scheduling. When we are no longer blocked and control - -- is returned, task scheduling will again be disabled. - - Result := semTake (Self_ID.Common.LL.CV, Ticks); - - if Result = 0 then - -- Somebody may have called Wakeup for us - - Wakeup := True; - - else - if errno /= S_objLib_OBJ_TIMEOUT then - Wakeup := True; - else - -- If Ticks = int'last, it was most probably truncated - -- so let's make another round after recomputing Ticks - -- from the the absolute time. - - if Ticks /= int'Last then - Timedout := True; - else - Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); - - if Ticks < 0 then - Timedout := True; - end if; - end if; - end if; - end if; - - -- Take the mutex back. - if Single_Lock then - Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); - else - Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); - end if; - - pragma Assert (Result = 0); - - exit when Timedout or Wakeup; - end loop; - - else - Timedout := True; - - -- Should never hold a lock while yielding. - if Single_Lock then - Result := semGive (Single_RTS_Lock.Mutex); - taskDelay (0); - Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); - - else - Result := semGive (Self_ID.Common.LL.L.Mutex); - taskDelay (0); - Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); - end if; - end if; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - -- This is for use in implementing delay statements, so - -- we assume the caller is holding no locks. - - procedure Timed_Delay - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes) - is - Orig : constant Duration := Monotonic_Clock; - Absolute : Duration; - Ticks : int; - Timedout : Boolean; - Result : int; - Aborted : Boolean := False; - - begin - SSL.Abort_Defer.all; - - if Mode = Relative then - Absolute := Orig + Time; - Ticks := To_Clock_Ticks (Time); - - if Ticks > 0 and then Ticks < int'Last then - - -- The first tick will delay anytime between 0 and - -- 1 / sysClkRateGet seconds, so we need to add one to - -- be on the safe side. - - Ticks := Ticks + 1; - end if; - - else - Absolute := Time; - Ticks := To_Clock_Ticks (Time - Orig); - end if; - - if Ticks > 0 then - -- Modifying State and Pending_Priority_Change, locking the TCB. - if Single_Lock then - Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); - else - Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); - end if; - - pragma Assert (Result = 0); - - Self_ID.Common.State := Delay_Sleep; - Timedout := False; - - loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - - Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - -- Release the TCB before sleeping - - if Single_Lock then - Result := semGive (Single_RTS_Lock.Mutex); - else - Result := semGive (Self_ID.Common.LL.L.Mutex); - end if; - pragma Assert (Result = 0); - - exit when Aborted; - - Result := semTake (Self_ID.Common.LL.CV, Ticks); - - if Result /= 0 then - -- If Ticks = int'last, it was most probably truncated - -- so let's make another round after recomputing Ticks - -- from the the absolute time. - - if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then - Timedout := True; - else - Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); - - if Ticks < 0 then - Timedout := True; - end if; - end if; - end if; - - -- Take back the lock after having slept, to protect further - -- access to Self_ID - - if Single_Lock then - Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); - else - Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); - end if; - - pragma Assert (Result = 0); - - exit when Timedout; - end loop; - - Self_ID.Common.State := Runnable; - - if Single_Lock then - Result := semGive (Single_RTS_Lock.Mutex); - else - Result := semGive (Self_ID.Common.LL.L.Mutex); - end if; - - else - taskDelay (0); - end if; - - SSL.Abort_Undefer.all; - end Timed_Delay; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration is - TS : aliased timespec; - Result : int; - - begin - Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); - pragma Assert (Result = 0); - return To_Duration (TS); - end Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - begin - return 1.0 / Duration (sysClkRateGet); - end RT_Resolution; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is - pragma Unreferenced (Reason); - - Result : int; - - begin - Result := semGive (T.Common.LL.CV); - pragma Assert (Result = 0); - end Wakeup; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - pragma Unreferenced (Do_Yield); - Result : int; - pragma Unreferenced (Result); - begin - Result := taskDelay (0); - end Yield; - - ------------------ - -- Set_Priority -- - ------------------ - - type Prio_Array_Type is array (System.Any_Priority) of Integer; - pragma Atomic_Components (Prio_Array_Type); - - Prio_Array : Prio_Array_Type; - -- Global array containing the id of the currently running task for - -- each priority. Note that we assume that we are on a single processor - -- with run-till-blocked scheduling. - - procedure Set_Priority - (T : Task_ID; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) - is - Array_Item : Integer; - Result : int; - - begin - Result := - taskPrioritySet - (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio))); - pragma Assert (Result = 0); - - if FIFO_Within_Priorities then - - -- Annex D requirement [RM D.2.2 par. 9]: - -- If the task drops its priority due to the loss of inherited - -- priority, it is added at the head of the ready queue for its - -- new active priority. - - if Loss_Of_Inheritance - and then Prio < T.Common.Current_Priority - then - Array_Item := Prio_Array (T.Common.Base_Priority) + 1; - Prio_Array (T.Common.Base_Priority) := Array_Item; - - loop - -- Give some processes a chance to arrive - - taskDelay (0); - - -- Then wait for our turn to proceed - - exit when Array_Item = Prio_Array (T.Common.Base_Priority) - or else Prio_Array (T.Common.Base_Priority) = 1; - end loop; - - Prio_Array (T.Common.Base_Priority) := - Prio_Array (T.Common.Base_Priority) - 1; - end if; - end if; - - T.Common.Current_Priority := Prio; - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_ID) return System.Any_Priority is - begin - return T.Common.Current_Priority; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (Self_ID : Task_ID) is - procedure Init_Float; - pragma Import (C, Init_Float, "__gnat_init_float"); - -- Properly initializes the FPU for PPC/MIPS systems. - - begin - Self_ID.Common.LL.Thread := taskIdSelf; - Specific.Set (Self_ID); - - Init_Float; - - -- Install the signal handlers. - -- This is called for each task since there is no signal inheritance - -- between VxWorks tasks. - - Install_Signal_Handlers; - - Lock_RTS; - - for J in Known_Tasks'Range loop - if Known_Tasks (J) = null then - Known_Tasks (J) := Self_ID; - Self_ID.Known_Tasks_Index := J; - exit; - end if; - end loop; - - Unlock_RTS; - end Enter_Task; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_ID is - begin - if Is_Valid_Task then - return Self; - else - return Register_Foreign_Thread (taskIdSelf); - end if; - end Register_Foreign_Thread; - - -------------------- - -- Initialize_TCB -- - -------------------- - - procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is - begin - Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY); - Self_ID.Common.LL.Thread := 0; - - if Self_ID.Common.LL.CV = 0 then - Succeeded := False; - else - Succeeded := True; - - if not Single_Lock then - Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); - end if; - end if; - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_ID; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - Adjusted_Stack_Size : size_t; - begin - if Stack_Size = Unspecified_Size then - Adjusted_Stack_Size := size_t (Default_Stack_Size); - - elsif Stack_Size < Minimum_Stack_Size then - Adjusted_Stack_Size := size_t (Minimum_Stack_Size); - - else - Adjusted_Stack_Size := size_t (Stack_Size); - end if; - - -- Ask for 4 extra bytes of stack space so that the ATCB - -- pointer can be stored below the stack limit, plus extra - -- space for the frame of Task_Wrapper. This is so the user - -- gets the amount of stack requested exclusive of the needs - -- of the runtime. - -- - -- We also have to allocate n more bytes for the task name - -- storage and enough space for the Wind Task Control Block - -- which is around 0x778 bytes. VxWorks also seems to carve out - -- additional space, so use 2048 as a nice round number. - -- We might want to increment to the nearest page size in - -- case we ever support VxVMI. - -- - -- XXX - we should come back and visit this so we can - -- set the task name to something appropriate. - - Adjusted_Stack_Size := Adjusted_Stack_Size + 2048; - - -- Since the initial signal mask of a thread is inherited from the - -- creator, and the Environment task has all its signals masked, we - -- do not need to manipulate caller's signal mask at this point. - -- All tasks in RTS will have All_Tasks_Mask initially. - - if T.Common.Task_Image_Len = 0 then - T.Common.LL.Thread := taskSpawn - (System.Null_Address, - To_VxWorks_Priority (int (Priority)), - VX_FP_TASK, - Adjusted_Stack_Size, - Wrapper, - To_Address (T)); - else - declare - Name : aliased String (1 .. T.Common.Task_Image_Len + 1); - begin - Name (1 .. Name'Last - 1) := - T.Common.Task_Image (1 .. T.Common.Task_Image_Len); - Name (Name'Last) := ASCII.NUL; - - T.Common.LL.Thread := taskSpawn - (Name'Address, - To_VxWorks_Priority (int (Priority)), - VX_FP_TASK, - Adjusted_Stack_Size, - Wrapper, - To_Address (T)); - end; - end if; - - if T.Common.LL.Thread = -1 then - Succeeded := False; - else - Succeeded := True; - end if; - - Task_Creation_Hook (T.Common.LL.Thread); - Set_Priority (T, Priority); - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_ID) is - Result : int; - Tmp : Task_ID := T; - Is_Self : constant Boolean := (T = Self); - - procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); - - begin - if not Single_Lock then - Result := semDelete (T.Common.LL.L.Mutex); - pragma Assert (Result = 0); - end if; - - T.Common.LL.Thread := 0; - - Result := semDelete (T.Common.LL.CV); - pragma Assert (Result = 0); - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - Free (Tmp); - - if Is_Self then - Result := taskVarDelete (taskIdSelf, ATCB_Key'Access); - pragma Assert (Result /= ERROR); - end if; - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - procedure Exit_Task is - begin - Specific.Set (null); - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_ID) is - Result : int; - - begin - Result := kill (T.Common.LL.Thread, - Signal (Interrupt_Management.Abort_Task_Signal)); - pragma Assert (Result = 0); - end Abort_Task; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy version - - function Check_Exit (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - - begin - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is - pragma Unreferenced (Self_ID); - - begin - return True; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_ID is - begin - return Environment_Task_ID; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean - is - begin - if T.Common.LL.Thread /= 0 - and then T.Common.LL.Thread /= Thread_Self - then - return taskSuspend (T.Common.LL.Thread) = 0; - else - return True; - end if; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean - is - begin - if T.Common.LL.Thread /= 0 - and then T.Common.LL.Thread /= Thread_Self - then - return taskResume (T.Common.LL.Thread) = 0; - else - return True; - end if; - end Resume_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_ID) is - Result : int; - - begin - if Locking_Policy = 'C' then - Mutex_Protocol := Prio_Protect; - elsif Locking_Policy = 'I' then - Mutex_Protocol := Prio_Inherit; - else - Mutex_Protocol := Prio_None; - end if; - - if Time_Slice_Val > 0 then - Result := kernelTimeSlice - (To_Clock_Ticks - (Duration (Time_Slice_Val) / Duration (1_000_000.0))); - end if; - - Result := sigemptyset (Unblocked_Signal_Mask'Access); - pragma Assert (Result = 0); - - for J in Interrupt_Management.Signal_ID loop - if System.Interrupt_Management.Keep_Unmasked (J) then - Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); - pragma Assert (Result = 0); - end if; - end loop; - - Environment_Task_ID := Environment_Task; - - -- Initialize the lock used to synchronize chain of all ATCBs. - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - - Enter_Task (Environment_Task); - end Initialize; - -end System.Task_Primitives.Operations; diff --git a/gcc/ada/5ztaspri.ads b/gcc/ada/5ztaspri.ads deleted file mode 100644 index efd41ccd984..00000000000 --- a/gcc/ada/5ztaspri.ads +++ /dev/null @@ -1,95 +0,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; diff --git a/gcc/ada/5ztfsetr.adb b/gcc/ada/5ztfsetr.adb deleted file mode 100644 index 0cd3d1b1107..00000000000 --- a/gcc/ada/5ztfsetr.adb +++ /dev/null @@ -1,107 +0,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; diff --git a/gcc/ada/5ztpopsp.adb b/gcc/ada/5ztpopsp.adb deleted file mode 100644 index 02983287d2c..00000000000 --- a/gcc/ada/5ztpopsp.adb +++ /dev/null @@ -1,74 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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 a VxWorks version of this package where foreign threads are --- recognized. - -separate (System.Task_Primitives.Operations) -package body Specific is - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean is - begin - return taskVarGet (taskIdSelf, ATCB_Key'Access) /= ERROR; - end Is_Valid_Task; - - --------- - -- Set -- - --------- - - procedure Set (Self_Id : Task_ID) is - Result : STATUS; - - begin - if taskVarGet (0, ATCB_Key'Access) = ERROR then - Result := taskVarAdd (0, ATCB_Key'Access); - pragma Assert (Result = OK); - end if; - - ATCB_Key := To_Address (Self_Id); - end Set; - - ---------- - -- Self -- - ---------- - - function Self return Task_ID is - begin - return To_Task_ID (ATCB_Key); - end Self; - -end Specific; diff --git a/gcc/ada/6vcpp.adb b/gcc/ada/6vcpp.adb deleted file mode 100644 index a0a8a49962e..00000000000 --- a/gcc/ada/6vcpp.adb +++ /dev/null @@ -1,346 +0,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; diff --git a/gcc/ada/6vcstrea.adb b/gcc/ada/6vcstrea.adb deleted file mode 100644 index 75b35966021..00000000000 --- a/gcc/ada/6vcstrea.adb +++ /dev/null @@ -1,255 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . C _ S T R E A M S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-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; diff --git a/gcc/ada/6vinterf.ads b/gcc/ada/6vinterf.ads deleted file mode 100644 index e4c39108cc9..00000000000 --- a/gcc/ada/6vinterf.ads +++ /dev/null @@ -1,194 +0,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; diff --git a/gcc/ada/7sinmaop.adb b/gcc/ada/7sinmaop.adb deleted file mode 100644 index 8fe6b3a89bd..00000000000 --- a/gcc/ada/7sinmaop.adb +++ /dev/null @@ -1,359 +0,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; diff --git a/gcc/ada/7sintman.adb b/gcc/ada/7sintman.adb deleted file mode 100644 index 801adac39f2..00000000000 --- a/gcc/ada/7sintman.adb +++ /dev/null @@ -1,285 +0,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; diff --git a/gcc/ada/7sosinte.adb b/gcc/ada/7sosinte.adb deleted file mode 100644 index b646a789b50..00000000000 --- a/gcc/ada/7sosinte.adb +++ /dev/null @@ -1,366 +0,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; diff --git a/gcc/ada/7sosprim.adb b/gcc/ada/7sosprim.adb deleted file mode 100644 index c4a7a112380..00000000000 --- a/gcc/ada/7sosprim.adb +++ /dev/null @@ -1,159 +0,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; diff --git a/gcc/ada/7staprop.adb b/gcc/ada/7staprop.adb deleted file mode 100644 index f5bc6174ccb..00000000000 --- a/gcc/ada/7staprop.adb +++ /dev/null @@ -1,1212 +0,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 . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-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 a POSIX-like version of this package - --- This package contains all the GNULL primitives that interface directly --- with the underlying OS. - --- Note: this file can only be used for POSIX compliant systems that --- implement SCHED_FIFO and Ceiling Locking correctly. - --- For configurations where SCHED_FIFO and priority ceiling are not a --- requirement, this file can also be used (e.g AiX threads) - -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.Tasking.Debug; --- used for Known_Tasks - -with System.Task_Info; --- used for Task_Info_Type - -with Interfaces.C; --- used for int --- size_t - -with System.Interrupt_Management; --- used for Keep_Unmasked --- Abort_Task_Interrupt --- Interrupt_ID - -with System.Interrupt_Management.Operations; --- used for Set_Interrupt_Mask --- All_Tasks_Mask -pragma Elaborate_All (System.Interrupt_Management.Operations); - -with System.Parameters; --- used for Size_Type - -with System.Tasking; --- used for Ada_Task_Control_Block --- Task_ID - -with System.Soft_Links; --- used for Defer/Undefer_Abort - --- Note that we do not use System.Tasking.Initialization directly since --- this is a higher level package that we shouldn't depend on. For example --- when using the restricted run time, it is replaced by --- System.Tasking.Restricted.Initialization - -with System.OS_Primitives; --- used for Delay_Modes - -with Unchecked_Conversion; -with Unchecked_Deallocation; - -package body System.Task_Primitives.Operations is - - use System.Tasking.Debug; - use System.Tasking; - use Interfaces.C; - use System.OS_Interface; - use System.Parameters; - use System.OS_Primitives; - - package SSL renames System.Soft_Links; - - ---------------- - -- Local Data -- - ---------------- - - -- The followings are logically constants, but need to be initialized - -- at run time. - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_ID associated with a thread - - Environment_Task_ID : Task_ID; - -- A variable to hold Task_ID for the environment task. - - Locking_Policy : Character; - pragma Import (C, Locking_Policy, "__gl_locking_policy"); - -- Value of the pragma Locking_Policy: - -- 'C' for Ceiling_Locking - -- 'I' for Inherit_Locking - -- ' ' for none. - - Unblocked_Signal_Mask : aliased sigset_t; - -- The set of signals that should unblocked in all tasks - - -- The followings are internal configuration constants needed. - - Next_Serial_Number : Task_Serial_Number := 100; - -- We start at 100, to reserve some special values for - -- using in error checking. - - Time_Slice_Val : Integer; - pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - - Dispatching_Policy : Character; - pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - - FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; - -- Indicates whether FIFO_Within_Priorities is set. - - Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads). - - -------------------- - -- Local Packages -- - -------------------- - - package Specific is - - procedure Initialize (Environment_Task : Task_ID); - pragma Inline (Initialize); - -- Initialize various data needed by this package. - - function Is_Valid_Task return Boolean; - pragma Inline (Is_Valid_Task); - -- Does executing thread have a TCB? - - procedure Set (Self_Id : Task_ID); - pragma Inline (Set); - -- Set the self id for the current task. - - function Self return Task_ID; - pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task. - - end Specific; - - package body Specific is separate; - -- The body of this package is target specific. - - --------------------------------- - -- Support for foreign threads -- - --------------------------------- - - function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; - -- Allocate and Initialize a new ATCB for the current Thread. - - function Register_Foreign_Thread - (Thread : Thread_Id) return Task_ID is separate; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Abort_Handler (Sig : Signal); - -- Signal handler used to implement asynchronous abort. - -- See also comment before body, below. - - function To_Address is new Unchecked_Conversion (Task_ID, System.Address); - - ------------------- - -- Abort_Handler -- - ------------------- - - -- Target-dependent binding of inter-thread Abort signal to - -- the raising of the Abort_Signal exception. - - -- The technical issues and alternatives here are essentially - -- the same as for raising exceptions in response to other - -- signals (e.g. Storage_Error). See code and comments in - -- the package body System.Interrupt_Management. - - -- Some implementations may not allow an exception to be propagated - -- out of a handler, and others might leave the signal or - -- interrupt that invoked this handler masked after the exceptional - -- return to the application code. - - -- GNAT exceptions are originally implemented using setjmp()/longjmp(). - -- On most UNIX systems, this will allow transfer out of a signal handler, - -- which is usually the only mechanism available for implementing - -- asynchronous handlers of this kind. However, some - -- systems do not restore the signal mask on longjmp(), leaving the - -- abort signal masked. - - procedure Abort_Handler (Sig : Signal) is - pragma Warnings (Off, Sig); - - T : constant Task_ID := Self; - Result : Interfaces.C.int; - Old_Set : aliased sigset_t; - - begin - -- It is not safe to raise an exception when using ZCX and the GCC - -- exception handling mechanism. - - if ZCX_By_Default and then GCC_ZCX_Support then - return; - end if; - - if T.Deferral_Level = 0 - and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then - not T.Aborting - then - T.Aborting := True; - - -- Make sure signals used for RTS internal purpose are unmasked - - Result := pthread_sigmask (SIG_UNBLOCK, - Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); - pragma Assert (Result = 0); - - raise Standard'Abort_Signal; - end if; - end Abort_Handler; - - ----------------- - -- Stack_Guard -- - ----------------- - - procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is - Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread); - Guard_Page_Address : Address; - - Res : Interfaces.C.int; - - begin - if Stack_Base_Available then - - -- Compute the guard page address - - Guard_Page_Address := - Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size; - - if On then - Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_ON); - else - Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_OFF); - end if; - - pragma Assert (Res = 0); - end if; - end Stack_Guard; - - -------------------- - -- Get_Thread_Id -- - -------------------- - - function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_ID renames Specific.Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - -- Note: mutexes and cond_variables needed per-task basis are - -- initialized in Intialize_TCB and the Storage_Error is - -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) - -- used in RTS is initialized before any status change of RTS. - -- Therefore rasing Storage_Error in the following routines - -- should be able to be handled safely. - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : access Lock) - is - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - if Locking_Policy = 'C' then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_PROTECT); - pragma Assert (Result = 0); - - Result := pthread_mutexattr_setprioceiling - (Attributes'Access, Interfaces.C.int (Prio)); - pragma Assert (Result = 0); - - elsif Locking_Policy = 'I' then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_INHERIT); - pragma Assert (Result = 0); - end if; - - Result := pthread_mutex_init (L, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is - pragma Warnings (Off, Level); - - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - if Locking_Policy = 'C' then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_PROTECT); - pragma Assert (Result = 0); - - Result := pthread_mutexattr_setprioceiling - (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); - pragma Assert (Result = 0); - - elsif Locking_Policy = 'I' then - Result := pthread_mutexattr_setprotocol - (Attributes'Access, PTHREAD_PRIO_INHERIT); - pragma Assert (Result = 0); - end if; - - Result := pthread_mutex_init (L, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Attributes'Access); - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : access Lock) is - Result : Interfaces.C.int; - - begin - Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0); - end Finalize_Lock; - - procedure Finalize_Lock (L : access RTS_Lock) is - Result : Interfaces.C.int; - - begin - Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0); - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - Result : Interfaces.C.int; - - begin - Result := pthread_mutex_lock (L); - - -- Assume that the cause of EINVAL is a priority ceiling violation - - Ceiling_Violation := (Result = EINVAL); - pragma Assert (Result = 0 or else Result = EINVAL); - end Write_Lock; - - procedure Write_Lock - (L : access RTS_Lock; - Global_Lock : Boolean := False) - is - Result : Interfaces.C.int; - - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_lock (L); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - procedure Write_Lock (T : Task_ID) is - Result : Interfaces.C.int; - - begin - if not Single_Lock then - Result := pthread_mutex_lock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is - begin - Write_Lock (L, Ceiling_Violation); - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : access Lock) is - Result : Interfaces.C.int; - - begin - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); - end Unlock; - - procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is - Result : Interfaces.C.int; - - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); - end if; - end Unlock; - - procedure Unlock (T : Task_ID) is - Result : Interfaces.C.int; - - begin - if not Single_Lock then - Result := pthread_mutex_unlock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Unlock; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : Task_ID; - Reason : System.Tasking.Task_States) - is - pragma Warnings (Off, Reason); - - Result : Interfaces.C.int; - - begin - if Single_Lock then - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - else - Result := pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - end if; - - -- EINTR is not considered a failure. - - pragma Assert (Result = 0 or else Result = EINTR); - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - -- This is for use within the run-time system, so abort is - -- assumed to be already deferred, and the caller should be - -- holding its own ATCB lock. - - procedure Timed_Sleep - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Warnings (Off, Reason); - - Check_Time : constant Duration := Monotonic_Clock; - Rel_Time : Duration; - Abs_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - Timedout := True; - Yielded := False; - - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time); - end if; - - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); - end if; - end if; - - if Abs_Time > Check_Time then - if Relative_Timed_Wait then - Request := To_Timespec (Rel_Time); - else - Request := To_Timespec (Abs_Time); - end if; - - loop - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - or else Self_ID.Pending_Priority_Change; - - if Single_Lock then - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, - Request'Access); - - else - Result := pthread_cond_timedwait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, - Request'Access); - end if; - - exit when Abs_Time <= Monotonic_Clock; - - if Result = 0 or Result = EINTR then - - -- Somebody may have called Wakeup for us - - Timedout := False; - exit; - end if; - - pragma Assert (Result = ETIMEDOUT); - end loop; - end if; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - -- This is for use in implementing delay statements, so - -- we assume the caller is abort-deferred but is holding - -- no locks. - - procedure Timed_Delay - (Self_ID : Task_ID; - Time : Duration; - Mode : ST.Delay_Modes) - is - Check_Time : constant Duration := Monotonic_Clock; - Abs_Time : Duration; - Rel_Time : Duration; - Request : aliased timespec; - Result : Interfaces.C.int; - - begin - -- Only the little window between deferring abort and - -- locking Self_ID is the reason we need to - -- check for pending abort and priority change below! :( - - SSL.Abort_Defer.all; - - if Single_Lock then - Lock_RTS; - end if; - - Write_Lock (Self_ID); - - if Mode = Relative then - Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time); - end if; - - else - Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); - - if Relative_Timed_Wait then - Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); - end if; - end if; - - if Abs_Time > Check_Time then - if Relative_Timed_Wait then - Request := To_Timespec (Rel_Time); - else - Request := To_Timespec (Abs_Time); - end if; - - Self_ID.Common.State := Delay_Sleep; - - loop - if Self_ID.Pending_Priority_Change then - Self_ID.Pending_Priority_Change := False; - Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; - Set_Priority (Self_ID, Self_ID.Common.Base_Priority); - end if; - - exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; - - if Single_Lock then - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Single_RTS_Lock'Access, Request'Access); - else - Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, - Self_ID.Common.LL.L'Access, Request'Access); - end if; - - exit when Abs_Time <= Monotonic_Clock; - - pragma Assert (Result = 0 - or else Result = ETIMEDOUT - or else Result = EINTR); - end loop; - - Self_ID.Common.State := Runnable; - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - Result := sched_yield; - SSL.Abort_Undefer.all; - end Timed_Delay; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration is - TS : aliased timespec; - Result : Interfaces.C.int; - - begin - Result := clock_gettime - (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access); - pragma Assert (Result = 0); - return To_Duration (TS); - end Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - begin - return 10#1.0#E-6; - end RT_Resolution; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is - pragma Warnings (Off, Reason); - - Result : Interfaces.C.int; - - begin - Result := pthread_cond_signal (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Wakeup; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - Result : Interfaces.C.int; - pragma Unreferenced (Result); - begin - if Do_Yield then - Result := sched_yield; - end if; - end Yield; - - ------------------ - -- Set_Priority -- - ------------------ - - procedure Set_Priority - (T : Task_ID; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) - is - pragma Warnings (Off, Loss_Of_Inheritance); - - Result : Interfaces.C.int; - Param : aliased struct_sched_param; - - begin - T.Common.Current_Priority := Prio; - Param.sched_priority := Interfaces.C.int (Prio); - - if Time_Slice_Supported and then Time_Slice_Val > 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_RR, Param'Access); - - elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_FIFO, Param'Access); - - else - Result := pthread_setschedparam - (T.Common.LL.Thread, SCHED_OTHER, Param'Access); - end if; - - pragma Assert (Result = 0); - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_ID) return System.Any_Priority is - begin - return T.Common.Current_Priority; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (Self_ID : Task_ID) is - begin - Self_ID.Common.LL.Thread := pthread_self; - Self_ID.Common.LL.LWP := lwp_self; - - Specific.Set (Self_ID); - - Lock_RTS; - - for J in Known_Tasks'Range loop - if Known_Tasks (J) = null then - Known_Tasks (J) := Self_ID; - Self_ID.Known_Tasks_Index := J; - exit; - end if; - end loop; - - Unlock_RTS; - end Enter_Task; - - -------------- - -- New_ATCB -- - -------------- - - function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is - begin - return new Ada_Task_Control_Block (Entry_Num); - end New_ATCB; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_ID is - begin - if Is_Valid_Task then - return Self; - else - return Register_Foreign_Thread (pthread_self); - end if; - end Register_Foreign_Thread; - - -------------------- - -- Initialize_TCB -- - -------------------- - - procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is - Mutex_Attr : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - Cond_Attr : aliased pthread_condattr_t; - - begin - -- Give the task a unique serial number. - - Self_ID.Serial_Number := Next_Serial_Number; - Next_Serial_Number := Next_Serial_Number + 1; - pragma Assert (Next_Serial_Number /= 0); - - if not Single_Lock then - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - if Locking_Policy = 'C' then - Result := pthread_mutexattr_setprotocol - (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT); - pragma Assert (Result = 0); - - Result := pthread_mutexattr_setprioceiling - (Mutex_Attr'Access, - Interfaces.C.int (System.Any_Priority'Last)); - pragma Assert (Result = 0); - - elsif Locking_Policy = 'I' then - Result := pthread_mutexattr_setprotocol - (Mutex_Attr'Access, PTHREAD_PRIO_INHERIT); - pragma Assert (Result = 0); - end if; - - Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, - Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, - Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result = 0 then - Succeeded := True; - else - if not Single_Lock then - Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Succeeded := False; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_ID; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - Attributes : aliased pthread_attr_t; - Adjusted_Stack_Size : Interfaces.C.size_t; - Result : Interfaces.C.int; - - function Thread_Body_Access is new - Unchecked_Conversion (System.Address, Thread_Body); - - use System.Task_Info; - - begin - if Stack_Size = Unspecified_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size); - - elsif Stack_Size < Minimum_Stack_Size then - Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); - - else - Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); - end if; - - if Stack_Base_Available then - -- If Stack Checking is supported then allocate 2 additional pages: - -- - -- In the worst case, stack is allocated at something like - -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages - -- to be sure the effective stack size is greater than what - -- has been asked. - - Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Get_Page_Size; - end if; - - Result := pthread_attr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_attr_setdetachstate - (Attributes'Access, PTHREAD_CREATE_DETACHED); - pragma Assert (Result = 0); - - Result := pthread_attr_setstacksize - (Attributes'Access, Adjusted_Stack_Size); - pragma Assert (Result = 0); - - if T.Common.Task_Info /= Default_Scope then - - -- We are assuming that Scope_Type has the same values than the - -- corresponding C macros - - Result := pthread_attr_setscope - (Attributes'Access, Task_Info_Type'Pos (T.Common.Task_Info)); - pragma Assert (Result = 0); - end if; - - -- Since the initial signal mask of a thread is inherited from the - -- creator, and the Environment task has all its signals masked, we - -- do not need to manipulate caller's signal mask at this point. - -- All tasks in RTS will have All_Tasks_Mask initially. - - Result := pthread_create - (T.Common.LL.Thread'Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); - pragma Assert (Result = 0 or else Result = EAGAIN); - - Succeeded := Result = 0; - - Result := pthread_attr_destroy (Attributes'Access); - pragma Assert (Result = 0); - - Set_Priority (T, Priority); - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_ID) is - Result : Interfaces.C.int; - Tmp : Task_ID := T; - Is_Self : constant Boolean := T = Self; - - procedure Free is new - Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); - - begin - if not Single_Lock then - Result := pthread_mutex_destroy (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_cond_destroy (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - Free (Tmp); - - if Is_Self then - Specific.Set (null); - end if; - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - procedure Exit_Task is - begin - -- Mark this task as unknown, so that if Self is called, it won't - -- return a dangling pointer. - - Specific.Set (null); - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_ID) is - Result : Interfaces.C.int; - - begin - Result := pthread_kill (T.Common.LL.Thread, - Signal (System.Interrupt_Management.Abort_Task_Interrupt)); - pragma Assert (Result = 0); - end Abort_Task; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy version - - function Check_Exit (Self_ID : ST.Task_ID) return Boolean is - pragma Warnings (Off, Self_ID); - - begin - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is - pragma Warnings (Off, Self_ID); - - begin - return True; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_ID is - begin - return Environment_Task_ID; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean - is - pragma Warnings (Off, T); - pragma Warnings (Off, Thread_Self); - - begin - return False; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_ID; - Thread_Self : Thread_Id) - return Boolean - is - pragma Warnings (Off, T); - pragma Warnings (Off, Thread_Self); - - begin - return False; - end Resume_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_ID) is - act : aliased struct_sigaction; - old_act : aliased struct_sigaction; - Tmp_Set : aliased sigset_t; - Result : Interfaces.C.int; - - function State (Int : System.Interrupt_Management.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: - - 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 - Environment_Task_ID := Environment_Task; - - -- Initialize the lock used to synchronize chain of all ATCBs. - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - - Specific.Initialize (Environment_Task); - - Enter_Task (Environment_Task); - - -- Install the abort-signal handler - - if State (System.Interrupt_Management.Abort_Task_Interrupt) - /= Default - then - act.sa_flags := 0; - act.sa_handler := Abort_Handler'Address; - - Result := sigemptyset (Tmp_Set'Access); - pragma Assert (Result = 0); - act.sa_mask := Tmp_Set; - - Result := - sigaction - (Signal (System.Interrupt_Management.Abort_Task_Interrupt), - act'Unchecked_Access, - old_act'Unchecked_Access); - pragma Assert (Result = 0); - end if; - end Initialize; - -begin - declare - Result : Interfaces.C.int; - begin - -- Mask Environment task for all signals. The original mask of the - -- Environment task will be recovered by Interrupt_Server task - -- during the elaboration of s-interr.adb. - - System.Interrupt_Management.Operations.Set_Interrupt_Mask - (System.Interrupt_Management.Operations.All_Tasks_Mask'Access); - - -- Prepare the set of signals that should unblocked in all tasks - - Result := sigemptyset (Unblocked_Signal_Mask'Access); - pragma Assert (Result = 0); - - for J in Interrupt_Management.Interrupt_ID loop - if System.Interrupt_Management.Keep_Unmasked (J) then - Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); - pragma Assert (Result = 0); - end if; - end loop; - end; -end System.Task_Primitives.Operations; diff --git a/gcc/ada/7staspri.ads b/gcc/ada/7staspri.ads deleted file mode 100644 index 1717cce47f5..00000000000 --- a/gcc/ada/7staspri.ads +++ /dev/null @@ -1,92 +0,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; diff --git a/gcc/ada/7stfsetr.adb b/gcc/ada/7stfsetr.adb deleted file mode 100644 index a8e166d04ed..00000000000 --- a/gcc/ada/7stfsetr.adb +++ /dev/null @@ -1,313 +0,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; diff --git a/gcc/ada/7stpopsp.adb b/gcc/ada/7stpopsp.adb deleted file mode 100644 index f7a67a074ca..00000000000 --- a/gcc/ada/7stpopsp.adb +++ /dev/null @@ -1,80 +0,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; diff --git a/gcc/ada/7straceb.adb b/gcc/ada/7straceb.adb deleted file mode 100644 index 1811c5a603b..00000000000 --- a/gcc/ada/7straceb.adb +++ /dev/null @@ -1,113 +0,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; diff --git a/gcc/ada/7straces.adb b/gcc/ada/7straces.adb deleted file mode 100644 index 46822242a40..00000000000 --- a/gcc/ada/7straces.adb +++ /dev/null @@ -1,73 +0,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; diff --git a/gcc/ada/7strafor.adb b/gcc/ada/7strafor.adb deleted file mode 100644 index 8aa564463ad..00000000000 --- a/gcc/ada/7strafor.adb +++ /dev/null @@ -1,113 +0,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; diff --git a/gcc/ada/7strafor.ads b/gcc/ada/7strafor.ads deleted file mode 100644 index fe232beeea8..00000000000 --- a/gcc/ada/7strafor.ads +++ /dev/null @@ -1,62 +0,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; diff --git a/gcc/ada/7stratas.adb b/gcc/ada/7stratas.adb deleted file mode 100644 index 0e18aed2d96..00000000000 --- a/gcc/ada/7stratas.adb +++ /dev/null @@ -1,367 +0,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; diff --git a/gcc/ada/86numaux.adb b/gcc/ada/86numaux.adb deleted file mode 100644 index a13733305a1..00000000000 --- a/gcc/ada/86numaux.adb +++ /dev/null @@ -1,592 +0,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; diff --git a/gcc/ada/86numaux.ads b/gcc/ada/86numaux.ads deleted file mode 100644 index 857499fdfc1..00000000000 --- a/gcc/ada/86numaux.ads +++ /dev/null @@ -1,84 +0,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; diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 4ae1cfda6e7..7ba15df2373 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,147 @@ +2004-05-14 Arnaud Charlet + + 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 * trans.c (gnat_stabilize_reference_1): Remove case 'b'. diff --git a/gcc/ada/Makefile.in b/gcc/ada/Makefile.in index 6b075b8a3d3..a094a82830e 100644 --- a/gcc/ada/Makefile.in +++ b/gcc/ada/Makefile.in @@ -341,13 +341,13 @@ endif # Non-tasking case: LIBGNAT_TARGET_PAIRS = \ -a-intnam.ads<4nintnam.ads \ -s-inmaop.adb<5ninmaop.adb \ -s-intman.adb<5nintman.adb \ -s-osinte.ads<5nosinte.ads \ -s-osprim.adb<7sosprim.adb \ -s-taprop.adb<5ntaprop.adb \ -s-taspri.ads<5ntaspri.ads +a-intnam.ads + raise Time_Error; + end "+"; + + function "+" (Left : Duration; Right : Time) return Time is + pragma Unsuppress (Overflow_Check); + begin + return (Time (Left) + Right); + + exception + when Constraint_Error => + raise Time_Error; + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (Left : Time; Right : Duration) return Time is + pragma Unsuppress (Overflow_Check); + begin + return Left - Time (Right); + + exception + when Constraint_Error => + raise Time_Error; + end "-"; + + function "-" (Left : Time; Right : Time) return Duration is + pragma Unsuppress (Overflow_Check); + begin + return Duration (Left) - Duration (Right); + + exception + when Constraint_Error => + raise Time_Error; + end "-"; + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Time) return Boolean is + begin + return Duration (Left) < Duration (Right); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" (Left, Right : Time) return Boolean is + begin + return Duration (Left) <= Duration (Right); + end "<="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Time) return Boolean is + begin + return Duration (Left) > Duration (Right); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" (Left, Right : Time) return Boolean is + begin + return Duration (Left) >= Duration (Right); + end ">="; + + ----------- + -- Clock -- + ----------- + + -- The Ada.Calendar.Clock function gets the time from the soft links + -- interface which will call the appropriate function depending wether + -- tasking is involved or not. + + function Clock return Time is + begin + return Time (System.OS_Primitives.Clock); + end Clock; + + --------- + -- Day -- + --------- + + function Day (Date : Time) return Day_Number is + DY : Year_Number; + DM : Month_Number; + DD : Day_Number; + DS : Day_Duration; + + begin + Split (Date, DY, DM, DD, DS); + return DD; + end Day; + + ----------- + -- Month -- + ----------- + + function Month (Date : Time) return Month_Number is + DY : Year_Number; + DM : Month_Number; + DD : Day_Number; + DS : Day_Duration; + + begin + Split (Date, DY, DM, DD, DS); + return DM; + end Month; + + ------------- + -- Seconds -- + ------------- + + function Seconds (Date : Time) return Day_Duration is + DY : Year_Number; + DM : Month_Number; + DD : Day_Number; + DS : Day_Duration; + + begin + Split (Date, DY, DM, DD, DS); + return DS; + end Seconds; + + ----------- + -- Split -- + ----------- + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Seconds : out Day_Duration) + is + + Date_Int : aliased Long_Long_Integer; + Date_Loc : aliased Long_Long_Integer; + Timbuf : aliased SYSTEMTIME; + Int_Date : Long_Long_Integer; + Sub_Seconds : Duration; + + begin + -- We take the sub-seconds (decimal part) of Date and this is added + -- to compute the Seconds. This way we keep the precision of the + -- high-precision clock that was lost with the Win32 API calls + -- below. + + if Date < 0.0 then + + -- this is a Date before Epoch (January 1st, 1970) + + Sub_Seconds := Duration (Date) - + Duration (Long_Long_Integer (Date + Duration'(0.5))); + + Int_Date := Long_Long_Integer (Date - Sub_Seconds); + + -- For Date = -86400.1 we are 2 days before Epoch at 0.1 seconds + -- from day 1 before Epoch. It means that it is 23h 59m 59.9s. + -- here we adjust for that. + + if Sub_Seconds < 0.0 then + Int_Date := Int_Date - 1; + Sub_Seconds := 1.0 + Sub_Seconds; + end if; + + else + + -- this is a Date after Epoch (January 1st, 1970) + + Sub_Seconds := Duration (Date) - + Duration (Long_Long_Integer (Date - Duration'(0.5))); + + Int_Date := Long_Long_Integer (Date - Sub_Seconds); + + end if; + + -- Date_Int is the number of seconds from Epoch. + + Date_Int := Long_Long_Integer + (Int_Date * Sec_Unit / system_time_ns) + epoch_1970; + + if not FileTimeToLocalFileTime (Date_Int'Access, Date_Loc'Access) then + raise Time_Error; + end if; + + if not FileTimeToSystemTime (Date_Loc'Access, Timbuf'Access) then + raise Time_Error; + end if; + + if Timbuf.wYear not in Ada_Year_Min .. Ada_Year_Max then + raise Time_Error; + end if; + + Seconds := + Duration (Timbuf.wHour) * 3_600.0 + + Duration (Timbuf.wMinute) * 60.0 + + Duration (Timbuf.wSecond) + + Sub_Seconds; + + Day := Integer (Timbuf.wDay); + Month := Integer (Timbuf.wMonth); + Year := Integer (Timbuf.wYear); + end Split; + + ------------- + -- Time_Of -- + ------------- + + function Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Seconds : Day_Duration := 0.0) + return Time + is + + Timbuf : aliased SYSTEMTIME; + Now : aliased Long_Long_Integer; + Loc : aliased Long_Long_Integer; + Int_Secs : Integer; + Secs : Integer; + Add_One_Day : Boolean := False; + Date : Time; + + begin + -- The following checks are redundant with respect to the constraint + -- error checks that should normally be made on parameters, but we + -- decide to raise Constraint_Error in any case if bad values come + -- in (as a result of checks being off in the caller, or for other + -- erroneous or bounded error cases). + + if not Year 'Valid + or else not Month 'Valid + or else not Day 'Valid + or else not Seconds'Valid + then + raise Constraint_Error; + end if; + + if Seconds = 0.0 then + Int_Secs := 0; + else + Int_Secs := Integer (Seconds - 0.5); + end if; + + -- Timbuf.wMillisec is to keep the msec. We can't use that because the + -- high-resolution clock has a precision of 1 Microsecond. + -- Anyway the sub-seconds part is not needed to compute the number + -- of seconds in UTC. + + if Int_Secs = 86_400 then + Secs := 0; + Add_One_Day := True; + else + Secs := Int_Secs; + end if; + + Timbuf.wMilliseconds := 0; + Timbuf.wSecond := WORD (Secs mod 60); + Timbuf.wMinute := WORD ((Secs / 60) mod 60); + Timbuf.wHour := WORD (Secs / 3600); + Timbuf.wDay := WORD (Day); + Timbuf.wMonth := WORD (Month); + Timbuf.wYear := WORD (Year); + + if not SystemTimeToFileTime (Timbuf'Access, Loc'Access) then + raise Time_Error; + end if; + + if not LocalFileTimeToFileTime (Loc'Access, Now'Access) then + raise Time_Error; + end if; + + -- Here we have the UTC now translate UTC to Epoch time (UNIX style + -- time based on 1 january 1970) and add there the sub-seconds part. + + declare + Sub_Sec : constant Duration := Seconds - Duration (Int_Secs); + begin + Date := Time ((Now - epoch_1970) * system_time_ns / Sec_Unit) + + Sub_Sec; + end; + + if Add_One_Day then + Date := Date + Duration (86400.0); + end if; + + return Date; + end Time_Of; + + ---------- + -- Year -- + ---------- + + function Year (Date : Time) return Year_Number is + DY : Year_Number; + DM : Month_Number; + DD : Day_Number; + DS : Day_Duration; + + begin + Split (Date, DY, DM, DD, DS); + return DY; + end Year; + +end Ada.Calendar; diff --git a/gcc/ada/a-calend-vms.adb b/gcc/ada/a-calend-vms.adb new file mode 100644 index 00000000000..74c2923cbf2 --- /dev/null +++ b/gcc/ada/a-calend-vms.adb @@ -0,0 +1,361 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2003 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 System.Aux_DEC; use System.Aux_DEC; + +package body Ada.Calendar is + + ------------------------------ + -- Use of Pragma Unsuppress -- + ------------------------------ + + -- This implementation of Calendar takes advantage of the permission in + -- Ada 95 of using arithmetic overflow checks to check for out of bounds + -- time values. This means that we must catch the constraint error that + -- results from arithmetic overflow, so we use pragma Unsuppress to make + -- sure that overflow is enabled, using software overflow checking if + -- necessary. That way, compiling Calendar with options to suppress this + -- checking will not affect its correctness. + + ------------------------ + -- Local Declarations -- + ------------------------ + + Ada_Year_Min : constant := 1901; + Ada_Year_Max : constant := 2099; + + -- Some basic constants used throughout + + function To_Relative_Time (D : Duration) return Time; + + function To_Relative_Time (D : Duration) return Time is + begin + return Time (Long_Integer'Integer_Value (D) / 100); + end To_Relative_Time; + + --------- + -- "+" -- + --------- + + function "+" (Left : Time; Right : Duration) return Time is + pragma Unsuppress (Overflow_Check); + begin + return (Left + To_Relative_Time (Right)); + + exception + when Constraint_Error => + raise Time_Error; + end "+"; + + function "+" (Left : Duration; Right : Time) return Time is + pragma Unsuppress (Overflow_Check); + begin + return (To_Relative_Time (Left) + Right); + + exception + when Constraint_Error => + raise Time_Error; + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (Left : Time; Right : Duration) return Time is + pragma Unsuppress (Overflow_Check); + begin + return Left - To_Relative_Time (Right); + + exception + when Constraint_Error => + raise Time_Error; + end "-"; + + function "-" (Left : Time; Right : Time) return Duration is + pragma Unsuppress (Overflow_Check); + begin + return Duration'Fixed_Value + ((Long_Integer (Left) - Long_Integer (Right)) * 100); + + exception + when Constraint_Error => + raise Time_Error; + end "-"; + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Time) return Boolean is + begin + return Long_Integer (Left) < Long_Integer (Right); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" (Left, Right : Time) return Boolean is + begin + return Long_Integer (Left) <= Long_Integer (Right); + end "<="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Time) return Boolean is + begin + return Long_Integer (Left) > Long_Integer (Right); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" (Left, Right : Time) return Boolean is + begin + return Long_Integer (Left) >= Long_Integer (Right); + end ">="; + + ----------- + -- Clock -- + ----------- + + -- The Ada.Calendar.Clock function gets the time. + -- Note that on other targets a soft-link is used to get a different clock + -- depending whether tasking is used or not. On VMS this isn't needed + -- since all clock calls end up using SYS$GETTIM, so call the + -- OS_Primitives version for efficiency. + + function Clock return Time is + begin + return Time (OSP.OS_Clock); + end Clock; + + --------- + -- Day -- + --------- + + function Day (Date : Time) return Day_Number is + DY : Year_Number; + DM : Month_Number; + DD : Day_Number; + DS : Day_Duration; + + begin + Split (Date, DY, DM, DD, DS); + return DD; + end Day; + + ----------- + -- Month -- + ----------- + + function Month (Date : Time) return Month_Number is + DY : Year_Number; + DM : Month_Number; + DD : Day_Number; + DS : Day_Duration; + + begin + Split (Date, DY, DM, DD, DS); + return DM; + end Month; + + ------------- + -- Seconds -- + ------------- + + function Seconds (Date : Time) return Day_Duration is + DY : Year_Number; + DM : Month_Number; + DD : Day_Number; + DS : Day_Duration; + + begin + Split (Date, DY, DM, DD, DS); + return DS; + end Seconds; + + ----------- + -- Split -- + ----------- + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Seconds : out Day_Duration) + is + procedure Numtim ( + Status : out Unsigned_Longword; + Timbuf : out Unsigned_Word_Array; + Timadr : in Time); + + pragma Interface (External, Numtim); + + pragma Import_Valued_Procedure (Numtim, "SYS$NUMTIM", + (Unsigned_Longword, Unsigned_Word_Array, Time), + (Value, Reference, Reference)); + + Status : Unsigned_Longword; + Timbuf : Unsigned_Word_Array (1 .. 7); + + Subsecs : constant Time := Date mod 10_000_000; + Date_Secs : constant Time := Date - Subsecs; + + begin + Numtim (Status, Timbuf, Date_Secs); + + if Status mod 2 /= 1 + or else Timbuf (1) not in Ada_Year_Min .. Ada_Year_Max + then + raise Time_Error; + end if; + + Seconds := Day_Duration (Timbuf (6) + + 60 * (Timbuf (5) + 60 * Timbuf (4))) + + Duration (Subsecs) / 10_000_000.0; + + Day := Integer (Timbuf (3)); + Month := Integer (Timbuf (2)); + Year := Integer (Timbuf (1)); + end Split; + + ------------- + -- Time_Of -- + ------------- + + function Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Seconds : Day_Duration := 0.0) + return Time + is + + procedure Cvt_Vectim ( + Status : out Unsigned_Longword; + Input_Time : in Unsigned_Word_Array; + Resultant_Time : out Time); + + pragma Interface (External, Cvt_Vectim); + + pragma Import_Valued_Procedure (Cvt_Vectim, "LIB$CVT_VECTIM", + (Unsigned_Longword, Unsigned_Word_Array, Time), + (Value, Reference, Reference)); + + Status : Unsigned_Longword; + Timbuf : Unsigned_Word_Array (1 .. 7); + Date : Time; + Int_Secs : Integer; + Day_Hack : Boolean := False; + Subsecs : Day_Duration; + + begin + -- The following checks are redundant with respect to the constraint + -- error checks that should normally be made on parameters, but we + -- decide to raise Constraint_Error in any case if bad values come + -- in (as a result of checks being off in the caller, or for other + -- erroneous or bounded error cases). + + if not Year 'Valid + or else not Month 'Valid + or else not Day 'Valid + or else not Seconds'Valid + then + raise Constraint_Error; + end if; + + -- Truncate seconds value by subtracting 0.5 and rounding, + -- but be careful with 0.0 since that will give -1.0 unless + -- it is treated specially. + + if Seconds > 0.0 then + Int_Secs := Integer (Seconds - 0.5); + else + Int_Secs := Integer (Seconds); + end if; + + Subsecs := Seconds - Day_Duration (Int_Secs); + + -- Cvt_Vectim barfs on the largest Day_Duration, so trick it by + -- setting it to zero and then adding the difference after conversion. + + if Int_Secs = 86_400 then + Int_Secs := 0; + Day_Hack := True; + end if; + + Timbuf (7) := 0; + Timbuf (6) := Unsigned_Word (Int_Secs mod 60); + Timbuf (5) := Unsigned_Word ((Int_Secs / 60) mod 60); + Timbuf (4) := Unsigned_Word (Int_Secs / 3600); + Timbuf (3) := Unsigned_Word (Day); + Timbuf (2) := Unsigned_Word (Month); + Timbuf (1) := Unsigned_Word (Year); + + Cvt_Vectim (Status, Timbuf, Date); + + if Status mod 2 /= 1 then + raise Time_Error; + end if; + + if Day_Hack then + Date := Date + 10_000_000 * 86_400; + end if; + + Date := Date + Time (10_000_000.0 * Subsecs); + return Date; + end Time_Of; + + ---------- + -- Year -- + ---------- + + function Year (Date : Time) return Year_Number is + DY : Year_Number; + DM : Month_Number; + DD : Day_Number; + DS : Day_Duration; + + begin + Split (Date, DY, DM, DD, DS); + return DY; + end Year; + +end Ada.Calendar; diff --git a/gcc/ada/a-calend-vms.ads b/gcc/ada/a-calend-vms.ads new file mode 100644 index 00000000000..6704346cf70 --- /dev/null +++ b/gcc/ada/a-calend-vms.ads @@ -0,0 +1,121 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2002 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Alpha/VMS version. + +with System.OS_Primitives; +package Ada.Calendar is + + package OSP renames System.OS_Primitives; + + type Time is private; + + -- Declarations representing limits of allowed local time values. Note that + -- these do NOT constrain the possible stored values of time which may well + -- permit a larger range of times (this is explicitly allowed in Ada 95). + + subtype Year_Number is Integer range 1901 .. 2099; + subtype Month_Number is Integer range 1 .. 12; + subtype Day_Number is Integer range 1 .. 31; + + subtype Day_Duration is Duration range 0.0 .. 86_400.0; + + function Clock return Time; + + function Year (Date : Time) return Year_Number; + function Month (Date : Time) return Month_Number; + function Day (Date : Time) return Day_Number; + function Seconds (Date : Time) return Day_Duration; + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Seconds : out Day_Duration); + + function Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Seconds : Day_Duration := 0.0) + return Time; + + function "+" (Left : Time; Right : Duration) return Time; + function "+" (Left : Duration; Right : Time) return Time; + function "-" (Left : Time; Right : Duration) return Time; + function "-" (Left : Time; Right : Time) return Duration; + + function "<" (Left, Right : Time) return Boolean; + function "<=" (Left, Right : Time) return Boolean; + function ">" (Left, Right : Time) return Boolean; + function ">=" (Left, Right : Time) return Boolean; + + Time_Error : exception; + +private + + pragma Inline (Clock); + + pragma Inline (Year); + pragma Inline (Month); + pragma Inline (Day); + + pragma Inline ("+"); + pragma Inline ("-"); + + pragma Inline ("<"); + pragma Inline ("<="); + pragma Inline (">"); + pragma Inline (">="); + + -- Time is represented as the number of 100-nanosecond (ns) units offset + -- from the system base date and time, which is 00:00 o'clock, + -- November 17, 1858 (the Smithsonian base date and time for the + -- astronomic calendar). + + -- The time value stored is typically a GMT value, as provided in standard + -- Unix environments. If this is the case then Split and Time_Of perform + -- required conversions to and from local times. + + type Time is new OSP.OS_Time; + + -- Notwithstanding this definition, Time is not quite the same as OS_Time. + -- Relative Time is positive, whereas relative OS_Time is negative, + -- but this declaration makes for easier conversion. + +end Ada.Calendar; diff --git a/gcc/ada/a-dirval-mingw.adb b/gcc/ada/a-dirval-mingw.adb new file mode 100644 index 00000000000..a20ff177973 --- /dev/null +++ b/gcc/ada/a-dirval-mingw.adb @@ -0,0 +1,146 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T O R I E S . V A L I D I T Y -- +-- -- +-- B o d y -- +-- (Windows Version) -- +-- -- +-- Copyright (C) 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 Windows version of this package + +with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; + +package body Ada.Directories.Validity is + + Invalid_Character : constant array (Character) of Boolean := + (NUL .. US => True, + '/' | ':' | '*' | '?' => True, + '"' | '<' | '>' | '|' => True, + DEL .. NBSP => True, + others => False); + + ------------------------ + -- Is_Valid_Path_Name -- + ------------------------ + + function Is_Valid_Path_Name (Name : String) return Boolean is + Start : Positive := Name'First; + Last : Natural; + + begin + -- A path name cannot be empty, cannot contain more than 256 characters, + -- cannot contain invalid characters and each directory/file name need + -- to be valid. + + if Name'Length = 0 or else Name'Length > 256 then + return False; + + else + -- A drive letter may be specified at the beginning + + if Name'Length >= 2 + and then Name (Start + 1) = ':' + and then + (Name (Start) in 'A' .. 'Z' or else + Name (Start) in 'a' .. 'z') + then + Start := Start + 2; + end if; + + loop + -- Look for the start of the next directory or file name + + while Start <= Name'Last and then Name (Start) = '\' loop + Start := Start + 1; + end loop; + + -- If all directories/file names are OK, return True + + exit when Start > Name'Last; + + Last := Start; + + -- Look for the end of the directory/file name + + while Last < Name'Last loop + exit when Name (Last + 1) = '\'; + Last := Last + 1; + end loop; + + -- Check if the directory/file name is valid + + if not Is_Valid_Simple_Name (Name (Start .. Last)) then + return False; + end if; + + -- Move to the next name + + Start := Last + 1; + end loop; + end if; + + -- If Name follows the rules, it is valid + + return True; + end Is_Valid_Path_Name; + + -------------------------- + -- Is_Valid_Simple_Name -- + -------------------------- + + function Is_Valid_Simple_Name (Name : String) return Boolean is + Only_Spaces : Boolean; + + begin + -- A file name cannot be empty, cannot contain more than 256 characters, + -- and cannot contain invalid characters, including '\' + + if Name'Length = 0 or else Name'Length > 256 then + return False; + + -- Name length is OK + + else + Only_Spaces := True; + for J in Name'Range loop + if Invalid_Character (Name (J)) or else Name (J) = '\' then + return False; + elsif Name (J) /= ' ' then + Only_Spaces := False; + end if; + end loop; + + -- If no invalid chars, and not all spaces, file name is valid. + + return not Only_Spaces; + end if; + end Is_Valid_Simple_Name; + +end Ada.Directories.Validity; + diff --git a/gcc/ada/a-dirval-vms.adb b/gcc/ada/a-dirval-vms.adb new file mode 100644 index 00000000000..76cae74aa34 --- /dev/null +++ b/gcc/ada/a-dirval-vms.adb @@ -0,0 +1,175 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T O R I E S . V A L I D I T Y -- +-- -- +-- B o d y -- +-- (VMS Version) -- +-- -- +-- Copyright (C) 2004 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 version of this package + +package body Ada.Directories.Validity is + + Max_Number_Of_Characters : constant := 39; + Max_Path_Length : constant := 1_024; + + Invalid_Character : constant array (Character) of Boolean := + ('a' .. 'z' => False, + 'A' .. 'Z' => False, + '_' | '$' | '-' | '.' => False, + others => True); + + ------------------------ + -- Is_Valid_Path_Name -- + ------------------------ + + function Is_Valid_Path_Name (Name : String) return Boolean is + First : Positive := Name'First; + Last : Positive; + Dot_Found : Boolean := False; + + begin + -- A valid path (directory) name cannot be empty, and cannot contain + -- more than 1024 characters. Directories can be ".", ".." or be simple + -- name without extensions. + + if Name'Length = 0 or else Name'Length > Max_Path_Length then + return False; + + else + loop + -- Look for the start of the next directory or file name + + while First <= Name'Last and then Name (First) = '/' loop + First := First + 1; + end loop; + + -- If all directories/file names are OK, return True + + exit when First > Name'Last; + + Last := First; + Dot_Found := False; + + -- Look for the end of the directory/file name + + while Last < Name'Last loop + exit when Name (Last + 1) = '/'; + Last := Last + 1; + + if Name (Last) = '.' then + Dot_Found := True; + end if; + end loop; + + -- If name include a dot, it can only be ".", ".." or a the last + -- file name. + + if Dot_Found then + if Name (First .. Last) /= "." and then + Name (First .. Last) /= ".." + then + return Last = Name'Last + and then Is_Valid_Simple_Name (Name (First .. Last)); + + end if; + + -- Check if the directory/file name is valid + + elsif not Is_Valid_Simple_Name (Name (First .. Last)) then + return False; + end if; + + -- Move to the next name + + First := Last + 1; + end loop; + end if; + + -- If Name follows the rules, then it is valid + + return True; + end Is_Valid_Path_Name; + + -------------------------- + -- Is_Valid_Simple_Name -- + -------------------------- + + function Is_Valid_Simple_Name (Name : String) return Boolean is + In_Extension : Boolean := False; + Number_Of_Characters : Natural := 0; + + begin + -- A file name cannot be empty, and cannot have more than 39 characters + -- before or after a single '.'. + + if Name'Length = 0 then + return False; + + else + -- Check each character for validity + + for J in Name'Range loop + if Invalid_Character (Name (J)) then + return False; + + elsif Name (J) = '.' then + + -- Name cannot contain several dots + + if In_Extension then + return False; + + else + -- Reset the number of characters to count the characters + -- of the extension. + + In_Extension := True; + Number_Of_Characters := 0; + end if; + + else + -- Check that the number of character is not too large + + Number_Of_Characters := Number_Of_Characters + 1; + + if Number_Of_Characters > Max_Number_Of_Characters then + return False; + end if; + end if; + end loop; + end if; + + -- If the rules are followed, then it is valid + + return True; + end Is_Valid_Simple_Name; + +end Ada.Directories.Validity; + diff --git a/gcc/ada/a-excpol-abort.adb b/gcc/ada/a-excpol-abort.adb new file mode 100644 index 00000000000..afa93c1d3f2 --- /dev/null +++ b/gcc/ada/a-excpol-abort.adb @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . P O L L -- +-- (version supporting asynchronous abort test) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2000, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for targets that do not support per-thread asynchronous +-- signals. On such targets, we require compilation with the -gnatP switch +-- that activates periodic polling. Then in the body of the polling routine +-- we test for asynchronous abort. + +-- NT, OS/2, HPUX/DCE and SCO currently use this file + +with System.Soft_Links; +-- used for Check_Abort_Status + +separate (Ada.Exceptions) + +---------- +-- Poll -- +---------- + +procedure Poll is +begin + -- Test for asynchronous abort on each poll + + if System.Soft_Links.Check_Abort_Status.all /= 0 then + raise Standard'Abort_Signal; + end if; +end Poll; diff --git a/gcc/ada/a-excpol-interix.adb b/gcc/ada/a-excpol-interix.adb new file mode 100644 index 00000000000..7deb26a8603 --- /dev/null +++ b/gcc/ada/a-excpol-interix.adb @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . P O L L -- +-- (version supporting asynchronous abort test and time slicing) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2000, Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for targets that do not support per-thread asynchronous +-- signals or that do not handle async timers properly. On such targets, we +-- require compilation with the -gnatP switch that activates periodic polling. +-- Then in the body of the polling routine we test for asynchronous abort and +-- yield periodically. + +-- HP-UX and SCO currently use this file + +with System.Soft_Links; +-- used for Check_Abort_Status + +separate (Ada.Exceptions) + +---------- +-- Poll -- +---------- + +procedure Poll is +begin + if Counter = 10000 then + Counter := 0; + delay 0.0; + else + Counter := Counter + 1; + end if; + + -- Test for asynchronous abort on each poll + + if System.Soft_Links.Check_Abort_Status.all /= 0 then + raise Standard'Abort_Signal; + end if; +end Poll; diff --git a/gcc/ada/a-intnam-aix.ads b/gcc/ada/a-intnam-aix.ads new file mode 100644 index 00000000000..fa56138b461 --- /dev/null +++ b/gcc/ada/a-intnam-aix.ads @@ -0,0 +1,201 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-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 AIX version of this package. +-- +-- The following signals are reserved by the run time (native threads): +-- +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGTERM, +-- SIGSTOP, SIGKILL +-- +-- The following signals are reserved by the run time (FSU threads): +-- +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGALRM, +-- SIGWAITING, SIGSTOP, SIGKILL +-- +-- The pragma Unreserve_All_Interrupts affects the following signal(s): +-- +-- SIGINT: made available for Ada handler + +-- This target-dependent package spec contains names of interrupts +-- supported by the local system. + +with System.OS_Interface; +-- used for names of interrupts + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be + -- many-to-one. There may be aliases. Also, for all + -- signal names that are not supported on the current system + -- the value of the corresponding constant will be zero. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGEMT : constant Interrupt_ID := + System.OS_Interface.SIGEMT; -- EMT instruction + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGSYS : constant Interrupt_ID := + System.OS_Interface.SIGSYS; -- bad argument to system call + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- child status change + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGPWR : constant Interrupt_ID := + System.OS_Interface.SIGPWR; -- power-fail restart + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGPOLL : constant Interrupt_ID := + System.OS_Interface.SIGPOLL; -- pollable event occurred + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + + SIGMSG : constant Interrupt_ID := + System.OS_Interface.SIGMSG; -- input data is in the ring buffer + + SIGDANGER : constant Interrupt_ID := + System.OS_Interface.SIGDANGER; -- system crash imminent; + + SIGMIGRATE : constant Interrupt_ID := + System.OS_Interface.SIGMIGRATE; -- migrate process + + SIGPRE : constant Interrupt_ID := + System.OS_Interface.SIGPRE; -- programming exception + + SIGVIRT : constant Interrupt_ID := + System.OS_Interface.SIGVIRT; -- AIX virtual time alarm + + SIGALRM1 : constant Interrupt_ID := + System.OS_Interface.SIGALRM1; -- m:n condition variables + + SIGWAITING : constant Interrupt_ID := + System.OS_Interface.SIGWAITING; -- m:n scheduling + + SIGKAP : constant Interrupt_ID := + System.OS_Interface.SIGKAP; -- keep alive poll from native keyboard + + SIGGRANT : constant Interrupt_ID := + System.OS_Interface.SIGGRANT; -- monitor mode granted + + SIGRETRACT : constant Interrupt_ID := + System.OS_Interface.SIGRETRACT; -- monitor mode should be relinguished + + SIGSOUND : constant Interrupt_ID := + System.OS_Interface.SIGSOUND; -- sound control has completed + + SIGSAK : constant Interrupt_ID := + System.OS_Interface.SIGSAK; -- secure attention key + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-dummy.ads b/gcc/ada/a-intnam-dummy.ads new file mode 100644 index 00000000000..427ba5cc18a --- /dev/null +++ b/gcc/ada/a-intnam-dummy.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- (No Tasking Version) -- +-- -- +-- Copyright (C) 1991-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. -- +-- -- +------------------------------------------------------------------------------ + +-- The standard implementation of this spec contains only dummy interrupt +-- names. These dummy entries permit checking out code for correctness of +-- semantics, even if interrupts are not supported. + +-- For specific implementations that fully support interrupts, this package +-- spec is replaced by an implementation dependent version that defines the +-- interrupts available on the system. + +package Ada.Interrupts.Names is + + DUMMY_INTERRUPT_1 : constant Interrupt_ID := 1; + DUMMY_INTERRUPT_2 : constant Interrupt_ID := 2; + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-freebsd.ads b/gcc/ada/a-intnam-freebsd.ads new file mode 100644 index 00000000000..eb05daaa912 --- /dev/null +++ b/gcc/ada/a-intnam-freebsd.ads @@ -0,0 +1,136 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-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 FreeBSD THREADS version of this package + +with System.OS_Interface; +-- used for names of interrupts + +package Ada.Interrupts.Names is + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- child status change + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + -- Beware that the mapping of names to signals may be + -- many-to-one. There may be aliases. Also, for all + -- signal names that are not supported on the current system + -- the value of the corresponding constant will be zero. + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-hpux.ads b/gcc/ada/a-intnam-hpux.ads new file mode 100644 index 00000000000..0e01a0fa74e --- /dev/null +++ b/gcc/ada/a-intnam-hpux.ads @@ -0,0 +1,155 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-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 HP-UX version of this package. + +-- The following signals are reserved by the run time: + +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT, +-- SIGALRM, SIGSTOP, SIGKILL + +-- The pragma Unreserve_All_Interrupts affects the following signal(s): + +-- SIGINT: made available for Ada handler + +-- This target-dependent package spec contains names of interrupts +-- supported by the local system. + +with System.OS_Interface; +-- used for names of interrupts + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be + -- many-to-one. There may be aliases. Also, for all + -- signal names that are not supported on the current system + -- the value of the corresponding constant will be zero. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGEMT : constant Interrupt_ID := + System.OS_Interface.SIGEMT; -- EMT instruction + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGSYS : constant Interrupt_ID := + System.OS_Interface.SIGSYS; -- bad argument to system call + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- child status change + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGPOLL : constant Interrupt_ID := + System.OS_Interface.SIGPOLL; -- pollable event occurred + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGPWR : constant Interrupt_ID := + System.OS_Interface.SIGPWR; -- power-fail restart + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-interix.ads b/gcc/ada/a-intnam-interix.ads new file mode 100644 index 00000000000..f9cac69dc99 --- /dev/null +++ b/gcc/ada/a-intnam-interix.ads @@ -0,0 +1,154 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-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 OpenNT (FSU THREAD) version of this package. +-- +-- The following signals are reserved by the run time: +-- +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, +-- SIGALRM, SIGVTALRM, SIGSTOP, SIGKILL +-- +-- The pragma Unreserve_All_Interrupts affects the following signal(s): +-- +-- SIGINT: made available for Ada handlers + +-- This target-dependent package spec contains names of interrupts +-- supported by the local system. + +with System.OS_Interface; +-- used for names of interrupts + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be + -- many-to-one. There may be aliases. Also, for all + -- signal names that are not supported on the current system + -- the value of the corresponding constant will be zero. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGSYS : constant Interrupt_ID := + System.OS_Interface.SIGSYS; -- bad argument to system call + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- child status change + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGPOLL : constant Interrupt_ID := + System.OS_Interface.SIGPOLL; -- pollable event occurred + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-irix.ads b/gcc/ada/a-intnam-irix.ads new file mode 100644 index 00000000000..afd82f2bb6c --- /dev/null +++ b/gcc/ada/a-intnam-irix.ads @@ -0,0 +1,196 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-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 Library General Public License as published by the -- +-- Free Software Foundation; either version 2, or (at your option) any -- +-- later version. GNARL is distributed in the hope that it will be use- -- +-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of -- +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Gen- -- +-- eral Library Public License for more details. You should have received -- +-- a copy of the GNU Library General Public License along with GNARL; see -- +-- file COPYING.LIB. 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 Irix version of this package + +-- The following signals are reserved by the run time (Athread library): + +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGSTOP, SIGKILL + +-- The following signals are reserved by the run time (Pthread library): + +-- SIGTSTP, SIGILL, SIGTRAP, SIGEMT, SIGFPE, SIGBUS, SIGSTOP, SIGKILL, +-- SIGSEGV, SIGSYS, SIGXCPU, SIGXFSZ, SIGPROF, SIGPTINTR, SIGPTRESCHED, +-- SIGABRT, SIGINT + +-- The pragma Unreserve_All_Interrupts affects the following signal +-- (Pthread library): + +-- SIGINT: made available for Ada handler + +-- This target-dependent package spec contains names of interrupts +-- supported by the local system. + +with System.OS_Interface; +-- used for names of interrupts + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be + -- many-to-one. There may be aliases. Also, for all + -- signal names that are not supported on the current system + -- the value of the corresponding constant will be zero. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := + System.OS_Interface.SIGABRT; -- used by abort, replace SIGIOT in the + -- future + + SIGEMT : constant Interrupt_ID := + System.OS_Interface.SIGEMT; -- EMT instruction + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGSYS : constant Interrupt_ID := + System.OS_Interface.SIGSYS; -- bad argument to system call + + SIGPIPE : constant Interrupt_ID := + System.OS_Interface.SIGPIPE; -- write on pipe with no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- alias for SIGCHLD + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- child status change + + SIGPWR : constant Interrupt_ID := + System.OS_Interface.SIGPWR; -- power-fail restart + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGPOLL : constant Interrupt_ID := + System.OS_Interface.SIGPOLL; -- pollable event occurred + + SIGIO : constant Interrupt_ID := + System.OS_Interface.SIGIO; -- I/O possible (Solaris SIGPOLL alias) + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + + SIGK32 : constant Interrupt_ID := + System.OS_Interface.SIGK32; -- reserved for kernel (IRIX) + + SIGCKPT : constant Interrupt_ID := + System.OS_Interface.SIGCKPT; -- Checkpoint warning + + SIGRESTART : constant Interrupt_ID := + System.OS_Interface.SIGRESTART; -- Restart warning + + SIGUME : constant Interrupt_ID := + System.OS_Interface.SIGUME; -- Uncorrectable memory error + + -- Signals defined for Posix 1003.1c. + + SIGPTINTR : constant Interrupt_ID := + System.OS_Interface.SIGPTINTR; -- Pthread Interrupt Signal + + SIGPTRESCHED : constant Interrupt_ID := + System.OS_Interface.SIGPTRESCHED; -- Pthread Rescheduling Signal + + -- Posix 1003.1b signals + + SIGRTMIN : constant Interrupt_ID := + System.OS_Interface.SIGRTMIN; -- Posix 1003.1b signals + + SIGRTMAX : constant Interrupt_ID := + System.OS_Interface.SIGRTMAX; -- Posix 1003.1b signals + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-linux.ads b/gcc/ada/a-intnam-linux.ads new file mode 100644 index 00000000000..ce9ccc774db --- /dev/null +++ b/gcc/ada/a-intnam-linux.ads @@ -0,0 +1,168 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-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 GNU/Linux version of this package. +-- +-- The following signals are reserved by the run time (FSU threads): +-- +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, +-- SIGALRM, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL +-- +-- The following signals are reserved by the run time (LinuxThreads): +-- +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, +-- SIGUSR1, SIGUSR2, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL +-- +-- The pragma Unreserve_All_Interrupts affects the following signal(s): +-- +-- SIGINT: made available for Ada handler + +-- This target-dependent package spec contains names of interrupts +-- supported by the local system. + +with System.OS_Interface; +-- used for names of interrupts + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be + -- many-to-one. There may be aliases. Also, for all + -- signal names that are not supported on the current system + -- the value of the corresponding constant will be zero. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- child status change + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGPOLL : constant Interrupt_ID := + System.OS_Interface.SIGPOLL; -- pollable event occurred + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + + SIGUNUSED : constant Interrupt_ID := + System.OS_Interface.SIGUNUSED; -- unused signal + + SIGSTKFLT : constant Interrupt_ID := + System.OS_Interface.SIGSTKFLT; -- stack fault on coprocessor + + SIGLOST : constant Interrupt_ID := + System.OS_Interface.SIGLOST; -- Linux alias for SIGIO + + SIGPWR : constant Interrupt_ID := + System.OS_Interface.SIGPWR; -- Power failure + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-lynxos.ads b/gcc/ada/a-intnam-lynxos.ads new file mode 100644 index 00000000000..edc91159690 --- /dev/null +++ b/gcc/ada/a-intnam-lynxos.ads @@ -0,0 +1,165 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-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 LynxOS version of this package. +-- +-- The following signals are reserved by the run time: +-- +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, +-- SIGWAITING, SIGLWP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGSTOP, SIGKILL +-- +-- The pragma Unreserve_All_Interrupts affects the following signal(s): +-- +-- SIGINT: made available for Ada handler + +with System.OS_Interface; +-- used for names of interrupts + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be + -- many-to-one. There may be aliases. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGBRK : constant Interrupt_ID := + System.OS_Interface.SIGBRK; -- break + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGCORE : constant Interrupt_ID := + System.OS_Interface.SIGCORE; -- kill with core dump + + SIGEMT : constant Interrupt_ID := + System.OS_Interface.SIGEMT; -- EMT instruction + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGSYS : constant Interrupt_ID := + System.OS_Interface.SIGSYS; -- bad argument to system call + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- child status change + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGPOLL : constant Interrupt_ID := + System.OS_Interface.SIGPOLL; -- pollable event occurred + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGLOST : constant Interrupt_ID := + System.OS_Interface.SIGLOST; -- SUN 4.1 compatibility + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + SIGPRIO : constant Interrupt_ID := + System.OS_Interface.SIGPRIO; + -- sent to a process with its priority + -- or group is changed +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-mingw.ads b/gcc/ada/a-intnam-mingw.ads new file mode 100644 index 00000000000..4d02e17bf60 --- /dev/null +++ b/gcc/ada/a-intnam-mingw.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-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 NT (native) version of this package. + +-- This target-dependent package spec contains names of interrupts +-- supported by the local system. + +with System.OS_Interface; +-- used for names of interrupts + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be + -- many-to-one. There may be aliases. Also, for all + -- signal names that are not supported on the current system + -- the value of the corresponding constant will be zero. + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-os2.ads b/gcc/ada/a-intnam-os2.ads new file mode 100644 index 00000000000..6733730b372 --- /dev/null +++ b/gcc/ada/a-intnam-os2.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-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 an OS/2 version of this package. + +-- This target-dependent package spec contains names of interrupts +-- supported by the local system. + +-- This is a stub, for systems that do not support interrupts (or signals) + +package Ada.Interrupts.Names is +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-solaris.ads b/gcc/ada/a-intnam-solaris.ads new file mode 100644 index 00000000000..d6fc181ea9e --- /dev/null +++ b/gcc/ada/a-intnam-solaris.ads @@ -0,0 +1,179 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-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 Solaris version of this package. +-- +-- The following signals are reserved by the run time (native threads): +-- +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, +-- SIGLWP, SIGWAITING, SIGCANCEL, SIGSTOP, SIGKILL +-- +-- The following signals are reserved by the run time (FSU threads): +-- +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGTERM, SIGABRT, SIGINT, +-- SIGLWP, SIGALRM, SIGVTALRM, SIGAITING, SIGSTOP, SIGKILL +-- +-- The pragma Unreserve_All_Interrupts affects the following signal(s): +-- +-- SIGINT: made available for Ada handlers + +with System.OS_Interface; +-- used for names of interrupts + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be + -- many-to-one. There may be aliases. Also, for all + -- signal names that are not supported on the current system + -- the value of the corresponding constant will be zero. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGEMT : constant Interrupt_ID := + System.OS_Interface.SIGEMT; -- EMT instruction + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGSYS : constant Interrupt_ID := + System.OS_Interface.SIGSYS; -- bad argument to system call + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- child status change + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGPOLL : constant Interrupt_ID := + System.OS_Interface.SIGPOLL; -- pollable event occurred + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + + SIGPWR : constant Interrupt_ID := + System.OS_Interface.SIGPWR; -- power-fail restart + + SIGWAITING : constant Interrupt_ID := + System.OS_Interface.SIGWAITING; -- process's lwps blocked (Solaris) + + SIGLWP : constant Interrupt_ID := + System.OS_Interface.SIGLWP; -- used by thread library (Solaris) + + SIGFREEZE : constant Interrupt_ID := + System.OS_Interface.SIGFREEZE; -- used by CPR (Solaris) + +-- what is CPR???? + + SIGTHAW : constant Interrupt_ID := + System.OS_Interface.SIGTHAW; -- used by CPR (Solaris) + + SIGCANCEL : constant Interrupt_ID := + System.OS_Interface.SIGCANCEL; -- used for thread cancel (Solaris) + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-tru64.ads b/gcc/ada/a-intnam-tru64.ads new file mode 100644 index 00000000000..95509a89d94 --- /dev/null +++ b/gcc/ada/a-intnam-tru64.ads @@ -0,0 +1,151 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-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 the DEC Unix 4.0 version of this package. +-- +-- The following signals are reserved by the run time: +-- +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT, SIGTRAP, SIGINT, SIGALRM, +-- SIGSTOP, SIGKILL +-- +-- The pragma Unreserve_All_Interrupts affects the following signal(s): +-- +-- SIGINT: made available for Ada handler + +with System.OS_Interface; +-- used for names of interrupts + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be + -- many-to-one. There may be aliases. Also, for all + -- signal names that are not supported on the current system + -- the value of the corresponding constant will be zero. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGEMT : constant Interrupt_ID := + System.OS_Interface.SIGEMT; -- EMT instruction + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGSYS : constant Interrupt_ID := + System.OS_Interface.SIGSYS; -- bad argument to system call + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGPOLL : constant Interrupt_ID := + System.OS_Interface.SIGPOLL; -- pollable event occurred + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-unixware.ads b/gcc/ada/a-intnam-unixware.ads new file mode 100644 index 00000000000..b7009ab569e --- /dev/null +++ b/gcc/ada/a-intnam-unixware.ads @@ -0,0 +1,164 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-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 SCO UnixWare version of this package. +-- +-- The following signals are reserved by the run time: +-- +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, +-- SIGWAITING, SIGLWP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGSTOP, SIGKILL +-- +-- The pragma Unreserve_All_Interrupts affects the following signal(s): +-- +-- SIGINT: made available for Ada handler + +with System.OS_Interface; +-- used for names of interrupts + +package Ada.Interrupts.Names is + + -- Beware that the mapping of names to signals may be + -- many-to-one. There may be aliases. + + SIGHUP : constant Interrupt_ID := + System.OS_Interface.SIGHUP; -- hangup + + SIGINT : constant Interrupt_ID := + System.OS_Interface.SIGINT; -- interrupt (rubout) + + SIGQUIT : constant Interrupt_ID := + System.OS_Interface.SIGQUIT; -- quit (ASCD FS) + + SIGILL : constant Interrupt_ID := + System.OS_Interface.SIGILL; -- illegal instruction (not reset) + + SIGTRAP : constant Interrupt_ID := + System.OS_Interface.SIGTRAP; -- trace trap (not reset) + + SIGIOT : constant Interrupt_ID := + System.OS_Interface.SIGIOT; -- IOT instruction + + SIGABRT : constant Interrupt_ID := -- used by abort, + System.OS_Interface.SIGABRT; -- replace SIGIOT in the future + + SIGEMT : constant Interrupt_ID := + System.OS_Interface.SIGEMT; -- EMT instruction + + SIGFPE : constant Interrupt_ID := + System.OS_Interface.SIGFPE; -- floating point exception + + SIGKILL : constant Interrupt_ID := + System.OS_Interface.SIGKILL; -- kill (cannot be caught or ignored) + + SIGBUS : constant Interrupt_ID := + System.OS_Interface.SIGBUS; -- bus error + + SIGSEGV : constant Interrupt_ID := + System.OS_Interface.SIGSEGV; -- segmentation violation + + SIGSYS : constant Interrupt_ID := + System.OS_Interface.SIGSYS; -- bad argument to system call + + SIGPIPE : constant Interrupt_ID := -- write on a pipe with + System.OS_Interface.SIGPIPE; -- no one to read it + + SIGALRM : constant Interrupt_ID := + System.OS_Interface.SIGALRM; -- alarm clock + + SIGTERM : constant Interrupt_ID := + System.OS_Interface.SIGTERM; -- software termination signal from kill + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- child status change + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGPWR : constant Interrupt_ID := + System.OS_Interface.SIGPWR; -- power-fail restart + + SIGWINCH : constant Interrupt_ID := + System.OS_Interface.SIGWINCH; -- window size change + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + SIGPOLL : constant Interrupt_ID := + System.OS_Interface.SIGPOLL; -- pollable event occurred + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) + + SIGSTOP : constant Interrupt_ID := + System.OS_Interface.SIGSTOP; -- stop (cannot be caught or ignored) + + SIGTSTP : constant Interrupt_ID := + System.OS_Interface.SIGTSTP; -- user stop requested from tty + + SIGCONT : constant Interrupt_ID := + System.OS_Interface.SIGCONT; -- stopped process has been continued + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGVTALRM : constant Interrupt_ID := + System.OS_Interface.SIGVTALRM; -- virtual timer expired + + SIGPROF : constant Interrupt_ID := + System.OS_Interface.SIGPROF; -- profiling timer expired + + SIGXCPU : constant Interrupt_ID := + System.OS_Interface.SIGXCPU; -- CPU time limit exceeded + + SIGXFSZ : constant Interrupt_ID := + System.OS_Interface.SIGXFSZ; -- filesize limit exceeded + + SIGWAITING : constant Interrupt_ID := + System.OS_Interface.SIGWAITING; -- process's lwps blocked (Solaris) + + SIGLWP : constant Interrupt_ID := + System.OS_Interface.SIGLWP; -- used by thread library (Solaris) + + SIGAIO : constant Interrupt_ID := + System.OS_Interface.SIGAIO; -- Asynchronous I/O signal + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-vms.ads b/gcc/ada/a-intnam-vms.ads new file mode 100644 index 00000000000..7eec58fbeb7 --- /dev/null +++ b/gcc/ada/a-intnam-vms.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-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 OpenVMS/Alpha version of this package. +-- +-- This target-dependent package spec contains names of interrupts +-- supported by the local system. + +with System.OS_Interface; +package Ada.Interrupts.Names is + + package OS renames System.OS_Interface; + + Interrupt_ID_0 : constant Interrupt_ID := OS.Interrupt_ID_0; + Interrupt_ID_1 : constant Interrupt_ID := OS.Interrupt_ID_1; + Interrupt_ID_2 : constant Interrupt_ID := OS.Interrupt_ID_2; + Interrupt_ID_3 : constant Interrupt_ID := OS.Interrupt_ID_3; + Interrupt_ID_4 : constant Interrupt_ID := OS.Interrupt_ID_4; + Interrupt_ID_5 : constant Interrupt_ID := OS.Interrupt_ID_5; + Interrupt_ID_6 : constant Interrupt_ID := OS.Interrupt_ID_6; + Interrupt_ID_7 : constant Interrupt_ID := OS.Interrupt_ID_7; + Interrupt_ID_8 : constant Interrupt_ID := OS.Interrupt_ID_8; + Interrupt_ID_9 : constant Interrupt_ID := OS.Interrupt_ID_9; + Interrupt_ID_10 : constant Interrupt_ID := OS.Interrupt_ID_10; + Interrupt_ID_11 : constant Interrupt_ID := OS.Interrupt_ID_11; + Interrupt_ID_12 : constant Interrupt_ID := OS.Interrupt_ID_12; + Interrupt_ID_13 : constant Interrupt_ID := OS.Interrupt_ID_13; + Interrupt_ID_14 : constant Interrupt_ID := OS.Interrupt_ID_14; + Interrupt_ID_15 : constant Interrupt_ID := OS.Interrupt_ID_15; + Interrupt_ID_16 : constant Interrupt_ID := OS.Interrupt_ID_16; + Interrupt_ID_17 : constant Interrupt_ID := OS.Interrupt_ID_17; + Interrupt_ID_18 : constant Interrupt_ID := OS.Interrupt_ID_18; + Interrupt_ID_19 : constant Interrupt_ID := OS.Interrupt_ID_19; + Interrupt_ID_20 : constant Interrupt_ID := OS.Interrupt_ID_20; + Interrupt_ID_21 : constant Interrupt_ID := OS.Interrupt_ID_21; + Interrupt_ID_22 : constant Interrupt_ID := OS.Interrupt_ID_22; + Interrupt_ID_23 : constant Interrupt_ID := OS.Interrupt_ID_23; + Interrupt_ID_24 : constant Interrupt_ID := OS.Interrupt_ID_24; + Interrupt_ID_25 : constant Interrupt_ID := OS.Interrupt_ID_25; + Interrupt_ID_26 : constant Interrupt_ID := OS.Interrupt_ID_26; + Interrupt_ID_27 : constant Interrupt_ID := OS.Interrupt_ID_27; + Interrupt_ID_28 : constant Interrupt_ID := OS.Interrupt_ID_28; + Interrupt_ID_29 : constant Interrupt_ID := OS.Interrupt_ID_29; + Interrupt_ID_30 : constant Interrupt_ID := OS.Interrupt_ID_30; + Interrupt_ID_31 : constant Interrupt_ID := OS.Interrupt_ID_31; + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-vxworks.ads b/gcc/ada/a-intnam-vxworks.ads new file mode 100644 index 00000000000..757b15376fb --- /dev/null +++ b/gcc/ada/a-intnam-vxworks.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . I N T E R R U P T S . N A M E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks version of this package. + +with System.OS_Interface; + +package Ada.Interrupts.Names is + + subtype Hardware_Interrupts is Interrupt_ID + range Interrupt_ID'First .. System.OS_Interface.Max_HW_Interrupt; + -- Range of values that can be used for hardware interrupts. + +end Ada.Interrupts.Names; diff --git a/gcc/ada/a-numaux-libc-x86.ads b/gcc/ada/a-numaux-libc-x86.ads new file mode 100644 index 00000000000..0f84a9fe053 --- /dev/null +++ b/gcc/ada/a-numaux-libc-x86.ads @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X -- +-- -- +-- S p e c -- +-- (C Library Version for x86) -- +-- -- +-- Copyright (C) 1992-2003 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. The C library version interfaces with the routines +-- in the C mathematical library, and is thus quite portable, although it may +-- not necessarily meet the requirements for accuracy in the numerics annex. +-- One advantage of using this package is that it will interface directly to +-- hardware instructions, such as the those provided on the Intel x86. + +-- 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). + +package Ada.Numerics.Aux is +pragma Pure (Aux); + + pragma Linker_Options ("-lm"); + + type Double is digits 18; + + -- We import these functions directly from C. Note that we label them + -- all as pure functions, because indeed all of them are in fact pure! + + function Sin (X : Double) return Double; + pragma Import (C, Sin, "sinl"); + pragma Pure_Function (Sin); + + function Cos (X : Double) return Double; + pragma Import (C, Cos, "cosl"); + pragma Pure_Function (Cos); + + function Tan (X : Double) return Double; + pragma Import (C, Tan, "tanl"); + pragma Pure_Function (Tan); + + function Exp (X : Double) return Double; + pragma Import (C, Exp, "expl"); + pragma Pure_Function (Exp); + + function Sqrt (X : Double) return Double; + pragma Import (C, Sqrt, "sqrtl"); + pragma Pure_Function (Sqrt); + + function Log (X : Double) return Double; + pragma Import (C, Log, "logl"); + pragma Pure_Function (Log); + + function Acos (X : Double) return Double; + pragma Import (C, Acos, "acosl"); + pragma Pure_Function (Acos); + + function Asin (X : Double) return Double; + pragma Import (C, Asin, "asinl"); + pragma Pure_Function (Asin); + + function Atan (X : Double) return Double; + pragma Import (C, Atan, "atanl"); + pragma Pure_Function (Atan); + + function Sinh (X : Double) return Double; + pragma Import (C, Sinh, "sinhl"); + pragma Pure_Function (Sinh); + + function Cosh (X : Double) return Double; + pragma Import (C, Cosh, "coshl"); + pragma Pure_Function (Cosh); + + function Tanh (X : Double) return Double; + pragma Import (C, Tanh, "tanhl"); + pragma Pure_Function (Tanh); + + function Pow (X, Y : Double) return Double; + pragma Import (C, Pow, "powl"); + pragma Pure_Function (Pow); + +end Ada.Numerics.Aux; diff --git a/gcc/ada/a-numaux-vxworks.ads b/gcc/ada/a-numaux-vxworks.ads new file mode 100644 index 00000000000..3a995a12bd1 --- /dev/null +++ b/gcc/ada/a-numaux-vxworks.ads @@ -0,0 +1,110 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X -- +-- -- +-- S p e c -- +-- (C Library Version, VxWorks) -- +-- -- +-- Copyright (C) 1992-2003 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. The C library version interfaces with the routines +-- in the C mathematical library, and is thus quite portable, although it may +-- not necessarily meet the requirements for accuracy in the numerics annex. +-- One advantage of using this package is that it will interface directly to +-- hardware instructions, such as the those provided on the Intel x86. + +-- Note: there are two versions of this package. One using the normal IEEE +-- 64-bit double format (which is this version), and one using 80-bit x86 +-- long double (see file 4onumaux.ads). + +package Ada.Numerics.Aux is +pragma Pure (Aux); + + -- This version omits the pragma linker_options ("-lm") since there is + -- no libm.a library for VxWorks. + + type Double is digits 15; + -- Type Double is the type used to call the C routines + + -- We import these functions directly from C. Note that we label them + -- all as pure functions, because indeed all of them are in fact pure! + + function Sin (X : Double) return Double; + pragma Import (C, Sin, "sin"); + pragma Pure_Function (Sin); + + function Cos (X : Double) return Double; + pragma Import (C, Cos, "cos"); + pragma Pure_Function (Cos); + + function Tan (X : Double) return Double; + pragma Import (C, Tan, "tan"); + pragma Pure_Function (Tan); + + function Exp (X : Double) return Double; + pragma Import (C, Exp, "exp"); + pragma Pure_Function (Exp); + + function Sqrt (X : Double) return Double; + pragma Import (C, Sqrt, "sqrt"); + pragma Pure_Function (Sqrt); + + function Log (X : Double) return Double; + pragma Import (C, Log, "log"); + pragma Pure_Function (Log); + + function Acos (X : Double) return Double; + pragma Import (C, Acos, "acos"); + pragma Pure_Function (Acos); + + function Asin (X : Double) return Double; + pragma Import (C, Asin, "asin"); + pragma Pure_Function (Asin); + + function Atan (X : Double) return Double; + pragma Import (C, Atan, "atan"); + pragma Pure_Function (Atan); + + function Sinh (X : Double) return Double; + pragma Import (C, Sinh, "sinh"); + pragma Pure_Function (Sinh); + + function Cosh (X : Double) return Double; + pragma Import (C, Cosh, "cosh"); + pragma Pure_Function (Cosh); + + function Tanh (X : Double) return Double; + pragma Import (C, Tanh, "tanh"); + pragma Pure_Function (Tanh); + + function Pow (X, Y : Double) return Double; + pragma Import (C, Pow, "pow"); + pragma Pure_Function (Pow); + +end Ada.Numerics.Aux; diff --git a/gcc/ada/a-numaux-x86.adb b/gcc/ada/a-numaux-x86.adb new file mode 100644 index 00000000000..a13733305a1 --- /dev/null +++ b/gcc/ada/a-numaux-x86.adb @@ -0,0 +1,592 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-numaux-x86.ads b/gcc/ada/a-numaux-x86.ads new file mode 100644 index 00000000000..857499fdfc1 --- /dev/null +++ b/gcc/ada/a-numaux-x86.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/a-sytaco-vxworks.adb b/gcc/ada/a-sytaco-vxworks.adb new file mode 100644 index 00000000000..fcb320a97ec --- /dev/null +++ b/gcc/ada/a-sytaco-vxworks.adb @@ -0,0 +1,147 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S Y N C H R O N O U S _ T A S K _ C O N T R O L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C; + +package body Ada.Synchronous_Task_Control is + use System.OS_Interface; + use type Interfaces.C.int; + + ------------------- + -- Current_State -- + ------------------- + + function Current_State (S : Suspension_Object) return Boolean is + St : STATUS; + Result : Boolean := False; + + begin + -- Determine state by attempting to take the semaphore with + -- a 0 timeout value. Status = OK indicates the semaphore was + -- full, so reset it to the full state. + + St := semTake (S.Sema, NO_WAIT); + + -- If we took the semaphore, reset semaphore state to FULL + + if St = OK then + Result := True; + St := semGive (S.Sema); + end if; + + return Result; + end Current_State; + + --------------- + -- Set_False -- + --------------- + + procedure Set_False (S : in out Suspension_Object) is + St : STATUS; + + begin + -- Need to get the semaphore into the "empty" state. + -- On return, this task will have made the semaphore + -- empty (St = OK) or have left it empty. + + St := semTake (S.Sema, NO_WAIT); + pragma Assert (St = OK); + end Set_False; + + -------------- + -- Set_True -- + -------------- + + procedure Set_True (S : in out Suspension_Object) is + St : STATUS; + pragma Unreferenced (St); + begin + St := semGive (S.Sema); + end Set_True; + + ------------------------ + -- Suspend_Until_True -- + ------------------------ + + procedure Suspend_Until_True (S : in out Suspension_Object) is + St : STATUS; + + begin + -- Determine whether another task is pending on the suspension + -- object. Should never be called from an ISR. Therefore semTake can + -- be called on the mutex + + St := semTake (S.Mutex, NO_WAIT); + + if St = OK then + + -- Wait for suspension object + + St := semTake (S.Sema, WAIT_FOREVER); + St := semGive (S.Mutex); + + else + -- Another task is pending on the suspension object + + raise Program_Error; + end if; + end Suspend_Until_True; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Suspension_Object) is + begin + S.Sema := semBCreate (SEM_Q_FIFO, SEM_EMPTY); + + -- Use simpler binary semaphore instead of VxWorks + -- mutual exclusion semaphore, because we don't need + -- the fancier semantics and their overhead. + + S.Mutex := semBCreate (SEM_Q_FIFO, SEM_FULL); + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Suspension_Object) is + St : STATUS; + pragma Unreferenced (St); + begin + St := semDelete (S.Sema); + St := semDelete (S.Mutex); + end Finalize; + +end Ada.Synchronous_Task_Control; diff --git a/gcc/ada/a-sytaco-vxworks.ads b/gcc/ada/a-sytaco-vxworks.ads new file mode 100644 index 00000000000..c3c54bee43c --- /dev/null +++ b/gcc/ada/a-sytaco-vxworks.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S Y N C H R O N O U S _ T A S K _ C O N T R O L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.OS_Interface; +with Ada.Finalization; +package Ada.Synchronous_Task_Control is + + type Suspension_Object is limited private; + + procedure Set_True (S : in out Suspension_Object); + + procedure Set_False (S : in out Suspension_Object); + + function Current_State (S : Suspension_Object) return Boolean; + + procedure Suspend_Until_True (S : in out Suspension_Object); + +private + + procedure Initialize (S : in out Suspension_Object); + + procedure Finalize (S : in out Suspension_Object); + + -- Implement with a VxWorks binary semaphore. A second semaphore + -- is used to avoid a race condition related to the implementation of + -- the STC requirement to raise Program_Error when Suspend_Until_True is + -- called with a task already pending on the suspension object + + type Suspension_Object is new Ada.Finalization.Controlled with record + Sema : System.OS_Interface.SEM_ID; + Mutex : System.OS_Interface.SEM_ID; + end record; + +end Ada.Synchronous_Task_Control; diff --git a/gcc/ada/g-eacodu-vms.adb b/gcc/ada/g-eacodu-vms.adb new file mode 100644 index 00000000000..2c31a28e299 --- /dev/null +++ b/gcc/ada/g-eacodu-vms.adb @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . E X C E P T I O N _ A C T I O N S . C O R E _ D U M P -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003 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 VMS version. + +with System; +with System.Aux_DEC; +separate (GNAT.Exception_Actions) +procedure Core_Dump (Occurrence : Exception_Occurrence) is + + use System; + use System.Aux_DEC; + + pragma Unreferenced (Occurrence); + + SS_IMGDMP : constant := 1276; + + subtype Cond_Value_Type is Unsigned_Longword; + subtype Access_Mode_Type is + Unsigned_Word range 0 .. 3; + Access_Mode_Zero : constant Access_Mode_Type := 0; + + Status : Cond_Value_Type; + + procedure Setexv ( + Status : out Cond_Value_Type; + Vector : in Unsigned_Longword := 0; + Addres : in Address := Address_Zero; + Acmode : in Access_Mode_Type := Access_Mode_Zero; + Prvhnd : in Unsigned_Longword := 0); + pragma Interface (External, Setexv); + pragma Import_Valued_Procedure (Setexv, "SYS$SETEXV", + (Cond_Value_Type, Unsigned_Longword, Address, Access_Mode_Type, + Unsigned_Longword), + (Value, Value, Value, Value, Value)); + + procedure Lib_Signal (I : in Integer); + pragma Interface (C, Lib_Signal); + pragma Import_Procedure (Lib_Signal, "LIB$SIGNAL", Mechanism => (Value)); +begin + Setexv (Status, 1, Address_Zero, 3); + Lib_Signal (SS_IMGDMP); +end Core_Dump; diff --git a/gcc/ada/g-expect-vms.adb b/gcc/ada/g-expect-vms.adb new file mode 100644 index 00000000000..1f18885c813 --- /dev/null +++ b/gcc/ada/g-expect-vms.adb @@ -0,0 +1,1184 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . E X P E C T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-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 is the VMS version. + +with System; use System; +with Ada.Calendar; use Ada.Calendar; + +with GNAT.IO; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Regpat; use GNAT.Regpat; + +with Unchecked_Deallocation; + +package body GNAT.Expect is + + type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access; + + Save_Input : File_Descriptor; + Save_Output : File_Descriptor; + Save_Error : File_Descriptor; + + procedure Expect_Internal + (Descriptors : in out Array_Of_Pd; + Result : out Expect_Match; + Timeout : Integer; + Full_Buffer : Boolean); + -- Internal function used to read from the process Descriptor. + -- + -- Three outputs are possible: + -- Result=Expect_Timeout, if no output was available before the timeout + -- expired. + -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters + -- had to be discarded from the internal buffer of Descriptor. + -- Result=, indicates how many characters were added to the + -- internal buffer. These characters are from indexes + -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index + -- Process_Died is raised if the process is no longer valid. + + procedure Reinitialize_Buffer + (Descriptor : in out Process_Descriptor'Class); + -- Reinitialize the internal buffer. + -- The buffer is deleted up to the end of the last match. + + procedure Free is new Unchecked_Deallocation + (Pattern_Matcher, Pattern_Matcher_Access); + + procedure Call_Filters + (Pid : Process_Descriptor'Class; + Str : String; + Filter_On : Filter_Type); + -- Call all the filters that have the appropriate type. + -- This function does nothing if the filters are locked + + ------------------------------ + -- Target dependent section -- + ------------------------------ + + function Dup (Fd : File_Descriptor) return File_Descriptor; + pragma Import (C, Dup); + + procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); + pragma Import (C, Dup2); + + procedure Kill (Pid : Process_Id; Sig_Num : Integer); + pragma Import (C, Kill); + + function Create_Pipe (Pipe : access Pipe_Type) return Integer; + pragma Import (C, Create_Pipe, "__gnat_pipe"); + + function Poll + (Fds : System.Address; + Num_Fds : Integer; + Timeout : Integer; + Is_Set : System.Address) return Integer; + pragma Import (C, Poll, "__gnat_expect_poll"); + -- Check whether there is any data waiting on the file descriptor + -- Out_fd, and wait if there is none, at most Timeout milliseconds + -- Returns -1 in case of error, 0 if the timeout expired before + -- data became available. + -- + -- Out_Is_Set is set to 1 if data was available, 0 otherwise. + + function Waitpid (Pid : Process_Id) return Integer; + pragma Import (C, Waitpid, "__gnat_waitpid"); + -- Wait for a specific process id, and return its exit code. + + --------- + -- "+" -- + --------- + + function "+" (S : String) return GNAT.OS_Lib.String_Access is + begin + return new String'(S); + end "+"; + + --------- + -- "+" -- + --------- + + function "+" + (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access + is + begin + return new GNAT.Regpat.Pattern_Matcher'(P); + end "+"; + + ---------------- + -- Add_Filter -- + ---------------- + + procedure Add_Filter + (Descriptor : in out Process_Descriptor; + Filter : Filter_Function; + Filter_On : Filter_Type := Output; + User_Data : System.Address := System.Null_Address; + After : Boolean := False) + is + Current : Filter_List := Descriptor.Filters; + + begin + if After then + while Current /= null and then Current.Next /= null loop + Current := Current.Next; + end loop; + + if Current = null then + Descriptor.Filters := + new Filter_List_Elem' + (Filter => Filter, Filter_On => Filter_On, + User_Data => User_Data, Next => null); + else + Current.Next := + new Filter_List_Elem' + (Filter => Filter, Filter_On => Filter_On, + User_Data => User_Data, Next => null); + end if; + + else + Descriptor.Filters := + new Filter_List_Elem' + (Filter => Filter, Filter_On => Filter_On, + User_Data => User_Data, Next => Descriptor.Filters); + end if; + end Add_Filter; + + ------------------ + -- Call_Filters -- + ------------------ + + procedure Call_Filters + (Pid : Process_Descriptor'Class; + Str : String; + Filter_On : Filter_Type) + is + Current_Filter : Filter_List; + + begin + if Pid.Filters_Lock = 0 then + Current_Filter := Pid.Filters; + + while Current_Filter /= null loop + if Current_Filter.Filter_On = Filter_On then + Current_Filter.Filter + (Pid, Str, Current_Filter.User_Data); + end if; + + Current_Filter := Current_Filter.Next; + end loop; + end if; + end Call_Filters; + + ----------- + -- Close -- + ----------- + + procedure Close + (Descriptor : in out Process_Descriptor; + Status : out Integer) + is + begin + Close (Descriptor.Input_Fd); + + if Descriptor.Error_Fd /= Descriptor.Output_Fd then + Close (Descriptor.Error_Fd); + end if; + + Close (Descriptor.Output_Fd); + + -- ??? Should have timeouts for different signals + Kill (Descriptor.Pid, 9); + + GNAT.OS_Lib.Free (Descriptor.Buffer); + Descriptor.Buffer_Size := 0; + + Status := Waitpid (Descriptor.Pid); + end Close; + + procedure Close (Descriptor : in out Process_Descriptor) is + Status : Integer; + begin + Close (Descriptor, Status); + end Close; + + ------------ + -- Expect -- + ------------ + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : String; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + begin + if Regexp = "" then + Expect (Descriptor, Result, Never_Match, Timeout, Full_Buffer); + else + Expect (Descriptor, Result, Compile (Regexp), Timeout, Full_Buffer); + end if; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : String; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + begin + pragma Assert (Matched'First = 0); + if Regexp = "" then + Expect + (Descriptor, Result, Never_Match, Matched, Timeout, Full_Buffer); + else + Expect + (Descriptor, Result, Compile (Regexp), Matched, Timeout, + Full_Buffer); + end if; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : GNAT.Regpat.Pattern_Matcher; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + Matched : GNAT.Regpat.Match_Array (0 .. 0); + + begin + Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer); + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : GNAT.Regpat.Pattern_Matcher; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + N : Expect_Match; + Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); + Try_Until : constant Time := Clock + Duration (Timeout) / 1000.0; + Timeout_Tmp : Integer := Timeout; + + begin + pragma Assert (Matched'First = 0); + Reinitialize_Buffer (Descriptor); + + loop + -- First, test if what is already in the buffer matches (This is + -- required if this package is used in multi-task mode, since one of + -- the tasks might have added something in the buffer, and we don't + -- want other tasks to wait for new input to be available before + -- checking the regexps). + + Match + (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); + + if Descriptor.Buffer_Index >= 1 and then Matched (0).First /= 0 then + Result := 1; + Descriptor.Last_Match_Start := Matched (0).First; + Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; + + -- Else try to read new input + + Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer); + + if N = Expect_Timeout or else N = Expect_Full_Buffer then + Result := N; + return; + end if; + + -- Calculate the timeout for the next turn. + -- Note that Timeout is, from the caller's perspective, the maximum + -- time until a match, not the maximum time until some output is + -- read, and thus can not be reused as is for Expect_Internal. + + if Timeout /= -1 then + Timeout_Tmp := Integer (Try_Until - Clock) * 1000; + + if Timeout_Tmp < 0 then + Result := Expect_Timeout; + exit; + end if; + end if; + end loop; + + -- Even if we had the general timeout above, we have to test that the + -- last test we read from the external process didn't match. + + Match + (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); + + if Matched (0).First /= 0 then + Result := 1; + Descriptor.Last_Match_Start := Matched (0).First; + Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Regexp_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + Patterns : Compiled_Regexp_Array (Regexps'Range); + Matched : GNAT.Regpat.Match_Array (0 .. 0); + + begin + for J in Regexps'Range loop + Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); + end loop; + + Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); + + for J in Regexps'Range loop + Free (Patterns (J)); + end loop; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Compiled_Regexp_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + Matched : GNAT.Regpat.Match_Array (0 .. 0); + + begin + Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer); + end Expect; + + procedure Expect + (Result : out Expect_Match; + Regexps : Multiprocess_Regexp_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + Matched : GNAT.Regpat.Match_Array (0 .. 0); + + begin + Expect (Result, Regexps, Matched, Timeout, Full_Buffer); + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + Patterns : Compiled_Regexp_Array (Regexps'Range); + + begin + pragma Assert (Matched'First = 0); + + for J in Regexps'Range loop + Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); + end loop; + + Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); + + for J in Regexps'Range loop + Free (Patterns (J)); + end loop; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Compiled_Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + N : Expect_Match; + Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); + + begin + pragma Assert (Matched'First = 0); + + Reinitialize_Buffer (Descriptor); + + loop + -- First, test if what is already in the buffer matches (This is + -- required if this package is used in multi-task mode, since one of + -- the tasks might have added something in the buffer, and we don't + -- want other tasks to wait for new input to be available before + -- checking the regexps). + + if Descriptor.Buffer /= null then + for J in Regexps'Range loop + Match + (Regexps (J).all, + Descriptor.Buffer (1 .. Descriptor.Buffer_Index), + Matched); + + if Matched (0) /= No_Match then + Result := Expect_Match (J); + Descriptor.Last_Match_Start := Matched (0).First; + Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; + end loop; + end if; + + Expect_Internal (Descriptors, N, Timeout, Full_Buffer); + + if N = Expect_Timeout or else N = Expect_Full_Buffer then + Result := N; + return; + end if; + end loop; + end Expect; + + procedure Expect + (Result : out Expect_Match; + Regexps : Multiprocess_Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10000; + Full_Buffer : Boolean := False) + is + N : Expect_Match; + Descriptors : Array_Of_Pd (Regexps'Range); + + begin + pragma Assert (Matched'First = 0); + + for J in Descriptors'Range loop + Descriptors (J) := Regexps (J).Descriptor; + Reinitialize_Buffer (Regexps (J).Descriptor.all); + end loop; + + loop + -- First, test if what is already in the buffer matches (This is + -- required if this package is used in multi-task mode, since one of + -- the tasks might have added something in the buffer, and we don't + -- want other tasks to wait for new input to be available before + -- checking the regexps). + + for J in Regexps'Range loop + Match (Regexps (J).Regexp.all, + Regexps (J).Descriptor.Buffer + (1 .. Regexps (J).Descriptor.Buffer_Index), + Matched); + + if Matched (0) /= No_Match then + Result := Expect_Match (J); + Regexps (J).Descriptor.Last_Match_Start := Matched (0).First; + Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; + end loop; + + Expect_Internal (Descriptors, N, Timeout, Full_Buffer); + + if N = Expect_Timeout or else N = Expect_Full_Buffer then + Result := N; + return; + end if; + end loop; + end Expect; + + --------------------- + -- Expect_Internal -- + --------------------- + + procedure Expect_Internal + (Descriptors : in out Array_Of_Pd; + Result : out Expect_Match; + Timeout : Integer; + Full_Buffer : Boolean) + is + Num_Descriptors : Integer; + Buffer_Size : Integer := 0; + + N : Integer; + + type File_Descriptor_Array is + array (Descriptors'Range) of File_Descriptor; + Fds : aliased File_Descriptor_Array; + + type Integer_Array is array (Descriptors'Range) of Integer; + Is_Set : aliased Integer_Array; + + begin + for J in Descriptors'Range loop + Fds (J) := Descriptors (J).Output_Fd; + + if Descriptors (J).Buffer_Size = 0 then + Buffer_Size := Integer'Max (Buffer_Size, 4096); + else + Buffer_Size := + Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); + end if; + end loop; + + declare + Buffer : aliased String (1 .. Buffer_Size); + -- Buffer used for input. This is allocated only once, not for + -- every iteration of the loop + + begin + -- Loop until we match or we have a timeout + + loop + Num_Descriptors := + Poll (Fds'Address, Fds'Length, Timeout, Is_Set'Address); + + case Num_Descriptors is + + -- Error? + + when -1 => + raise Process_Died; + + -- Timeout? + + when 0 => + Result := Expect_Timeout; + return; + + -- Some input + + when others => + for J in Descriptors'Range loop + if Is_Set (J) = 1 then + Buffer_Size := Descriptors (J).Buffer_Size; + + if Buffer_Size = 0 then + Buffer_Size := 4096; + end if; + + N := Read (Descriptors (J).Output_Fd, Buffer'Address, + Buffer_Size); + + -- Error or End of file + + if N <= 0 then + -- ??? Note that ddd tries again up to three times + -- in that case. See LiterateA.C:174 + raise Process_Died; + + else + -- If there is no limit to the buffer size + + if Descriptors (J).Buffer_Size = 0 then + + declare + Tmp : String_Access := Descriptors (J).Buffer; + + begin + if Tmp /= null then + Descriptors (J).Buffer := + new String (1 .. Tmp'Length + N); + Descriptors (J).Buffer (1 .. Tmp'Length) := + Tmp.all; + Descriptors (J).Buffer + (Tmp'Length + 1 .. Tmp'Length + N) := + Buffer (1 .. N); + Free (Tmp); + Descriptors (J).Buffer_Index := + Descriptors (J).Buffer'Last; + + else + Descriptors (J).Buffer := + new String (1 .. N); + Descriptors (J).Buffer.all := + Buffer (1 .. N); + Descriptors (J).Buffer_Index := N; + end if; + end; + + else + -- Add what we read to the buffer + + if Descriptors (J).Buffer_Index + N - 1 > + Descriptors (J).Buffer_Size + then + -- If the user wants to know when we have + -- read more than the buffer can contain. + + if Full_Buffer then + Result := Expect_Full_Buffer; + return; + end if; + + -- Keep as much as possible from the buffer, + -- and forget old characters. + + Descriptors (J).Buffer + (1 .. Descriptors (J).Buffer_Size - N) := + Descriptors (J).Buffer + (N - Descriptors (J).Buffer_Size + + Descriptors (J).Buffer_Index + 1 .. + Descriptors (J).Buffer_Index); + Descriptors (J).Buffer_Index := + Descriptors (J).Buffer_Size - N; + end if; + + -- Keep what we read in the buffer. + + Descriptors (J).Buffer + (Descriptors (J).Buffer_Index + 1 .. + Descriptors (J).Buffer_Index + N) := + Buffer (1 .. N); + Descriptors (J).Buffer_Index := + Descriptors (J).Buffer_Index + N; + end if; + + -- Call each of the output filter with what we + -- read. + + Call_Filters + (Descriptors (J).all, Buffer (1 .. N), Output); + + Result := Expect_Match (N); + return; + end if; + end if; + end loop; + end case; + end loop; + end; + end Expect_Internal; + + ---------------- + -- Expect_Out -- + ---------------- + + function Expect_Out (Descriptor : Process_Descriptor) return String is + begin + return Descriptor.Buffer (1 .. Descriptor.Last_Match_End); + end Expect_Out; + + ---------------------- + -- Expect_Out_Match -- + ---------------------- + + function Expect_Out_Match (Descriptor : Process_Descriptor) return String is + begin + return Descriptor.Buffer + (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End); + end Expect_Out_Match; + + ----------- + -- Flush -- + ----------- + + procedure Flush + (Descriptor : in out Process_Descriptor; + Timeout : Integer := 0) + is + Buffer_Size : constant Integer := 8192; + Num_Descriptors : Integer; + N : Integer; + Is_Set : aliased Integer; + Buffer : aliased String (1 .. Buffer_Size); + + begin + -- Empty the current buffer + + Descriptor.Last_Match_End := Descriptor.Buffer_Index; + Reinitialize_Buffer (Descriptor); + + -- Read everything from the process to flush its output + + loop + Num_Descriptors := + Poll (Descriptor.Output_Fd'Address, 1, Timeout, Is_Set'Address); + + case Num_Descriptors is + + -- Error ? + + when -1 => + raise Process_Died; + + -- Timeout => End of flush + + when 0 => + return; + + -- Some input + + when others => + if Is_Set = 1 then + N := Read (Descriptor.Output_Fd, Buffer'Address, + Buffer_Size); + + if N = -1 then + raise Process_Died; + elsif N = 0 then + return; + end if; + end if; + end case; + end loop; + + end Flush; + + ------------------ + -- Get_Error_Fd -- + ------------------ + + function Get_Error_Fd + (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor + is + begin + return Descriptor.Error_Fd; + end Get_Error_Fd; + + ------------------ + -- Get_Input_Fd -- + ------------------ + + function Get_Input_Fd + (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor + is + begin + return Descriptor.Input_Fd; + end Get_Input_Fd; + + ------------------- + -- Get_Output_Fd -- + ------------------- + + function Get_Output_Fd + (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor + is + begin + return Descriptor.Output_Fd; + end Get_Output_Fd; + + ------------- + -- Get_Pid -- + ------------- + + function Get_Pid + (Descriptor : Process_Descriptor) return Process_Id + is + begin + return Descriptor.Pid; + end Get_Pid; + + --------------- + -- Interrupt -- + --------------- + + procedure Interrupt (Descriptor : in out Process_Descriptor) is + SIGINT : constant := 2; + + begin + Send_Signal (Descriptor, SIGINT); + end Interrupt; + + ------------------ + -- Lock_Filters -- + ------------------ + + procedure Lock_Filters (Descriptor : in out Process_Descriptor) is + begin + Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1; + end Lock_Filters; + + ------------------------ + -- Non_Blocking_Spawn -- + ------------------------ + + procedure Non_Blocking_Spawn + (Descriptor : out Process_Descriptor'Class; + Command : String; + Args : GNAT.OS_Lib.Argument_List; + Buffer_Size : Natural := 4096; + Err_To_Out : Boolean := False) + is + function Alloc_Vfork_Blocks return Integer; + pragma Import (C, Alloc_Vfork_Blocks, "decc$$alloc_vfork_blocks"); + + function Get_Vfork_Jmpbuf return System.Address; + pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf"); + + function Get_Current_Invo_Context + (Addr : System.Address) return Process_Id; + pragma Import (C, Get_Current_Invo_Context, + "LIB$GET_CURRENT_INVO_CONTEXT"); + + Pipe1, Pipe2, Pipe3 : aliased Pipe_Type; + + Arg : String_Access; + Arg_List : aliased array (1 .. Args'Length + 2) of System.Address; + + Command_With_Path : String_Access; + + begin + -- Create the rest of the pipes + + Set_Up_Communications + (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); + + Command_With_Path := Locate_Exec_On_Path (Command); + + if Command_With_Path = null then + raise Invalid_Process; + end if; + + -- Fork a new process. It's not possible to do this in a subprogram. + + if Alloc_Vfork_Blocks >= 0 then + Descriptor.Pid := Get_Current_Invo_Context (Get_Vfork_Jmpbuf); + else + Descriptor.Pid := -1; + end if; + + -- Are we now in the child (or, for Windows, still in the common + -- process). + + if Descriptor.Pid = Null_Pid then + -- Prepare an array of arguments to pass to C + + Arg := new String (1 .. Command_With_Path'Length + 1); + Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; + Arg (Arg'Last) := ASCII.Nul; + Arg_List (1) := Arg.all'Address; + + for J in Args'Range loop + Arg := new String (1 .. Args (J)'Length + 1); + Arg (1 .. Args (J)'Length) := Args (J).all; + Arg (Arg'Last) := ASCII.Nul; + Arg_List (J + 2 - Args'First) := Arg.all'Address; + end loop; + + Arg_List (Arg_List'Last) := System.Null_Address; + + -- This does not return on Unix systems + + Set_Up_Child_Communications + (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all, + Arg_List'Address); + end if; + + Free (Command_With_Path); + + -- Did we have an error when spawning the child ? + + if Descriptor.Pid < Null_Pid then + raise Invalid_Process; + else + -- We are now in the parent process + + Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3); + end if; + + -- Create the buffer + + Descriptor.Buffer_Size := Buffer_Size; + + if Buffer_Size /= 0 then + Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); + end if; + end Non_Blocking_Spawn; + + ------------------------- + -- Reinitialize_Buffer -- + ------------------------- + + procedure Reinitialize_Buffer + (Descriptor : in out Process_Descriptor'Class) + is + begin + if Descriptor.Buffer_Size = 0 then + declare + Tmp : String_Access := Descriptor.Buffer; + + begin + Descriptor.Buffer := + new String + (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End); + + if Tmp /= null then + Descriptor.Buffer.all := Tmp + (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); + Free (Tmp); + end if; + end; + + Descriptor.Buffer_Index := Descriptor.Buffer'Last; + + else + Descriptor.Buffer + (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) := + Descriptor.Buffer + (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); + + if Descriptor.Buffer_Index > Descriptor.Last_Match_End then + Descriptor.Buffer_Index := + Descriptor.Buffer_Index - Descriptor.Last_Match_End; + else + Descriptor.Buffer_Index := 0; + end if; + end if; + + Descriptor.Last_Match_Start := 0; + Descriptor.Last_Match_End := 0; + end Reinitialize_Buffer; + + ------------------- + -- Remove_Filter -- + ------------------- + + procedure Remove_Filter + (Descriptor : in out Process_Descriptor; + Filter : Filter_Function) + is + Previous : Filter_List := null; + Current : Filter_List := Descriptor.Filters; + + begin + while Current /= null loop + if Current.Filter = Filter then + if Previous = null then + Descriptor.Filters := Current.Next; + else + Previous.Next := Current.Next; + end if; + end if; + + Previous := Current; + Current := Current.Next; + end loop; + end Remove_Filter; + + ---------- + -- Send -- + ---------- + + procedure Send + (Descriptor : in out Process_Descriptor; + Str : String; + Add_LF : Boolean := True; + Empty_Buffer : Boolean := False) + is + Full_Str : constant String := Str & ASCII.LF; + Last : Natural; + Result : Expect_Match; + Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); + + Discard : Natural; + pragma Unreferenced (Discard); + + begin + if Empty_Buffer then + + -- Force a read on the process if there is anything waiting + + Expect_Internal (Descriptors, Result, + Timeout => 0, Full_Buffer => False); + Descriptor.Last_Match_End := Descriptor.Buffer_Index; + + -- Empty the buffer + + Reinitialize_Buffer (Descriptor); + end if; + + if Add_LF then + Last := Full_Str'Last; + else + Last := Full_Str'Last - 1; + end if; + + Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input); + + Discard := Write (Descriptor.Input_Fd, + Full_Str'Address, + Last - Full_Str'First + 1); + -- Shouldn't we at least have a pragma Assert on the result ??? + end Send; + + ----------------- + -- Send_Signal -- + ----------------- + + procedure Send_Signal + (Descriptor : Process_Descriptor; + Signal : Integer) + is + begin + Kill (Descriptor.Pid, Signal); + -- ??? Need to check process status here. + end Send_Signal; + + --------------------------------- + -- Set_Up_Child_Communications -- + --------------------------------- + + procedure Set_Up_Child_Communications + (Pid : in out Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type; + Cmd : in String; + Args : in System.Address) + is + pragma Warnings (Off, Pid); + + begin + -- Since the code between fork and exec on VMS executes + -- in the context of the parent process, we need to + -- perform the following actions: + -- - save stdin, stdout, stderr + -- - replace them by our pipes + -- - create the child with process handle inheritance + -- - revert to the previous stdin, stdout and stderr. + + Save_Input := Dup (GNAT.OS_Lib.Standin); + Save_Output := Dup (GNAT.OS_Lib.Standout); + Save_Error := Dup (GNAT.OS_Lib.Standerr); + + -- Since we are still called from the parent process, there is no way + -- currently we can cleanly close the unneeded ends of the pipes, but + -- this doesn't really matter. + -- We could close Pipe1.Output, Pipe2.Input, Pipe3.Input. + + Dup2 (Pipe1.Input, GNAT.OS_Lib.Standin); + Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout); + Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr); + + Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.Nul, Args); + + end Set_Up_Child_Communications; + + --------------------------- + -- Set_Up_Communications -- + --------------------------- + + procedure Set_Up_Communications + (Pid : in out Process_Descriptor; + Err_To_Out : Boolean; + Pipe1 : access Pipe_Type; + Pipe2 : access Pipe_Type; + Pipe3 : access Pipe_Type) + is + begin + -- Create the pipes + + if Create_Pipe (Pipe1) /= 0 then + return; + end if; + + if Create_Pipe (Pipe2) /= 0 then + return; + end if; + + Pid.Input_Fd := Pipe1.Output; + Pid.Output_Fd := Pipe2.Input; + + if Err_To_Out then + Pipe3.all := Pipe2.all; + else + if Create_Pipe (Pipe3) /= 0 then + return; + end if; + end if; + + Pid.Error_Fd := Pipe3.Input; + end Set_Up_Communications; + + ---------------------------------- + -- Set_Up_Parent_Communications -- + ---------------------------------- + + procedure Set_Up_Parent_Communications + (Pid : in out Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type) + is + pragma Warnings (Off, Pid); + + begin + + Dup2 (Save_Input, GNAT.OS_Lib.Standin); + Dup2 (Save_Output, GNAT.OS_Lib.Standout); + Dup2 (Save_Error, GNAT.OS_Lib.Standerr); + + Close (Save_Input); + Close (Save_Output); + Close (Save_Error); + + Close (Pipe1.Input); + Close (Pipe2.Output); + Close (Pipe3.Output); + end Set_Up_Parent_Communications; + + ------------------ + -- Trace_Filter -- + ------------------ + + procedure Trace_Filter + (Descriptor : Process_Descriptor'Class; + Str : String; + User_Data : System.Address := System.Null_Address) + is + pragma Warnings (Off, Descriptor); + pragma Warnings (Off, User_Data); + + begin + GNAT.IO.Put (Str); + end Trace_Filter; + + -------------------- + -- Unlock_Filters -- + -------------------- + + procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is + begin + if Descriptor.Filters_Lock > 0 then + Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1; + end if; + end Unlock_Filters; + +end GNAT.Expect; diff --git a/gcc/ada/g-soccon-aix.ads b/gcc/ada/g-soccon-aix.ads new file mode 100644 index 00000000000..0f5fe9d4c6b --- /dev/null +++ b/gcc/ada/g-soccon-aix.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . C O N S T A N T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2003 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 target dependent definitions of constant for use +-- by the GNAT.Sockets package (g-socket.ads). This package should not be +-- directly with'ed by an applications program. + +-- This is the version for AIX + +package GNAT.Sockets.Constants is + + -------------- + -- Families -- + -------------- + + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 24; -- IPv6 address family + + ----------- + -- Modes -- + ----------- + + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket + + ------------------- + -- Socket errors -- + ------------------- + + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 67; -- Address already in use + EADDRNOTAVAIL : constant := 68; -- Cannot assign address + EAFNOSUPPORT : constant := 66; -- Addr family not supported + EALREADY : constant := 56; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 72; -- Connection aborted + ECONNREFUSED : constant := 79; -- Connection refused + ECONNRESET : constant := 73; -- Connection reset by peer + EDESTADDRREQ : constant := 58; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 80; -- Host is down + EHOSTUNREACH : constant := 81; -- No route to host + EINPROGRESS : constant := 55; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 75; -- Socket already connected + ELOOP : constant := 85; -- Too many symbolic lynks + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 59; -- Message too long + ENAMETOOLONG : constant := 86; -- Name too long + ENETDOWN : constant := 69; -- Network is down + ENETRESET : constant := 71; -- Disconn. on network reset + ENETUNREACH : constant := 70; -- Network is unreachable + ENOBUFS : constant := 74; -- No buffer space available + ENOPROTOOPT : constant := 61; -- Protocol not available + ENOTCONN : constant := 76; -- Socket not connected + ENOTSOCK : constant := 57; -- Operation on non socket + EOPNOTSUPP : constant := 64; -- Operation not supported + EPFNOSUPPORT : constant := 65; -- Unknown protocol family + EPROTONOSUPPORT : constant := 62; -- Unknown protocol + EPROTOTYPE : constant := 60; -- Unknown protocol type + ESHUTDOWN : constant := 77; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 63; -- Socket type not supported + ETIMEDOUT : constant := 78; -- Connection timed out + ETOOMANYREFS : constant := 115; -- Too many references + EWOULDBLOCK : constant := 11; -- Operation would block + + ----------------- + -- Host errors -- + ----------------- + + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors + + ------------------- + -- Control flags -- + ------------------- + + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read + + -------------------- + -- Shutdown modes -- + -------------------- + + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send + + --------------------- + -- Protocol levels -- + --------------------- + + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP + + ------------------- + -- Request flags -- + ------------------- + + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + + -------------------- + -- Socket options -- + -------------------- + + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_ERROR : constant := 4103; -- Get/clear error status + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback + +end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-freebsd.ads b/gcc/ada/g-soccon-freebsd.ads new file mode 100644 index 00000000000..cd19222e1a7 --- /dev/null +++ b/gcc/ada/g-soccon-freebsd.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . C O N S T A N T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2003 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 target dependent definitions of constant for use +-- by the GNAT.Sockets package (g-socket.ads). This package should not be +-- directly with'ed by an applications program. + +-- This is the version for i386 FreeBSD + +package GNAT.Sockets.Constants is + + -------------- + -- Families -- + -------------- + + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 28; -- IPv6 address family + + ----------- + -- Modes -- + ----------- + + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket + + ------------------- + -- Socket errors -- + ------------------- + + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 48; -- Address already in use + EADDRNOTAVAIL : constant := 49; -- Cannot assign address + EAFNOSUPPORT : constant := 47; -- Addr family not supported + EALREADY : constant := 37; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 53; -- Connection aborted + ECONNREFUSED : constant := 61; -- Connection refused + ECONNRESET : constant := 54; -- Connection reset by peer + EDESTADDRREQ : constant := 39; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 64; -- Host is down + EHOSTUNREACH : constant := 65; -- No route to host + EINPROGRESS : constant := 36; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 56; -- Socket already connected + ELOOP : constant := 62; -- Too many symbolic lynks + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 40; -- Message too long + ENAMETOOLONG : constant := 63; -- Name too long + ENETDOWN : constant := 50; -- Network is down + ENETRESET : constant := 52; -- Disconn. on network reset + ENETUNREACH : constant := 51; -- Network is unreachable + ENOBUFS : constant := 55; -- No buffer space available + ENOPROTOOPT : constant := 42; -- Protocol not available + ENOTCONN : constant := 57; -- Socket not connected + ENOTSOCK : constant := 38; -- Operation on non socket + EOPNOTSUPP : constant := 45; -- Operation not supported + EPFNOSUPPORT : constant := 46; -- Unknown protocol family + EPROTONOSUPPORT : constant := 43; -- Unknown protocol + EPROTOTYPE : constant := 41; -- Unknown protocol type + ESHUTDOWN : constant := 58; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported + ETIMEDOUT : constant := 60; -- Connection timed out + ETOOMANYREFS : constant := 59; -- Too many references + EWOULDBLOCK : constant := 35; -- Operation would block + + ----------------- + -- Host errors -- + ----------------- + + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors + + ------------------- + -- Control flags -- + ------------------- + + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read + + -------------------- + -- Shutdown modes -- + -------------------- + + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send + + --------------------- + -- Protocol levels -- + --------------------- + + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP + + ------------------- + -- Request flags -- + ------------------- + + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + + -------------------- + -- Socket options -- + -------------------- + + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_ERROR : constant := 4103; -- Get/clear error status + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback + +end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-hpux.ads b/gcc/ada/g-soccon-hpux.ads new file mode 100644 index 00000000000..cbca2bee7a5 --- /dev/null +++ b/gcc/ada/g-soccon-hpux.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . C O N S T A N T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2003 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 target dependent definitions of constant for use +-- by the GNAT.Sockets package (g-socket.ads). This package should not be +-- directly with'ed by an applications program. + +-- This is the version for HP/UX + +package GNAT.Sockets.Constants is + + -------------- + -- Families -- + -------------- + + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 26; -- IPv6 address family + + ----------- + -- Modes -- + ----------- + + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket + + ------------------- + -- Socket errors -- + ------------------- + + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 226; -- Address already in use + EADDRNOTAVAIL : constant := 227; -- Cannot assign address + EAFNOSUPPORT : constant := 225; -- Addr family not supported + EALREADY : constant := 244; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 231; -- Connection aborted + ECONNREFUSED : constant := 239; -- Connection refused + ECONNRESET : constant := 232; -- Connection reset by peer + EDESTADDRREQ : constant := 217; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 241; -- Host is down + EHOSTUNREACH : constant := 242; -- No route to host + EINPROGRESS : constant := 245; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 234; -- Socket already connected + ELOOP : constant := 249; -- Too many symbolic lynks + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 218; -- Message too long + ENAMETOOLONG : constant := 248; -- Name too long + ENETDOWN : constant := 228; -- Network is down + ENETRESET : constant := 230; -- Disconn. on network reset + ENETUNREACH : constant := 229; -- Network is unreachable + ENOBUFS : constant := 233; -- No buffer space available + ENOPROTOOPT : constant := 220; -- Protocol not available + ENOTCONN : constant := 235; -- Socket not connected + ENOTSOCK : constant := 216; -- Operation on non socket + EOPNOTSUPP : constant := 223; -- Operation not supported + EPFNOSUPPORT : constant := 224; -- Unknown protocol family + EPROTONOSUPPORT : constant := 221; -- Unknown protocol + EPROTOTYPE : constant := 219; -- Unknown protocol type + ESHUTDOWN : constant := 236; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 222; -- Socket type not supported + ETIMEDOUT : constant := 238; -- Connection timed out + ETOOMANYREFS : constant := 237; -- Too many references + EWOULDBLOCK : constant := 246; -- Operation would block + + ----------------- + -- Host errors -- + ----------------- + + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors + + ------------------- + -- Control flags -- + ------------------- + + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read + + -------------------- + -- Shutdown modes -- + -------------------- + + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send + + --------------------- + -- Protocol levels -- + --------------------- + + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP + + ------------------- + -- Request flags -- + ------------------- + + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + + -------------------- + -- Socket options -- + -------------------- + + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_ERROR : constant := 4103; -- Get/clear error status + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group + IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback + +end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-interix.ads b/gcc/ada/g-soccon-interix.ads new file mode 100644 index 00000000000..61903079b82 --- /dev/null +++ b/gcc/ada/g-soccon-interix.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . C O N S T A N T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2003 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 target dependent definitions of constant for use +-- by the GNAT.Sockets package (g-socket.ads). This package should not be +-- directly with'ed by an applications program. + +-- This is the version for Interix + +package GNAT.Sockets.Constants is + + -------------- + -- Families -- + -------------- + + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := -1; -- IPv6 address family + + ----------- + -- Modes -- + ----------- + + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket + + ------------------- + -- Socket errors -- + ------------------- + + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 48; -- Address already in use + EADDRNOTAVAIL : constant := 49; -- Cannot assign address + EAFNOSUPPORT : constant := 47; -- Addr family not supported + EALREADY : constant := 37; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 53; -- Connection aborted + ECONNREFUSED : constant := 61; -- Connection refused + ECONNRESET : constant := 54; -- Connection reset by peer + EDESTADDRREQ : constant := 82; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 64; -- Host is down + EHOSTUNREACH : constant := 65; -- No route to host + EINPROGRESS : constant := 80; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 56; -- Socket already connected + ELOOP : constant := 62; -- Too many symbolic lynks + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 83; -- Message too long + ENAMETOOLONG : constant := 38; -- Name too long + ENETDOWN : constant := 50; -- Network is down + ENETRESET : constant := 52; -- Disconn. on network reset + ENETUNREACH : constant := 51; -- Network is unreachable + ENOBUFS : constant := 55; -- No buffer space available + ENOPROTOOPT : constant := 85; -- Protocol not available + ENOTCONN : constant := 57; -- Socket not connected + ENOTSOCK : constant := 81; -- Operation on non socket + EOPNOTSUPP : constant := 45; -- Operation not supported + EPFNOSUPPORT : constant := 46; -- Unknown protocol family + EPROTONOSUPPORT : constant := 43; -- Unknown protocol + EPROTOTYPE : constant := 84; -- Unknown protocol type + ESHUTDOWN : constant := 58; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported + ETIMEDOUT : constant := 60; -- Connection timed out + ETOOMANYREFS : constant := 59; -- Too many references + EWOULDBLOCK : constant := 11; -- Operation would block + + ----------------- + -- Host errors -- + ----------------- + + HOST_NOT_FOUND : constant := 90; -- Unknown host + TRY_AGAIN : constant := 91; -- Host name lookup failure + NO_DATA : constant := 93; -- No data record for name + NO_RECOVERY : constant := 92; -- Non recoverable errors + + ------------------- + -- Control flags -- + ------------------- + + FIONBIO : constant := -2147195390; -- Set/clear non-blocking io + FIONREAD : constant := 1074030081; -- How many bytes to read + + -------------------- + -- Shutdown modes -- + -------------------- + + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send + + --------------------- + -- Protocol levels -- + --------------------- + + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP + + ------------------- + -- Request flags -- + ------------------- + + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + + -------------------- + -- Socket options -- + -------------------- + + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_ERROR : constant := 4103; -- Get/clear error status + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group + IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback + +end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-irix.ads b/gcc/ada/g-soccon-irix.ads new file mode 100644 index 00000000000..f19f3cde5f6 --- /dev/null +++ b/gcc/ada/g-soccon-irix.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . C O N S T A N T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2003 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 target dependent definitions of constant for use +-- by the GNAT.Sockets package (g-socket.ads). This package should not be +-- directly with'ed by an applications program. + +-- This is the version for SGI + +package GNAT.Sockets.Constants is + + -------------- + -- Families -- + -------------- + + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 24; -- IPv6 address family + + ----------- + -- Modes -- + ----------- + + SOCK_STREAM : constant := 2; -- Stream socket + SOCK_DGRAM : constant := 1; -- Datagram socket + + ------------------- + -- Socket errors -- + ------------------- + + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 125; -- Address already in use + EADDRNOTAVAIL : constant := 126; -- Cannot assign address + EAFNOSUPPORT : constant := 124; -- Addr family not supported + EALREADY : constant := 149; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 130; -- Connection aborted + ECONNREFUSED : constant := 146; -- Connection refused + ECONNRESET : constant := 131; -- Connection reset by peer + EDESTADDRREQ : constant := 96; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 147; -- Host is down + EHOSTUNREACH : constant := 148; -- No route to host + EINPROGRESS : constant := 150; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 133; -- Socket already connected + ELOOP : constant := 90; -- Too many symbolic lynks + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 97; -- Message too long + ENAMETOOLONG : constant := 78; -- Name too long + ENETDOWN : constant := 127; -- Network is down + ENETRESET : constant := 129; -- Disconn. on network reset + ENETUNREACH : constant := 128; -- Network is unreachable + ENOBUFS : constant := 132; -- No buffer space available + ENOPROTOOPT : constant := 99; -- Protocol not available + ENOTCONN : constant := 134; -- Socket not connected + ENOTSOCK : constant := 95; -- Operation on non socket + EOPNOTSUPP : constant := 122; -- Operation not supported + EPFNOSUPPORT : constant := 123; -- Unknown protocol family + EPROTONOSUPPORT : constant := 120; -- Unknown protocol + EPROTOTYPE : constant := 98; -- Unknown protocol type + ESHUTDOWN : constant := 143; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported + ETIMEDOUT : constant := 145; -- Connection timed out + ETOOMANYREFS : constant := 144; -- Too many references + EWOULDBLOCK : constant := 11; -- Operation would block + + ----------------- + -- Host errors -- + ----------------- + + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors + + ------------------- + -- Control flags -- + ------------------- + + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read + + -------------------- + -- Shutdown modes -- + -------------------- + + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send + + --------------------- + -- Protocol levels -- + --------------------- + + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP + + ------------------- + -- Request flags -- + ------------------- + + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + + -------------------- + -- Socket options -- + -------------------- + + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_ERROR : constant := 4103; -- Get/clear error status + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + IP_ADD_MEMBERSHIP : constant := 23; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 24; -- Leave a multicast group + IP_MULTICAST_TTL : constant := 21; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 22; -- Set/get mcast loopback + +end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-mingw.ads b/gcc/ada/g-soccon-mingw.ads new file mode 100644 index 00000000000..b4bb31564dc --- /dev/null +++ b/gcc/ada/g-soccon-mingw.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . C O N S T A N T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2003 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 target dependent definitions of constant for use +-- by the GNAT.Sockets package (g-socket.ads). This package should not be +-- directly with'ed by an applications program. + +-- This is the version for MINGW32 NT + +package GNAT.Sockets.Constants is + + -------------- + -- Families -- + -------------- + + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 3; -- IPv6 address family + + ----------- + -- Modes -- + ----------- + + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket + + ------------------- + -- Socket errors -- + ------------------- + + EACCES : constant := 10013; -- Permission denied + EADDRINUSE : constant := 10048; -- Address already in use + EADDRNOTAVAIL : constant := 10049; -- Cannot assign address + EAFNOSUPPORT : constant := 10047; -- Addr family not supported + EALREADY : constant := 10037; -- Operation in progress + EBADF : constant := 10009; -- Bad file descriptor + ECONNABORTED : constant := 10053; -- Connection aborted + ECONNREFUSED : constant := 10061; -- Connection refused + ECONNRESET : constant := 10054; -- Connection reset by peer + EDESTADDRREQ : constant := 10039; -- Destination addr required + EFAULT : constant := 10014; -- Bad address + EHOSTDOWN : constant := 10064; -- Host is down + EHOSTUNREACH : constant := 10065; -- No route to host + EINPROGRESS : constant := 10036; -- Operation now in progress + EINTR : constant := 10004; -- Interrupted system call + EINVAL : constant := 10022; -- Invalid argument + EIO : constant := 10101; -- Input output error + EISCONN : constant := 10056; -- Socket already connected + ELOOP : constant := 10062; -- Too many symbolic lynks + EMFILE : constant := 10024; -- Too many open files + EMSGSIZE : constant := 10040; -- Message too long + ENAMETOOLONG : constant := 10063; -- Name too long + ENETDOWN : constant := 10050; -- Network is down + ENETRESET : constant := 10052; -- Disconn. on network reset + ENETUNREACH : constant := 10051; -- Network is unreachable + ENOBUFS : constant := 10055; -- No buffer space available + ENOPROTOOPT : constant := 10042; -- Protocol not available + ENOTCONN : constant := 10057; -- Socket not connected + ENOTSOCK : constant := 10038; -- Operation on non socket + EOPNOTSUPP : constant := 10045; -- Operation not supported + EPFNOSUPPORT : constant := 10046; -- Unknown protocol family + EPROTONOSUPPORT : constant := 10043; -- Unknown protocol + EPROTOTYPE : constant := 10041; -- Unknown protocol type + ESHUTDOWN : constant := 10058; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 10044; -- Socket type not supported + ETIMEDOUT : constant := 10060; -- Connection timed out + ETOOMANYREFS : constant := 10059; -- Too many references + EWOULDBLOCK : constant := 10035; -- Operation would block + + ----------------- + -- Host errors -- + ----------------- + + HOST_NOT_FOUND : constant := 11001; -- Unknown host + TRY_AGAIN : constant := 11002; -- Host name lookup failure + NO_DATA : constant := 11004; -- No data record for name + NO_RECOVERY : constant := 11003; -- Non recoverable errors + + ------------------- + -- Control flags -- + ------------------- + + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read + + -------------------- + -- Shutdown modes -- + -------------------- + + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send + + --------------------- + -- Protocol levels -- + --------------------- + + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP + + ------------------- + -- Request flags -- + ------------------- + + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := -1; -- Send end of record + MSG_WAITALL : constant := -1; -- Wait for full reception + + -------------------- + -- Socket options -- + -------------------- + + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_ERROR : constant := 4103; -- Get/clear error status + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + IP_ADD_MEMBERSHIP : constant := 5; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 6; -- Leave a multicast group + IP_MULTICAST_TTL : constant := 3; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 4; -- Set/get mcast loopback + +end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-solaris.ads b/gcc/ada/g-soccon-solaris.ads new file mode 100644 index 00000000000..1ad58838ca9 --- /dev/null +++ b/gcc/ada/g-soccon-solaris.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . C O N S T A N T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2003 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 target dependent definitions of constant for use +-- by the GNAT.Sockets package (g-socket.ads). This package should not be +-- directly with'ed by an applications program. + +-- This is the version for Solaris + +package GNAT.Sockets.Constants is + + -------------- + -- Families -- + -------------- + + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 26; -- IPv6 address family + + ----------- + -- Modes -- + ----------- + + SOCK_STREAM : constant := 2; -- Stream socket + SOCK_DGRAM : constant := 1; -- Datagram socket + + ------------------- + -- Socket errors -- + ------------------- + + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 125; -- Address already in use + EADDRNOTAVAIL : constant := 126; -- Cannot assign address + EAFNOSUPPORT : constant := 124; -- Addr family not supported + EALREADY : constant := 149; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 130; -- Connection aborted + ECONNREFUSED : constant := 146; -- Connection refused + ECONNRESET : constant := 131; -- Connection reset by peer + EDESTADDRREQ : constant := 96; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 147; -- Host is down + EHOSTUNREACH : constant := 148; -- No route to host + EINPROGRESS : constant := 150; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 133; -- Socket already connected + ELOOP : constant := 90; -- Too many symbolic lynks + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 97; -- Message too long + ENAMETOOLONG : constant := 78; -- Name too long + ENETDOWN : constant := 127; -- Network is down + ENETRESET : constant := 129; -- Disconn. on network reset + ENETUNREACH : constant := 128; -- Network is unreachable + ENOBUFS : constant := 132; -- No buffer space available + ENOPROTOOPT : constant := 99; -- Protocol not available + ENOTCONN : constant := 134; -- Socket not connected + ENOTSOCK : constant := 95; -- Operation on non socket + EOPNOTSUPP : constant := 122; -- Operation not supported + EPFNOSUPPORT : constant := 123; -- Unknown protocol family + EPROTONOSUPPORT : constant := 120; -- Unknown protocol + EPROTOTYPE : constant := 98; -- Unknown protocol type + ESHUTDOWN : constant := 143; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported + ETIMEDOUT : constant := 145; -- Connection timed out + ETOOMANYREFS : constant := 144; -- Too many references + EWOULDBLOCK : constant := 11; -- Operation would block + + ----------------- + -- Host errors -- + ----------------- + + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors + + ------------------- + -- Control flags -- + ------------------- + + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read + + -------------------- + -- Shutdown modes -- + -------------------- + + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send + + --------------------- + -- Protocol levels -- + --------------------- + + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP + + ------------------- + -- Request flags -- + ------------------- + + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + + -------------------- + -- Socket options -- + -------------------- + + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_ERROR : constant := 4103; -- Get/clear error status + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + IP_ADD_MEMBERSHIP : constant := 19; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 20; -- Leave a multicast group + IP_MULTICAST_TTL : constant := 17; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 18; -- Set/get mcast loopback + +end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-tru64.ads b/gcc/ada/g-soccon-tru64.ads new file mode 100644 index 00000000000..ef3536e4bbc --- /dev/null +++ b/gcc/ada/g-soccon-tru64.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . C O N S T A N T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2003 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 target dependent definitions of constant for use +-- by the GNAT.Sockets package (g-socket.ads). This package should not be +-- directly with'ed by an applications program. + +-- This is the version for OSF + +package GNAT.Sockets.Constants is + + -------------- + -- Families -- + -------------- + + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 26; -- IPv6 address family + + ----------- + -- Modes -- + ----------- + + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket + + ------------------- + -- Socket errors -- + ------------------- + + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 48; -- Address already in use + EADDRNOTAVAIL : constant := 49; -- Cannot assign address + EAFNOSUPPORT : constant := 47; -- Addr family not supported + EALREADY : constant := 37; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 53; -- Connection aborted + ECONNREFUSED : constant := 61; -- Connection refused + ECONNRESET : constant := 54; -- Connection reset by peer + EDESTADDRREQ : constant := 39; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 64; -- Host is down + EHOSTUNREACH : constant := 65; -- No route to host + EINPROGRESS : constant := 36; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 56; -- Socket already connected + ELOOP : constant := 62; -- Too many symbolic lynks + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 40; -- Message too long + ENAMETOOLONG : constant := 63; -- Name too long + ENETDOWN : constant := 50; -- Network is down + ENETRESET : constant := 52; -- Disconn. on network reset + ENETUNREACH : constant := 51; -- Network is unreachable + ENOBUFS : constant := 55; -- No buffer space available + ENOPROTOOPT : constant := 42; -- Protocol not available + ENOTCONN : constant := 57; -- Socket not connected + ENOTSOCK : constant := 38; -- Operation on non socket + EOPNOTSUPP : constant := 45; -- Operation not supported + EPFNOSUPPORT : constant := 46; -- Unknown protocol family + EPROTONOSUPPORT : constant := 43; -- Unknown protocol + EPROTOTYPE : constant := 41; -- Unknown protocol type + ESHUTDOWN : constant := 58; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported + ETIMEDOUT : constant := 60; -- Connection timed out + ETOOMANYREFS : constant := 59; -- Too many references + EWOULDBLOCK : constant := 35; -- Operation would block + + ----------------- + -- Host errors -- + ----------------- + + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors + + ------------------- + -- Control flags -- + ------------------- + + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read + + -------------------- + -- Shutdown modes -- + -------------------- + + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send + + --------------------- + -- Protocol levels -- + --------------------- + + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP + + ------------------- + -- Request flags -- + ------------------- + + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + + -------------------- + -- Socket options -- + -------------------- + + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_ERROR : constant := 4103; -- Get/clear error status + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback + +end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-unixware.ads b/gcc/ada/g-soccon-unixware.ads new file mode 100644 index 00000000000..9f7065f6ffe --- /dev/null +++ b/gcc/ada/g-soccon-unixware.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . C O N S T A N T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2003 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 target dependent definitions of constant for use +-- by the GNAT.Sockets package (g-socket.ads). This package should not be +-- directly with'ed by an applications program. + +-- This is the version for UnixWare + +package GNAT.Sockets.Constants is + + -------------- + -- Families -- + -------------- + + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 27; -- IPv6 address family + + ----------- + -- Modes -- + ----------- + + SOCK_STREAM : constant := 2; -- Stream socket + SOCK_DGRAM : constant := 1; -- Datagram socket + + ------------------- + -- Socket errors -- + ------------------- + + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 125; -- Address already in use + EADDRNOTAVAIL : constant := 126; -- Cannot assign address + EAFNOSUPPORT : constant := 124; -- Addr family not supported + EALREADY : constant := 149; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 130; -- Connection aborted + ECONNREFUSED : constant := 146; -- Connection refused + ECONNRESET : constant := 131; -- Connection reset by peer + EDESTADDRREQ : constant := 96; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 147; -- Host is down + EHOSTUNREACH : constant := 148; -- No route to host + EINPROGRESS : constant := 150; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 133; -- Socket already connected + ELOOP : constant := 90; -- Too many symbolic lynks + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 97; -- Message too long + ENAMETOOLONG : constant := 78; -- Name too long + ENETDOWN : constant := 127; -- Network is down + ENETRESET : constant := 129; -- Disconn. on network reset + ENETUNREACH : constant := 128; -- Network is unreachable + ENOBUFS : constant := 132; -- No buffer space available + ENOPROTOOPT : constant := 99; -- Protocol not available + ENOTCONN : constant := 134; -- Socket not connected + ENOTSOCK : constant := 95; -- Operation on non socket + EOPNOTSUPP : constant := 122; -- Operation not supported + EPFNOSUPPORT : constant := 123; -- Unknown protocol family + EPROTONOSUPPORT : constant := 120; -- Unknown protocol + EPROTOTYPE : constant := 98; -- Unknown protocol type + ESHUTDOWN : constant := 143; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 121; -- Socket type not supported + ETIMEDOUT : constant := 145; -- Connection timed out + ETOOMANYREFS : constant := 144; -- Too many references + EWOULDBLOCK : constant := 11; -- Operation would block + + ----------------- + -- Host errors -- + ----------------- + + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors + + ------------------- + -- Control flags -- + ------------------- + + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read + + -------------------- + -- Shutdown modes -- + -------------------- + + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send + + --------------------- + -- Protocol levels -- + --------------------- + + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP + + ------------------- + -- Request flags -- + ------------------- + + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + + -------------------- + -- Socket options -- + -------------------- + + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_ERROR : constant := 4103; -- Get/clear error status + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + IP_ADD_MEMBERSHIP : constant := 11; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 12; -- Leave a multicast group + IP_MULTICAST_TTL : constant := 16; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 10; -- Set/get mcast loopback + +end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-vms.adb b/gcc/ada/g-soccon-vms.adb new file mode 100644 index 00000000000..76b2051e07c --- /dev/null +++ b/gcc/ada/g-soccon-vms.adb @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . C O N S T A N T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2003 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 target dependent definitions of constant for use +-- by the GNAT.Sockets package (g-socket.ads). This package should not be +-- directly with'ed by an applications program. + +-- This is the version for Alpha/VMS + +package GNAT.Sockets.Constants is + + -------------- + -- Families -- + -------------- + + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := 26; -- IPv6 address family + + ----------- + -- Modes -- + ----------- + + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket + + ------------------- + -- Socket errors -- + ------------------- + + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 48; -- Address already in use + EADDRNOTAVAIL : constant := 49; -- Cannot assign address + EAFNOSUPPORT : constant := 47; -- Addr family not supported + EALREADY : constant := 37; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 53; -- Connection aborted + ECONNREFUSED : constant := 61; -- Connection refused + ECONNRESET : constant := 54; -- Connection reset by peer + EDESTADDRREQ : constant := 39; -- Destination addr required + EFAULT : constant := 45; -- Bad address + EHOSTDOWN : constant := 64; -- Host is down + EHOSTUNREACH : constant := 65; -- No route to host + EINPROGRESS : constant := 36; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 56; -- Socket already connected + ELOOP : constant := 62; -- Too many symbolic lynks + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 40; -- Message too long + ENAMETOOLONG : constant := 63; -- Name too long + ENETDOWN : constant := 50; -- Network is down + ENETRESET : constant := 52; -- Disconn. on network reset + ENETUNREACH : constant := 51; -- Network is unreachable + ENOBUFS : constant := 55; -- No buffer space available + ENOPROTOOPT : constant := 42; -- Protocol not available + ENOTCONN : constant := 57; -- Socket not connected + ENOTSOCK : constant := 38; -- Operation on non socket + EOPNOTSUPP : constant := 95; -- Operation not supported + EPFNOSUPPORT : constant := 46; -- Unknown protocol family + EPROTONOSUPPORT : constant := 43; -- Unknown protocol + EPROTOTYPE : constant := 41; -- Unknown protocol type + ESHUTDOWN : constant := 58; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported + ETIMEDOUT : constant := 60; -- Connection timed out + ETOOMANYREFS : constant := 59; -- Too many references + EWOULDBLOCK : constant := 35; -- Operation would block + + ----------------- + -- Host errors -- + ----------------- + + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors + + ------------------- + -- Control flags -- + ------------------- + + FIONBIO : constant := -2147195266; -- Set/clear non-blocking io + FIONREAD : constant := 1074030207; -- How many bytes to read + + -------------------- + -- Shutdown modes -- + -------------------- + + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send + + --------------------- + -- Protocol levels -- + --------------------- + + SOL_SOCKET : constant := 16#FFFF#; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP + + ------------------- + -- Request flags -- + ------------------- + + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + + -------------------- + -- Socket options -- + -------------------- + + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_SNDBUF : constant := 16#1001#; -- Set/get send buffer size + SO_RCVBUF : constant := 16#1002#; -- Set/get recv buffer size + SO_REUSEADDR : constant := 16#0004#; -- Bind reuse local address + SO_KEEPALIVE : constant := 16#0008#; -- Enable keep-alive msgs + SO_LINGER : constant := 16#0080#; -- Defer close to flush data + SO_ERROR : constant := 16#1007#; -- Get/clear error status + SO_BROADCAST : constant := 16#0020#; -- Can send broadcast msgs + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback + +end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-vxworks.ads b/gcc/ada/g-soccon-vxworks.ads new file mode 100644 index 00000000000..27dcb0c7a9e --- /dev/null +++ b/gcc/ada/g-soccon-vxworks.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . C O N S T A N T S -- +-- -- +-- S p e c -- +-- -- +-- 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 package provides target dependent definitions of constant for use +-- by the GNAT.Sockets package (g-socket.ads). This package should not be +-- directly with'ed by an applications program. + +-- This is the version for VxWorks + +package GNAT.Sockets.Constants is + + -------------- + -- Families -- + -------------- + + AF_INET : constant := 2; -- IPv4 address family + AF_INET6 : constant := -1; -- IPv6 address family + + ----------- + -- Modes -- + ----------- + + SOCK_STREAM : constant := 1; -- Stream socket + SOCK_DGRAM : constant := 2; -- Datagram socket + + ------------------- + -- Socket errors -- + ------------------- + + EACCES : constant := 13; -- Permission denied + EADDRINUSE : constant := 48; -- Address already in use + EADDRNOTAVAIL : constant := 49; -- Cannot assign address + EAFNOSUPPORT : constant := 47; -- Addr family not supported + EALREADY : constant := 69; -- Operation in progress + EBADF : constant := 9; -- Bad file descriptor + ECONNABORTED : constant := 53; -- Connection aborted + ECONNREFUSED : constant := 61; -- Connection refused + ECONNRESET : constant := 54; -- Connection reset by peer + EDESTADDRREQ : constant := 40; -- Destination addr required + EFAULT : constant := 14; -- Bad address + EHOSTDOWN : constant := 67; -- Host is down + EHOSTUNREACH : constant := 65; -- No route to host + EINPROGRESS : constant := 68; -- Operation now in progress + EINTR : constant := 4; -- Interrupted system call + EINVAL : constant := 22; -- Invalid argument + EIO : constant := 5; -- Input output error + EISCONN : constant := 56; -- Socket already connected + ELOOP : constant := 64; -- Too many symbolic lynks + EMFILE : constant := 24; -- Too many open files + EMSGSIZE : constant := 36; -- Message too long + ENAMETOOLONG : constant := 26; -- Name too long + ENETDOWN : constant := 62; -- Network is down + ENETRESET : constant := 52; -- Disconn. on network reset + ENETUNREACH : constant := 51; -- Network is unreachable + ENOBUFS : constant := 55; -- No buffer space available + ENOPROTOOPT : constant := 42; -- Protocol not available + ENOTCONN : constant := 57; -- Socket not connected + ENOTSOCK : constant := 50; -- Operation on non socket + EOPNOTSUPP : constant := 45; -- Operation not supported + EPFNOSUPPORT : constant := 46; -- Unknown protocol family + EPROTONOSUPPORT : constant := 43; -- Unknown protocol + EPROTOTYPE : constant := 41; -- Unknown protocol type + ESHUTDOWN : constant := 58; -- Cannot send once shutdown + ESOCKTNOSUPPORT : constant := 44; -- Socket type not supported + ETIMEDOUT : constant := 60; -- Connection timed out + ETOOMANYREFS : constant := 59; -- Too many references + EWOULDBLOCK : constant := 70; -- Operation would block + + ----------------- + -- Host errors -- + ----------------- + + HOST_NOT_FOUND : constant := 1; -- Unknown host + TRY_AGAIN : constant := 2; -- Host name lookup failure + NO_DATA : constant := 4; -- No data record for name + NO_RECOVERY : constant := 3; -- Non recoverable errors + + ------------------- + -- Control flags -- + ------------------- + + FIONBIO : constant := 16; -- Set/clear non-blocking io + FIONREAD : constant := 1; -- How many bytes to read + + -------------------- + -- Shutdown modes -- + -------------------- + + SHUT_RD : constant := 0; -- No more recv + SHUT_WR : constant := 1; -- No more send + SHUT_RDWR : constant := 2; -- No more recv/send + + --------------------- + -- Protocol levels -- + --------------------- + + SOL_SOCKET : constant := 65535; -- Options for socket level + IPPROTO_IP : constant := 0; -- Dummy protocol for IP + IPPROTO_UDP : constant := 17; -- UDP + IPPROTO_TCP : constant := 6; -- TCP + + ------------------- + -- Request flags -- + ------------------- + + MSG_OOB : constant := 1; -- Process out-of-band data + MSG_PEEK : constant := 2; -- Peek at incoming data + MSG_EOR : constant := 8; -- Send end of record + MSG_WAITALL : constant := 64; -- Wait for full reception + + -------------------- + -- Socket options -- + -------------------- + + TCP_NODELAY : constant := 1; -- Do not coalesce packets + SO_SNDBUF : constant := 4097; -- Set/get send buffer size + SO_RCVBUF : constant := 4098; -- Set/get recv buffer size + SO_REUSEADDR : constant := 4; -- Bind reuse local address + SO_KEEPALIVE : constant := 8; -- Enable keep-alive msgs + SO_LINGER : constant := 128; -- Defer close to flush data + SO_ERROR : constant := 4103; -- Get/clear error status + SO_BROADCAST : constant := 32; -- Can send broadcast msgs + IP_ADD_MEMBERSHIP : constant := 12; -- Join a multicast group + IP_DROP_MEMBERSHIP : constant := 13; -- Leave a multicast group + IP_MULTICAST_TTL : constant := 10; -- Set/get multicast TTL + IP_MULTICAST_LOOP : constant := 11; -- Set/get mcast loopback + +end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-socthi-mingw.adb b/gcc/ada/g-socthi-mingw.adb new file mode 100644 index 00000000000..a948bdeedfa --- /dev/null +++ b/gcc/ada/g-socthi-mingw.adb @@ -0,0 +1,587 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2004 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 package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This version is for NT. + +with GNAT.Sockets.Constants; use GNAT.Sockets.Constants; +with Interfaces.C.Strings; use Interfaces.C.Strings; + +with System; use System; + +package body GNAT.Sockets.Thin is + + use type C.unsigned; + + WSAData_Dummy : array (1 .. 512) of C.int; + + WS_Version : constant := 16#0101#; + Initialized : Boolean := False; + + SYSNOTREADY : constant := 10091; + VERNOTSUPPORTED : constant := 10092; + NOTINITIALISED : constant := 10093; + EDISCON : constant := 10101; + + function Standard_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) + return C.int; + pragma Import (Stdcall, Standard_Connect, "connect"); + + function Standard_Select + (Nfds : C.int; + Readfds : Fd_Set_Access; + Writefds : Fd_Set_Access; + Exceptfds : Fd_Set_Access; + Timeout : Timeval_Access) + return C.int; + pragma Import (Stdcall, Standard_Select, "select"); + + type Error_Type is + (N_EINTR, + N_EBADF, + N_EACCES, + N_EFAULT, + N_EINVAL, + N_EMFILE, + N_EWOULDBLOCK, + N_EINPROGRESS, + N_EALREADY, + N_ENOTSOCK, + N_EDESTADDRREQ, + N_EMSGSIZE, + N_EPROTOTYPE, + N_ENOPROTOOPT, + N_EPROTONOSUPPORT, + N_ESOCKTNOSUPPORT, + N_EOPNOTSUPP, + N_EPFNOSUPPORT, + N_EAFNOSUPPORT, + N_EADDRINUSE, + N_EADDRNOTAVAIL, + N_ENETDOWN, + N_ENETUNREACH, + N_ENETRESET, + N_ECONNABORTED, + N_ECONNRESET, + N_ENOBUFS, + N_EISCONN, + N_ENOTCONN, + N_ESHUTDOWN, + N_ETOOMANYREFS, + N_ETIMEDOUT, + N_ECONNREFUSED, + N_ELOOP, + N_ENAMETOOLONG, + N_EHOSTDOWN, + N_EHOSTUNREACH, + N_SYSNOTREADY, + N_VERNOTSUPPORTED, + N_NOTINITIALISED, + N_EDISCON, + N_HOST_NOT_FOUND, + N_TRY_AGAIN, + N_NO_RECOVERY, + N_NO_DATA, + N_OTHERS); + + Error_Messages : constant array (Error_Type) of chars_ptr := + (N_EINTR => + New_String ("Interrupted system call"), + N_EBADF => + New_String ("Bad file number"), + N_EACCES => + New_String ("Permission denied"), + N_EFAULT => + New_String ("Bad address"), + N_EINVAL => + New_String ("Invalid argument"), + N_EMFILE => + New_String ("Too many open files"), + N_EWOULDBLOCK => + New_String ("Operation would block"), + N_EINPROGRESS => + New_String ("Operation now in progress. This error is " + & "returned if any Windows Sockets API " + & "function is called while a blocking " + & "function is in progress"), + N_EALREADY => + New_String ("Operation already in progress"), + N_ENOTSOCK => + New_String ("Socket operation on nonsocket"), + N_EDESTADDRREQ => + New_String ("Destination address required"), + N_EMSGSIZE => + New_String ("Message too long"), + N_EPROTOTYPE => + New_String ("Protocol wrong type for socket"), + N_ENOPROTOOPT => + New_String ("Protocol not available"), + N_EPROTONOSUPPORT => + New_String ("Protocol not supported"), + N_ESOCKTNOSUPPORT => + New_String ("Socket type not supported"), + N_EOPNOTSUPP => + New_String ("Operation not supported on socket"), + N_EPFNOSUPPORT => + New_String ("Protocol family not supported"), + N_EAFNOSUPPORT => + New_String ("Address family not supported by protocol family"), + N_EADDRINUSE => + New_String ("Address already in use"), + N_EADDRNOTAVAIL => + New_String ("Cannot assign requested address"), + N_ENETDOWN => + New_String ("Network is down. This error may be " + & "reported at any time if the Windows " + & "Sockets implementation detects an " + & "underlying failure"), + N_ENETUNREACH => + New_String ("Network is unreachable"), + N_ENETRESET => + New_String ("Network dropped connection on reset"), + N_ECONNABORTED => + New_String ("Software caused connection abort"), + N_ECONNRESET => + New_String ("Connection reset by peer"), + N_ENOBUFS => + New_String ("No buffer space available"), + N_EISCONN => + New_String ("Socket is already connected"), + N_ENOTCONN => + New_String ("Socket is not connected"), + N_ESHUTDOWN => + New_String ("Cannot send after socket shutdown"), + N_ETOOMANYREFS => + New_String ("Too many references: cannot splice"), + N_ETIMEDOUT => + New_String ("Connection timed out"), + N_ECONNREFUSED => + New_String ("Connection refused"), + N_ELOOP => + New_String ("Too many levels of symbolic links"), + N_ENAMETOOLONG => + New_String ("File name too long"), + N_EHOSTDOWN => + New_String ("Host is down"), + N_EHOSTUNREACH => + New_String ("No route to host"), + N_SYSNOTREADY => + New_String ("Returned by WSAStartup(), indicating that " + & "the network subsystem is unusable"), + N_VERNOTSUPPORTED => + New_String ("Returned by WSAStartup(), indicating that " + & "the Windows Sockets DLL cannot support " + & "this application"), + N_NOTINITIALISED => + New_String ("Winsock not initialized. This message is " + & "returned by any function except WSAStartup(), " + & "indicating that a successful WSAStartup() has " + & "not yet been performed"), + N_EDISCON => + New_String ("Disconnect"), + N_HOST_NOT_FOUND => + New_String ("Host not found. This message indicates " + & "that the key (name, address, and so on) was not found"), + N_TRY_AGAIN => + New_String ("Nonauthoritative host not found. This error may " + & "suggest that the name service itself is not " + & "functioning"), + N_NO_RECOVERY => + New_String ("Nonrecoverable error. This error may suggest that the " + & "name service itself is not functioning"), + N_NO_DATA => + New_String ("Valid name, no data record of requested type. " + & "This error indicates that the key (name, address, " + & "and so on) was not found."), + N_OTHERS => + New_String ("Unknown system error")); + + --------------- + -- C_Connect -- + --------------- + + function C_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) + return C.int + is + Res : C.int; + + begin + Res := Standard_Connect (S, Name, Namelen); + + if Res = -1 then + if Socket_Errno = EWOULDBLOCK then + Set_Socket_Errno (EINPROGRESS); + end if; + end if; + + return Res; + end C_Connect; + + ------------- + -- C_Readv -- + ------------- + + function C_Readv + (Socket : C.int; + Iov : System.Address; + Iovcnt : C.int) + return C.int + is + Res : C.int; + Count : C.int := 0; + + Iovec : array (0 .. Iovcnt - 1) of Vector_Element; + for Iovec'Address use Iov; + pragma Import (Ada, Iovec); + + begin + for J in Iovec'Range loop + Res := C_Recv + (Socket, + Iovec (J).Base.all'Address, + C.int (Iovec (J).Length), + 0); + + if Res < 0 then + return Res; + else + Count := Count + Res; + end if; + end loop; + return Count; + end C_Readv; + + -------------- + -- C_Select -- + -------------- + + function C_Select + (Nfds : C.int; + Readfds : Fd_Set_Access; + Writefds : Fd_Set_Access; + Exceptfds : Fd_Set_Access; + Timeout : Timeval_Access) + return C.int + is + pragma Warnings (Off, Exceptfds); + + RFS : constant Fd_Set_Access := Readfds; + WFS : constant Fd_Set_Access := Writefds; + WFSC : Fd_Set_Access := No_Fd_Set; + EFS : Fd_Set_Access := Exceptfds; + Res : C.int; + S : aliased C.int; + Last : aliased C.int; + + begin + -- Asynchronous connection failures are notified in the + -- exception fd set instead of the write fd set. To ensure + -- POSIX compatitibility, copy write fd set into exception fd + -- set. Once select() returns, check any socket present in the + -- exception fd set and peek at incoming out-of-band data. If + -- the test is not successfull and if the socket is present in + -- the initial write fd set, then move the socket from the + -- exception fd set to the write fd set. + + if WFS /= No_Fd_Set then + -- Add any socket present in write fd set into exception fd set + + if EFS = No_Fd_Set then + EFS := New_Socket_Set (WFS); + + else + WFSC := New_Socket_Set (WFS); + + Last := Nfds - 1; + loop + Get_Socket_From_Set + (WFSC, S'Unchecked_Access, Last'Unchecked_Access); + exit when S = -1; + Insert_Socket_In_Set (EFS, S); + end loop; + + Free_Socket_Set (WFSC); + end if; + + -- Keep a copy of write fd set + + WFSC := New_Socket_Set (WFS); + end if; + + Res := Standard_Select (Nfds, RFS, WFS, EFS, Timeout); + + if EFS /= No_Fd_Set then + declare + EFSC : constant Fd_Set_Access := New_Socket_Set (EFS); + Flag : constant C.int := MSG_PEEK + MSG_OOB; + Buffer : Character; + Length : C.int; + Fromlen : aliased C.int; + + begin + Last := Nfds - 1; + loop + Get_Socket_From_Set + (EFSC, S'Unchecked_Access, Last'Unchecked_Access); + + -- No more sockets in EFSC + + exit when S = -1; + + -- Check out-of-band data + + Length := C_Recvfrom + (S, Buffer'Address, 1, Flag, + null, Fromlen'Unchecked_Access); + + -- If the signal is not an out-of-band data, then it + -- is a connection failure notification. + + if Length = -1 then + Remove_Socket_From_Set (EFS, S); + + -- If S is present in the initial write fd set, + -- move it from exception fd set back to write fd + -- set. Otherwise, ignore this event since the user + -- is not watching for it. + + if WFSC /= No_Fd_Set + and then Is_Socket_In_Set (WFSC, S) + then + Insert_Socket_In_Set (WFS, S); + end if; + end if; + end loop; + + Free_Socket_Set (EFSC); + end; + + if Exceptfds = No_Fd_Set then + Free_Socket_Set (EFS); + end if; + end if; + + -- Free any copy of write fd set + + if WFSC /= No_Fd_Set then + Free_Socket_Set (WFSC); + end if; + + return Res; + end C_Select; + + -------------- + -- C_Writev -- + -------------- + + function C_Writev + (Socket : C.int; + Iov : System.Address; + Iovcnt : C.int) + return C.int + is + Res : C.int; + Count : C.int := 0; + + Iovec : array (0 .. Iovcnt - 1) of Vector_Element; + for Iovec'Address use Iov; + pragma Import (Ada, Iovec); + + begin + for J in Iovec'Range loop + Res := C_Send + (Socket, + Iovec (J).Base.all'Address, + C.int (Iovec (J).Length), + 0); + + if Res < 0 then + return Res; + else + Count := Count + Res; + end if; + end loop; + return Count; + end C_Writev; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + if Initialized then + WSACleanup; + Initialized := False; + end if; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Process_Blocking_IO : Boolean := False) is + pragma Unreferenced (Process_Blocking_IO); + + Return_Value : Interfaces.C.int; + + begin + if not Initialized then + Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address); + pragma Assert (Interfaces.C."=" (Return_Value, 0)); + Initialized := True; + end if; + end Initialize; + + ----------------- + -- Set_Address -- + ----------------- + + procedure Set_Address + (Sin : Sockaddr_In_Access; + Address : In_Addr) + is + begin + Sin.Sin_Addr := Address; + end Set_Address; + + ---------------- + -- Set_Family -- + ---------------- + + procedure Set_Family + (Sin : Sockaddr_In_Access; + Family : C.int) + is + begin + Sin.Sin_Family := C.unsigned_short (Family); + end Set_Family; + + ---------------- + -- Set_Length -- + ---------------- + + procedure Set_Length + (Sin : Sockaddr_In_Access; + Len : C.int) + is + pragma Unreferenced (Sin); + pragma Unreferenced (Len); + + begin + null; + end Set_Length; + + -------------- + -- Set_Port -- + -------------- + + procedure Set_Port + (Sin : Sockaddr_In_Access; + Port : C.unsigned_short) + is + begin + Sin.Sin_Port := Port; + end Set_Port; + + -------------------------- + -- Socket_Error_Message -- + -------------------------- + + function Socket_Error_Message + (Errno : Integer) + return C.Strings.chars_ptr + is + use GNAT.Sockets.Constants; + + begin + case Errno is + when EINTR => return Error_Messages (N_EINTR); + when EBADF => return Error_Messages (N_EBADF); + when EACCES => return Error_Messages (N_EACCES); + when EFAULT => return Error_Messages (N_EFAULT); + when EINVAL => return Error_Messages (N_EINVAL); + when EMFILE => return Error_Messages (N_EMFILE); + when EWOULDBLOCK => return Error_Messages (N_EWOULDBLOCK); + when EINPROGRESS => return Error_Messages (N_EINPROGRESS); + when EALREADY => return Error_Messages (N_EALREADY); + when ENOTSOCK => return Error_Messages (N_ENOTSOCK); + when EDESTADDRREQ => return Error_Messages (N_EDESTADDRREQ); + when EMSGSIZE => return Error_Messages (N_EMSGSIZE); + when EPROTOTYPE => return Error_Messages (N_EPROTOTYPE); + when ENOPROTOOPT => return Error_Messages (N_ENOPROTOOPT); + when EPROTONOSUPPORT => return Error_Messages (N_EPROTONOSUPPORT); + when ESOCKTNOSUPPORT => return Error_Messages (N_ESOCKTNOSUPPORT); + when EOPNOTSUPP => return Error_Messages (N_EOPNOTSUPP); + when EPFNOSUPPORT => return Error_Messages (N_EPFNOSUPPORT); + when EAFNOSUPPORT => return Error_Messages (N_EAFNOSUPPORT); + when EADDRINUSE => return Error_Messages (N_EADDRINUSE); + when EADDRNOTAVAIL => return Error_Messages (N_EADDRNOTAVAIL); + when ENETDOWN => return Error_Messages (N_ENETDOWN); + when ENETUNREACH => return Error_Messages (N_ENETUNREACH); + when ENETRESET => return Error_Messages (N_ENETRESET); + when ECONNABORTED => return Error_Messages (N_ECONNABORTED); + when ECONNRESET => return Error_Messages (N_ECONNRESET); + when ENOBUFS => return Error_Messages (N_ENOBUFS); + when EISCONN => return Error_Messages (N_EISCONN); + when ENOTCONN => return Error_Messages (N_ENOTCONN); + when ESHUTDOWN => return Error_Messages (N_ESHUTDOWN); + when ETOOMANYREFS => return Error_Messages (N_ETOOMANYREFS); + when ETIMEDOUT => return Error_Messages (N_ETIMEDOUT); + when ECONNREFUSED => return Error_Messages (N_ECONNREFUSED); + when ELOOP => return Error_Messages (N_ELOOP); + when ENAMETOOLONG => return Error_Messages (N_ENAMETOOLONG); + when EHOSTDOWN => return Error_Messages (N_EHOSTDOWN); + when EHOSTUNREACH => return Error_Messages (N_EHOSTUNREACH); + when SYSNOTREADY => return Error_Messages (N_SYSNOTREADY); + when VERNOTSUPPORTED => return Error_Messages (N_VERNOTSUPPORTED); + when NOTINITIALISED => return Error_Messages (N_NOTINITIALISED); + when EDISCON => return Error_Messages (N_EDISCON); + when HOST_NOT_FOUND => return Error_Messages (N_HOST_NOT_FOUND); + when TRY_AGAIN => return Error_Messages (N_TRY_AGAIN); + when NO_RECOVERY => return Error_Messages (N_NO_RECOVERY); + when NO_DATA => return Error_Messages (N_NO_DATA); + when others => return Error_Messages (N_OTHERS); + end case; + end Socket_Error_Message; + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-mingw.ads b/gcc/ada/g-socthi-mingw.ads new file mode 100644 index 00000000000..5ee990e8628 --- /dev/null +++ b/gcc/ada/g-socthi-mingw.ads @@ -0,0 +1,433 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2004 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 package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This version is for NT + +with Interfaces.C.Pointers; +with Interfaces.C.Strings; + +with GNAT.Sockets.Constants; + +with System; + +package GNAT.Sockets.Thin is + + package C renames Interfaces.C; + + use type C.int; + -- So that we can declare the Failure constant below. + + Success : constant C.int := 0; + Failure : constant C.int := -1; + + function Socket_Errno return Integer; + -- Returns last socket error number. + + procedure Set_Socket_Errno (Errno : Integer); + -- Set last socket error number. + + function Socket_Error_Message + (Errno : Integer) + return C.Strings.chars_ptr; + -- Returns the error message string for the error number Errno. If + -- Errno is not known it returns "Unknown system error". + + subtype Fd_Set_Access is System.Address; + No_Fd_Set : constant Fd_Set_Access := System.Null_Address; + + type Timeval_Unit is new C.long; + pragma Convention (C, Timeval_Unit); + + type Timeval is record + Tv_Sec : Timeval_Unit; + Tv_Usec : Timeval_Unit; + end record; + pragma Convention (C, Timeval); + + type Timeval_Access is access all Timeval; + pragma Convention (C, Timeval_Access); + + Immediat : constant Timeval := (0, 0); + + type Int_Access is access all C.int; + pragma Convention (C, Int_Access); + -- Access to C integers + + type Chars_Ptr_Array is array (C.size_t range <>) of + aliased C.Strings.chars_ptr; + + package Chars_Ptr_Pointers is + new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, + C.Strings.Null_Ptr); + -- Arrays of C (char *) + + type In_Addr is record + S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; + end record; + pragma Convention (C, In_Addr); + -- Internet address + + type In_Addr_Access is access all In_Addr; + pragma Convention (C, In_Addr_Access); + -- Access to internet address + + Inaddr_Any : aliased constant In_Addr := (others => 0); + -- Any internet address (all the interfaces) + + type In_Addr_Access_Array is array (C.size_t range <>) + of aliased In_Addr_Access; + pragma Convention (C, In_Addr_Access_Array); + package In_Addr_Access_Pointers is + new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); + -- Array of internet addresses + + type Sockaddr is record + Sa_Family : C.unsigned_short; + Sa_Data : C.char_array (1 .. 14); + end record; + pragma Convention (C, Sockaddr); + -- Socket address + + type Sockaddr_Access is access all Sockaddr; + pragma Convention (C, Sockaddr_Access); + -- Access to socket address + + type Sockaddr_In is record + Sin_Family : C.unsigned_short := Constants.AF_INET; + Sin_Port : C.unsigned_short := 0; + Sin_Addr : In_Addr := Inaddr_Any; + Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0)); + end record; + pragma Convention (C, Sockaddr_In); + -- Internet socket address + + type Sockaddr_In_Access is access all Sockaddr_In; + pragma Convention (C, Sockaddr_In_Access); + -- Access to internet socket address + + procedure Set_Length + (Sin : Sockaddr_In_Access; + Len : C.int); + pragma Inline (Set_Length); + -- Set Sin.Sin_Length to Len. + -- On this platform, nothing is done as there is no such field. + + procedure Set_Family + (Sin : Sockaddr_In_Access; + Family : C.int); + pragma Inline (Set_Family); + -- Set Sin.Sin_Family to Family + + procedure Set_Port + (Sin : Sockaddr_In_Access; + Port : C.unsigned_short); + pragma Inline (Set_Port); + -- Set Sin.Sin_Port to Port + + procedure Set_Address + (Sin : Sockaddr_In_Access; + Address : In_Addr); + pragma Inline (Set_Address); + -- Set Sin.Sin_Addr to Address + + type Hostent is record + H_Name : C.Strings.chars_ptr; + H_Aliases : Chars_Ptr_Pointers.Pointer; + H_Addrtype : C.short; + H_Length : C.short; + H_Addr_List : In_Addr_Access_Pointers.Pointer; + end record; + pragma Convention (C, Hostent); + -- Host entry + + type Hostent_Access is access all Hostent; + pragma Convention (C, Hostent_Access); + -- Access to host entry + + type Servent is record + S_Name : C.Strings.chars_ptr; + S_Aliases : Chars_Ptr_Pointers.Pointer; + S_Port : C.int; + S_Proto : C.Strings.chars_ptr; + end record; + pragma Convention (C, Servent); + -- Service entry + + type Servent_Access is access all Servent; + pragma Convention (C, Servent_Access); + -- Access to service entry + + type Two_Int is array (0 .. 1) of C.int; + pragma Convention (C, Two_Int); + -- Used with pipe() + + function C_Accept + (S : C.int; + Addr : System.Address; + Addrlen : access C.int) return C.int; + + function C_Bind + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int; + + function C_Close + (Fd : C.int) return C.int; + + function C_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int; + + function C_Gethostbyaddr + (Addr : System.Address; + Length : C.int; + Typ : C.int) return Hostent_Access; + + function C_Gethostbyname + (Name : C.char_array) return Hostent_Access; + + function C_Gethostname + (Name : System.Address; + Namelen : C.int) return C.int; + + function C_Getpeername + (S : C.int; + Name : System.Address; + Namelen : access C.int) return C.int; + + function C_Getservbyname + (Name : C.char_array; + Proto : C.char_array) return Servent_Access; + + function C_Getservbyport + (Port : C.int; + Proto : C.char_array) return Servent_Access; + + function C_Getsockname + (S : C.int; + Name : System.Address; + Namelen : access C.int) return C.int; + + function C_Getsockopt + (S : C.int; + Level : C.int; + Optname : C.int; + Optval : System.Address; + Optlen : access C.int) return C.int; + + function C_Inet_Addr + (Cp : C.Strings.chars_ptr) return C.int; + + function C_Ioctl + (S : C.int; + Req : C.int; + Arg : Int_Access) return C.int; + + function C_Listen + (S : C.int; + Backlog : C.int) return C.int; + + function C_Read + (Fildes : C.int; + Buf : System.Address; + Nbyte : C.int) return C.int; + + function C_Readv + (Socket : C.int; + Iov : System.Address; + Iovcnt : C.int) return C.int; + + function C_Recv + (S : C.int; + Buf : System.Address; + Len : C.int; + Flags : C.int) return C.int; + + function C_Recvfrom + (S : C.int; + Buf : System.Address; + Len : C.int; + Flags : C.int; + From : Sockaddr_In_Access; + Fromlen : access C.int) return C.int; + + function C_Select + (Nfds : C.int; + Readfds : Fd_Set_Access; + Writefds : Fd_Set_Access; + Exceptfds : Fd_Set_Access; + Timeout : Timeval_Access) return C.int; + + function C_Send + (S : C.int; + Buf : System.Address; + Len : C.int; + Flags : C.int) return C.int; + + function C_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : Sockaddr_In_Access; + Tolen : C.int) return C.int; + + function C_Setsockopt + (S : C.int; + Level : C.int; + Optname : C.int; + Optval : System.Address; + Optlen : C.int) return C.int; + + function C_Shutdown + (S : C.int; + How : C.int) return C.int; + + function C_Socket + (Domain : C.int; + Typ : C.int; + Protocol : C.int) return C.int; + + function C_Strerror + (Errnum : C.int) return C.Strings.chars_ptr; + + function C_System + (Command : System.Address) return C.int; + + function C_Write + (Fildes : C.int; + Buf : System.Address; + Nbyte : C.int) return C.int; + + function C_Writev + (Socket : C.int; + Iov : System.Address; + Iovcnt : C.int) return C.int; + + function WSAStartup + (WS_Version : Interfaces.C.int; + WSADataAddress : System.Address) return Interfaces.C.int; + + procedure Free_Socket_Set + (Set : Fd_Set_Access); + -- Free system-dependent socket set. + + procedure Get_Socket_From_Set + (Set : Fd_Set_Access; + Socket : Int_Access; + Last : Int_Access); + -- Get last socket in Socket and remove it from the socket + -- set. The parameter Last is a maximum value of the largest + -- socket. This hint is used to avoid scanning very large socket + -- sets. After a call to Get_Socket_From_Set, Last is set back to + -- the real largest socket in the socket set. + + procedure Insert_Socket_In_Set + (Set : Fd_Set_Access; + Socket : C.int); + -- Insert socket in the socket set + + function Is_Socket_In_Set + (Set : Fd_Set_Access; + Socket : C.int) return Boolean; + -- Check whether Socket is in the socket set + + procedure Last_Socket_In_Set + (Set : Fd_Set_Access; + Last : Int_Access); + -- Find the largest socket in the socket set. This is needed for + -- select(). When Last_Socket_In_Set is called, parameter Last is + -- a maximum value of the largest socket. This hint is used to + -- avoid scanning very large socket sets. After the call, Last is + -- set back to the real largest socket in the socket set. + + function New_Socket_Set + (Set : Fd_Set_Access) return Fd_Set_Access; + -- Allocate a new socket set which is a system-dependent structure + -- and initialize by copying Set if it is non-null, by making it + -- empty otherwise. + + procedure Remove_Socket_From_Set + (Set : Fd_Set_Access; + Socket : C.int); + -- Remove socket from the socket set + + procedure WSACleanup; + + procedure Finalize; + procedure Initialize (Process_Blocking_IO : Boolean := False); + +private + pragma Import (Stdcall, C_Accept, "accept"); + pragma Import (Stdcall, C_Bind, "bind"); + pragma Import (Stdcall, C_Close, "closesocket"); + pragma Import (Stdcall, C_Gethostbyaddr, "gethostbyaddr"); + pragma Import (Stdcall, C_Gethostbyname, "gethostbyname"); + pragma Import (Stdcall, C_Gethostname, "gethostname"); + pragma Import (Stdcall, C_Getpeername, "getpeername"); + pragma Import (Stdcall, C_Getservbyname, "getservbyname"); + pragma Import (Stdcall, C_Getservbyport, "getservbyport"); + pragma Import (Stdcall, C_Getsockname, "getsockname"); + pragma Import (Stdcall, C_Getsockopt, "getsockopt"); + pragma Import (Stdcall, C_Inet_Addr, "inet_addr"); + pragma Import (Stdcall, C_Ioctl, "ioctlsocket"); + pragma Import (Stdcall, C_Listen, "listen"); + pragma Import (C, C_Read, "_read"); + pragma Import (Stdcall, C_Recv, "recv"); + pragma Import (Stdcall, C_Recvfrom, "recvfrom"); + pragma Import (Stdcall, C_Send, "send"); + pragma Import (Stdcall, C_Sendto, "sendto"); + pragma Import (Stdcall, C_Setsockopt, "setsockopt"); + pragma Import (Stdcall, C_Shutdown, "shutdown"); + pragma Import (Stdcall, C_Socket, "socket"); + pragma Import (C, C_Strerror, "strerror"); + pragma Import (C, C_System, "_system"); + pragma Import (C, C_Write, "_write"); + pragma Import (Stdcall, Socket_Errno, "WSAGetLastError"); + pragma Import (Stdcall, Set_Socket_Errno, "WSASetLastError"); + pragma Import (Stdcall, WSAStartup, "WSAStartup"); + pragma Import (Stdcall, WSACleanup, "WSACleanup"); + + pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); + pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); + pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); + pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); + pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); + pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); + pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); +end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb new file mode 100644 index 00000000000..41b32d16e9a --- /dev/null +++ b/gcc/ada/g-socthi-vms.adb @@ -0,0 +1,551 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2004 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Temporary version for Alpha/VMS. + +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Task_Lock; + +with Interfaces.C; use Interfaces.C; + +package body GNAT.Sockets.Thin is + + Non_Blocking_Sockets : constant Fd_Set_Access + := New_Socket_Set (No_Socket_Set); + -- When this package is initialized with Process_Blocking_IO set + -- to True, sockets are set in non-blocking mode to avoid blocking + -- the whole process when a thread wants to perform a blocking IO + -- operation. But the user can also set a socket in non-blocking + -- mode by purpose. In order to make a difference between these + -- two situations, we track the origin of non-blocking mode in + -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has + -- been set in non-blocking mode by the user. + + Quantum : constant Duration := 0.2; + -- When Thread_Blocking_IO is False, we set sockets in + -- non-blocking mode and we spend a period of time Quantum between + -- two attempts on a blocking operation. + + Thread_Blocking_IO : Boolean := True; + + Unknown_System_Error : constant C.Strings.chars_ptr := + C.Strings.New_String ("Unknown system error"); + + function Syscall_Accept + (S : C.int; + Addr : System.Address; + Addrlen : access C.int) return C.int; + pragma Import (C, Syscall_Accept, "accept"); + + function Syscall_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int; + pragma Import (C, Syscall_Connect, "connect"); + + function Syscall_Ioctl + (S : C.int; + Req : C.int; + Arg : Int_Access) return C.int; + pragma Import (C, Syscall_Ioctl, "ioctl"); + + function Syscall_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int; + pragma Import (C, Syscall_Recv, "recv"); + + function Syscall_Recvfrom + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + From : Sockaddr_In_Access; + Fromlen : access C.int) return C.int; + pragma Import (C, Syscall_Recvfrom, "recvfrom"); + + function Syscall_Send + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) + return C.int; + pragma Import (C, Syscall_Send, "send"); + + function Syscall_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : Sockaddr_In_Access; + Tolen : C.int) + return C.int; + pragma Import (C, Syscall_Sendto, "sendto"); + + function Syscall_Socket + (Domain, Typ, Protocol : C.int) return C.int; + pragma Import (C, Syscall_Socket, "socket"); + + function Non_Blocking_Socket (S : C.int) return Boolean; + procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean); + + -------------- + -- C_Accept -- + -------------- + + function C_Accept + (S : C.int; + Addr : System.Address; + Addrlen : access C.int) return C.int + is + R : C.int; + Val : aliased C.int := 1; + + Discard : C.int; + pragma Warnings (Off, Discard); + + begin + loop + R := Syscall_Accept (S, Addr, Addrlen); + exit when Thread_Blocking_IO + or else R /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + if not Thread_Blocking_IO + and then R /= Failure + then + -- A socket inherits the properties ot its server especially + -- the FIONBIO flag. Do not use C_Ioctl as this subprogram + -- tracks sockets set in non-blocking mode by user. + + Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); + Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); + end if; + + return R; + end C_Accept; + + --------------- + -- C_Connect -- + --------------- + + function C_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int + is + Res : C.int; + + begin + Res := Syscall_Connect (S, Name, Namelen); + + if Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EINPROGRESS + then + return Res; + end if; + + declare + WSet : Fd_Set_Access; + Now : aliased Timeval; + + begin + WSet := New_Socket_Set (No_Socket_Set); + loop + Insert_Socket_In_Set (WSet, S); + Now := Immediat; + Res := C_Select + (S + 1, + No_Fd_Set, + WSet, + No_Fd_Set, + Now'Unchecked_Access); + + exit when Res > 0; + + if Res = Failure then + Free_Socket_Set (WSet); + return Res; + end if; + + delay Quantum; + end loop; + + Free_Socket_Set (WSet); + end; + + Res := Syscall_Connect (S, Name, Namelen); + + if Res = Failure + and then Errno = Constants.EISCONN + then + return Thin.Success; + else + return Res; + end if; + end C_Connect; + + ------------- + -- C_Ioctl -- + ------------- + + function C_Ioctl + (S : C.int; + Req : C.int; + Arg : Int_Access) return C.int + is + begin + if not Thread_Blocking_IO + and then Req = Constants.FIONBIO + then + if Arg.all /= 0 then + Set_Non_Blocking_Socket (S, True); + end if; + end if; + + return Syscall_Ioctl (S, Req, Arg); + end C_Ioctl; + + ------------ + -- C_Recv -- + ------------ + + function C_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Recv (S, Msg, Len, Flags); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Recv; + + ---------------- + -- C_Recvfrom -- + ---------------- + + function C_Recvfrom + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + From : Sockaddr_In_Access; + Fromlen : access C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Recvfrom; + + ------------ + -- C_Send -- + ------------ + + function C_Send + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Send (S, Msg, Len, Flags); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Send; + + -------------- + -- C_Sendto -- + -------------- + + function C_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : Sockaddr_In_Access; + Tolen : C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Sendto; + + -------------- + -- C_Socket -- + -------------- + + function C_Socket + (Domain : C.int; + Typ : C.int; + Protocol : C.int) return C.int + is + R : C.int; + Val : aliased C.int := 1; + + Discard : C.int; + pragma Unreferenced (Discard); + + begin + R := Syscall_Socket (Domain, Typ, Protocol); + + if not Thread_Blocking_IO + and then R /= Failure + then + -- Do not use C_Ioctl as this subprogram tracks sockets set + -- in non-blocking mode by user. + + Discard := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); + Set_Non_Blocking_Socket (R, False); + end if; + + return R; + end C_Socket; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + null; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Process_Blocking_IO : Boolean) is + begin + Thread_Blocking_IO := not Process_Blocking_IO; + end Initialize; + + ------------------------- + -- Non_Blocking_Socket -- + ------------------------- + + function Non_Blocking_Socket (S : C.int) return Boolean is + R : Boolean; + begin + Task_Lock.Lock; + R := Is_Socket_In_Set (Non_Blocking_Sockets, S); + Task_Lock.Unlock; + return R; + end Non_Blocking_Socket; + + ----------------- + -- Set_Address -- + ----------------- + + procedure Set_Address (Sin : Sockaddr_In_Access; Address : In_Addr) is + begin + Sin.Sin_Addr := Address; + end Set_Address; + + ---------------- + -- Set_Family -- + ---------------- + + procedure Set_Family (Sin : Sockaddr_In_Access; Family : C.int) is + begin + Sin.Sin_Family := C.unsigned_short (Family); + end Set_Family; + + ---------------- + -- Set_Length -- + ---------------- + + procedure Set_Length (Sin : Sockaddr_In_Access; Len : C.int) is + pragma Unreferenced (Sin); + pragma Unreferenced (Len); + begin + null; + end Set_Length; + + ----------------------------- + -- Set_Non_Blocking_Socket -- + ----------------------------- + + procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is + begin + Task_Lock.Lock; + + if V then + Insert_Socket_In_Set (Non_Blocking_Sockets, S); + else + Remove_Socket_From_Set (Non_Blocking_Sockets, S); + end if; + + Task_Lock.Unlock; + end Set_Non_Blocking_Socket; + + -------------- + -- Set_Port -- + -------------- + + procedure Set_Port (Sin : Sockaddr_In_Access; Port : C.unsigned_short) is + begin + Sin.Sin_Port := Port; + end Set_Port; + + -------------------------- + -- Socket_Error_Message -- + -------------------------- + + function Socket_Error_Message + (Errno : Integer) return C.Strings.chars_ptr + is + use type Interfaces.C.Strings.chars_ptr; + + C_Msg : C.Strings.chars_ptr; + + begin + C_Msg := C_Strerror (C.int (Errno)); + + if C_Msg = C.Strings.Null_Ptr then + return Unknown_System_Error; + else + return C_Msg; + end if; + end Socket_Error_Message; + + ------------- + -- C_Readv -- + ------------- + + function C_Readv + (Fd : C.int; + Iov : System.Address; + Iovcnt : C.int) return C.int + is + Res : C.int; + Count : C.int := 0; + + Iovec : array (0 .. Iovcnt - 1) of Vector_Element; + for Iovec'Address use Iov; + pragma Import (Ada, Iovec); + + begin + for J in Iovec'Range loop + Res := C_Read + (Fd, + Iovec (J).Base.all'Address, + Interfaces.C.int (Iovec (J).Length)); + + if Res < 0 then + return Res; + else + Count := Count + Res; + end if; + end loop; + return Count; + end C_Readv; + + -------------- + -- C_Writev -- + -------------- + + function C_Writev + (Fd : C.int; + Iov : System.Address; + Iovcnt : C.int) return C.int + is + Res : C.int; + Count : C.int := 0; + + Iovec : array (0 .. Iovcnt - 1) of Vector_Element; + for Iovec'Address use Iov; + pragma Import (Ada, Iovec); + + begin + for J in Iovec'Range loop + Res := C_Write + (Fd, + Iovec (J).Base.all'Address, + Interfaces.C.int (Iovec (J).Length)); + + if Res < 0 then + return Res; + else + Count := Count + Res; + end if; + end loop; + return Count; + end C_Writev; + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-vms.ads b/gcc/ada/g-socthi-vms.ads new file mode 100644 index 00000000000..a3985525f7c --- /dev/null +++ b/gcc/ada/g-socthi-vms.ads @@ -0,0 +1,445 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2004 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 package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This is the Alpha/VMS version. + +with Interfaces.C.Pointers; + +with Interfaces.C.Strings; +with GNAT.Sockets.Constants; +with GNAT.OS_Lib; + +with System; + +package GNAT.Sockets.Thin is + + -- ??? more comments needed ??? + + package C renames Interfaces.C; + + use type C.int; + -- This is so we can declare the Failure constant below + + Success : constant C.int := 0; + Failure : constant C.int := -1; + + function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; + -- Returns last socket error number. + + function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr; + -- Returns the error message string for the error number Errno. If + -- Errno is not known it returns "Unknown system error". + + subtype Fd_Set_Access is System.Address; + No_Fd_Set : constant Fd_Set_Access := System.Null_Address; + + type Timeval_Unit is new C.int; + pragma Convention (C, Timeval_Unit); + + type Timeval is record + Tv_Sec : Timeval_Unit; + Tv_Usec : Timeval_Unit; + end record; + pragma Convention (C, Timeval); + + type Timeval_Access is access all Timeval; + pragma Convention (C, Timeval_Access); + + Immediat : constant Timeval := (0, 0); + + type Int_Access is access all C.int; + pragma Convention (C, Int_Access); + -- Access to C integers + + type Chars_Ptr_Array is array (C.size_t range <>) of + aliased C.Strings.chars_ptr; + + package Chars_Ptr_Pointers is + new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, + C.Strings.Null_Ptr); + -- Arrays of C (char *) + + type In_Addr is record + S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; + end record; + pragma Convention (C, In_Addr); + -- Internet address + + type In_Addr_Access is access all In_Addr; + pragma Convention (C, In_Addr_Access); + -- Access to internet address + + Inaddr_Any : aliased constant In_Addr := (others => 0); + -- Any internet address (all the interfaces) + + type In_Addr_Access_Array is array (C.size_t range <>) + of aliased In_Addr_Access; + pragma Convention (C, In_Addr_Access_Array); + + package In_Addr_Access_Pointers is + new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); + -- Array of internet addresses + + type Sockaddr is record + Sa_Family : C.unsigned_short; + Sa_Data : C.char_array (1 .. 14); + end record; + pragma Convention (C, Sockaddr); + -- Socket address + + type Sockaddr_Access is access all Sockaddr; + pragma Convention (C, Sockaddr_Access); + -- Access to socket address + + type Sockaddr_In is record + Sin_Family : C.unsigned_short := Constants.AF_INET; + Sin_Port : C.unsigned_short := 0; + Sin_Addr : In_Addr := Inaddr_Any; + Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0)); + end record; + pragma Convention (C, Sockaddr_In); + -- Internet socket address + + type Sockaddr_In_Access is access all Sockaddr_In; + pragma Convention (C, Sockaddr_In_Access); + -- Access to internet socket address + + procedure Set_Length + (Sin : Sockaddr_In_Access; + Len : C.int); + pragma Inline (Set_Length); + -- Set Sin.Sin_Length to Len. + -- On this platform, nothing is done as there is no such field. + + procedure Set_Family + (Sin : Sockaddr_In_Access; + Family : C.int); + pragma Inline (Set_Family); + -- Set Sin.Sin_Family to Family + + procedure Set_Port + (Sin : Sockaddr_In_Access; + Port : C.unsigned_short); + pragma Inline (Set_Port); + -- Set Sin.Sin_Port to Port + + procedure Set_Address + (Sin : Sockaddr_In_Access; + Address : In_Addr); + pragma Inline (Set_Address); + -- Set Sin.Sin_Addr to Address + + type Hostent is record + H_Name : C.Strings.chars_ptr; + H_Aliases : Chars_Ptr_Pointers.Pointer; + H_Addrtype : C.int; + H_Length : C.int; + H_Addr_List : In_Addr_Access_Pointers.Pointer; + end record; + pragma Convention (C, Hostent); + -- Host entry + + type Hostent_Access is access all Hostent; + pragma Convention (C, Hostent_Access); + -- Access to host entry + + type Servent is record + S_Name : C.Strings.chars_ptr; + S_Aliases : Chars_Ptr_Pointers.Pointer; + S_Port : C.int; + S_Proto : C.Strings.chars_ptr; + end record; + pragma Convention (C, Servent); + -- Service entry + + type Servent_Access is access all Servent; + pragma Convention (C, Servent_Access); + -- Access to service entry + + type Two_Int is array (0 .. 1) of C.int; + pragma Convention (C, Two_Int); + -- Used with pipe() + + function C_Accept + (S : C.int; + Addr : System.Address; + Addrlen : access C.int) + return C.int; + + function C_Bind + (S : C.int; + Name : System.Address; + Namelen : C.int) + return C.int; + + function C_Close + (Fd : C.int) + return C.int; + + function C_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) + return C.int; + + function C_Gethostbyaddr + (Addr : System.Address; + Len : C.int; + Typ : C.int) + return Hostent_Access; + + function C_Gethostbyname + (Name : C.char_array) + return Hostent_Access; + + function C_Gethostname + (Name : System.Address; + Namelen : C.int) + return C.int; + + function C_Getpeername + (S : C.int; + Name : System.Address; + Namelen : access C.int) + return C.int; + + function C_Getservbyname + (Name : C.char_array; + Proto : C.char_array) + return Servent_Access; + + function C_Getservbyport + (Port : C.int; + Proto : C.char_array) + return Servent_Access; + + function C_Getsockname + (S : C.int; + Name : System.Address; + Namelen : access C.int) + return C.int; + + function C_Getsockopt + (S : C.int; + Level : C.int; + Optname : C.int; + Optval : System.Address; + Optlen : access C.int) + return C.int; + + function C_Inet_Addr + (Cp : C.Strings.chars_ptr) + return C.int; + + function C_Ioctl + (S : C.int; + Req : C.int; + Arg : Int_Access) + return C.int; + + function C_Listen (S, Backlog : C.int) return C.int; + + function C_Read + (Fd : C.int; + Buf : System.Address; + Count : C.int) + return C.int; + + function C_Readv + (Fd : C.int; + Iov : System.Address; + Iovcnt : C.int) + return C.int; + + function C_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) + return C.int; + + function C_Recvfrom + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + From : Sockaddr_In_Access; + Fromlen : access C.int) + return C.int; + + function C_Select + (Nfds : C.int; + Readfds : Fd_Set_Access; + Writefds : Fd_Set_Access; + Exceptfds : Fd_Set_Access; + Timeout : Timeval_Access) + return C.int; + + function C_Send + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) + return C.int; + + function C_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : Sockaddr_In_Access; + Tolen : C.int) + return C.int; + + function C_Setsockopt + (S : C.int; + Level : C.int; + Optname : C.int; + Optval : System.Address; + Optlen : C.int) + return C.int; + + function C_Shutdown + (S : C.int; + How : C.int) + return C.int; + + function C_Socket + (Domain : C.int; + Typ : C.int; + Protocol : C.int) + return C.int; + + function C_Strerror + (Errnum : C.int) + return C.Strings.chars_ptr; + + function C_System + (Command : System.Address) + return C.int; + + function C_Write + (Fd : C.int; + Buf : System.Address; + Count : C.int) + return C.int; + + function C_Writev + (Fd : C.int; + Iov : System.Address; + Iovcnt : C.int) + return C.int; + + procedure Free_Socket_Set + (Set : Fd_Set_Access); + -- Free system-dependent socket set. + + procedure Get_Socket_From_Set + (Set : Fd_Set_Access; + Socket : Int_Access; + Last : Int_Access); + -- Get last socket in Socket and remove it from the socket + -- set. The parameter Last is a maximum value of the largest + -- socket. This hint is used to avoid scanning very large socket + -- sets. After a call to Get_Socket_From_Set, Last is set back to + -- the real largest socket in the socket set. + + procedure Insert_Socket_In_Set + (Set : Fd_Set_Access; + Socket : C.int); + -- Insert socket in the socket set. + + function Is_Socket_In_Set + (Set : Fd_Set_Access; + Socket : C.int) + return Boolean; + -- Check whether Socket is in the socket set. + + procedure Last_Socket_In_Set + (Set : Fd_Set_Access; + Last : Int_Access); + -- Find the largest socket in the socket set. This is needed for + -- select(). When Last_Socket_In_Set is called, parameter Last is + -- a maximum value of the largest socket. This hint is used to + -- avoid scanning very large socket sets. After the call, Last is + -- set back to the real largest socket in the socket set. + + function New_Socket_Set + (Set : Fd_Set_Access) + return Fd_Set_Access; + -- Allocate a new socket set which is a system-dependent structure + -- and initialize by copying Set if it is non-null, by making it + -- empty otherwise. + + procedure Remove_Socket_From_Set + (Set : Fd_Set_Access; + Socket : C.int); + -- Remove socket from the socket set. + + procedure Finalize; + procedure Initialize (Process_Blocking_IO : Boolean); + +private + + pragma Import (C, C_Bind, "DECC$BIND"); + pragma Import (C, C_Close, "DECC$CLOSE"); + pragma Import (C, C_Gethostbyaddr, "DECC$GETHOSTBYADDR"); + pragma Import (C, C_Gethostbyname, "DECC$GETHOSTBYNAME"); + pragma Import (C, C_Gethostname, "DECC$GETHOSTNAME"); + pragma Import (C, C_Getpeername, "DECC$GETPEERNAME"); + pragma Import (C, C_Getservbyname, "DECC$GETSERVBYNAME"); + pragma Import (C, C_Getservbyport, "DECC$GETSERVBYPORT"); + pragma Import (C, C_Getsockname, "DECC$GETSOCKNAME"); + pragma Import (C, C_Getsockopt, "DECC$GETSOCKOPT"); + pragma Import (C, C_Inet_Addr, "DECC$INET_ADDR"); + pragma Import (C, C_Listen, "DECC$LISTEN"); + pragma Import (C, C_Read, "DECC$READ"); + pragma Import (C, C_Select, "DECC$SELECT"); + pragma Import (C, C_Setsockopt, "DECC$SETSOCKOPT"); + pragma Import (C, C_Shutdown, "DECC$SHUTDOWN"); + pragma Import (C, C_Strerror, "DECC$STRERROR"); + pragma Import (C, C_System, "DECC$SYSTEM"); + pragma Import (C, C_Write, "DECC$WRITE"); + + pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); + pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); + pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); + pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); + pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); + pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); + pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); +end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-vxworks.adb b/gcc/ada/g-socthi-vxworks.adb new file mode 100644 index 00000000000..28e22418847 --- /dev/null +++ b/gcc/ada/g-socthi-vxworks.adb @@ -0,0 +1,624 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2004 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 package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This version is for VxWorks + +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Task_Lock; + +with Interfaces.C; use Interfaces.C; +with Unchecked_Conversion; + +package body GNAT.Sockets.Thin is + + Non_Blocking_Sockets : constant Fd_Set_Access := + New_Socket_Set (No_Socket_Set); + -- When this package is initialized with Process_Blocking_IO set + -- to True, sockets are set in non-blocking mode to avoid blocking + -- the whole process when a thread wants to perform a blocking IO + -- operation. But the user can also set a socket in non-blocking + -- mode by purpose. In order to make a difference between these + -- two situations, we track the origin of non-blocking mode in + -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has + -- been set in non-blocking mode by the user. + + Quantum : constant Duration := 0.2; + -- When Thread_Blocking_IO is False, we set sockets in + -- non-blocking mode and we spend a period of time Quantum between + -- two attempts on a blocking operation. + + Thread_Blocking_IO : Boolean := True; + + Unknown_System_Error : constant C.Strings.chars_ptr := + C.Strings.New_String ("Unknown system error"); + + -- The following types and variables are required to create a Hostent + -- record "by hand". + + type In_Addr_Access_Array_Access is access In_Addr_Access_Array; + + Alias_Access : constant Chars_Ptr_Pointers.Pointer := + new C.Strings.chars_ptr'(C.Strings.Null_Ptr); + + In_Addr_Access_Array_A : constant In_Addr_Access_Array_Access := + new In_Addr_Access_Array'(new In_Addr, null); + + In_Addr_Access_Ptr : constant In_Addr_Access_Pointers.Pointer := + In_Addr_Access_Array_A + (In_Addr_Access_Array_A'First)'Access; + + Local_Hostent : constant Hostent_Access := new Hostent; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- All these require comments ??? + + function Syscall_Accept + (S : C.int; + Addr : System.Address; + Addrlen : access C.int) return C.int; + pragma Import (C, Syscall_Accept, "accept"); + + function Syscall_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int; + pragma Import (C, Syscall_Connect, "connect"); + + function Syscall_Ioctl + (S : C.int; + Req : C.int; + Arg : Int_Access) return C.int; + pragma Import (C, Syscall_Ioctl, "ioctl"); + + function Syscall_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int; + pragma Import (C, Syscall_Recv, "recv"); + + function Syscall_Recvfrom + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + From : Sockaddr_In_Access; + Fromlen : access C.int) return C.int; + pragma Import (C, Syscall_Recvfrom, "recvfrom"); + + function Syscall_Send + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int; + pragma Import (C, Syscall_Send, "send"); + + function Syscall_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : Sockaddr_In_Access; + Tolen : C.int) return C.int; + pragma Import (C, Syscall_Sendto, "sendto"); + + function Syscall_Socket + (Domain : C.int; + Typ : C.int; + Protocol : C.int) return C.int; + pragma Import (C, Syscall_Socket, "socket"); + + function Non_Blocking_Socket (S : C.int) return Boolean; + procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean); + + -------------- + -- C_Accept -- + -------------- + + function C_Accept + (S : C.int; + Addr : System.Address; + Addrlen : access C.int) return C.int + is + R : C.int; + Val : aliased C.int := 1; + + Res : C.int; + pragma Unreferenced (Res); + + begin + loop + R := Syscall_Accept (S, Addr, Addrlen); + exit when Thread_Blocking_IO + or else R /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + if not Thread_Blocking_IO + and then R /= Failure + then + -- A socket inherits the properties ot its server especially + -- the FIONBIO flag. Do not use C_Ioctl as this subprogram + -- tracks sockets set in non-blocking mode by user. + + Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); + Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); + -- Is it OK to ignore result ??? + end if; + + return R; + end C_Accept; + + --------------- + -- C_Connect -- + --------------- + + function C_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int + is + Res : C.int; + + begin + Res := Syscall_Connect (S, Name, Namelen); + + if Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EINPROGRESS + then + return Res; + end if; + + declare + WSet : Fd_Set_Access; + Now : aliased Timeval; + + begin + WSet := New_Socket_Set (No_Socket_Set); + + loop + Insert_Socket_In_Set (WSet, S); + Now := Immediat; + Res := C_Select + (S + 1, + No_Fd_Set, + WSet, + No_Fd_Set, + Now'Unchecked_Access); + + exit when Res > 0; + + if Res = Failure then + Free_Socket_Set (WSet); + return Res; + end if; + + delay Quantum; + end loop; + + Free_Socket_Set (WSet); + end; + + Res := Syscall_Connect (S, Name, Namelen); + + if Res = Failure + and then Errno = Constants.EISCONN + then + return Thin.Success; + else + return Res; + end if; + end C_Connect; + + --------------------- + -- C_Gethostbyaddr -- + --------------------- + + function C_Gethostbyaddr + (Addr : System.Address; + Len : C.int; + Typ : C.int) return Hostent_Access + is + pragma Warnings (Off, Len); + pragma Warnings (Off, Typ); + + type int_Access is access int; + function To_Pointer is + new Unchecked_Conversion (System.Address, int_Access); + + procedure VxWorks_Gethostbyaddr + (Addr : C.int; Buf : out C.char_array); + pragma Import (C, VxWorks_Gethostbyaddr, "hostGetByAddr"); + + Host_Name : C.char_array (1 .. Max_Name_Length); + + begin + VxWorks_Gethostbyaddr (To_Pointer (Addr).all, Host_Name); + + In_Addr_Access_Ptr.all.all := To_In_Addr (To_Pointer (Addr).all); + Local_Hostent.all.H_Name := C.Strings.New_Char_Array (Host_Name); + + return Local_Hostent; + end C_Gethostbyaddr; + + --------------------- + -- C_Gethostbyname -- + --------------------- + + function C_Gethostbyname + (Name : C.char_array) return Hostent_Access + is + function VxWorks_Gethostbyname + (Name : C.char_array) return C.int; + pragma Import (C, VxWorks_Gethostbyname, "hostGetByName"); + + Addr : C.int; + + begin + Addr := VxWorks_Gethostbyname (Name); + + In_Addr_Access_Ptr.all.all := To_In_Addr (Addr); + Local_Hostent.all.H_Name := C.Strings.New_Char_Array (To_C (Host_Name)); + + return Local_Hostent; + end C_Gethostbyname; + + --------------------- + -- C_Getservbyname -- + --------------------- + + function C_Getservbyname + (Name : C.char_array; + Proto : C.char_array) return Servent_Access + is + pragma Warnings (Off, Name); + pragma Warnings (Off, Proto); + + begin + return null; + end C_Getservbyname; + + --------------------- + -- C_Getservbyport -- + --------------------- + + function C_Getservbyport + (Port : C.int; + Proto : C.char_array) return Servent_Access + is + pragma Warnings (Off, Port); + pragma Warnings (Off, Proto); + + begin + return null; + end C_Getservbyport; + + ------------- + -- C_Ioctl -- + ------------- + + function C_Ioctl + (S : C.int; + Req : C.int; + Arg : Int_Access) return C.int + is + begin + if not Thread_Blocking_IO + and then Req = Constants.FIONBIO + then + if Arg.all /= 0 then + Set_Non_Blocking_Socket (S, True); + end if; + end if; + + return Syscall_Ioctl (S, Req, Arg); + end C_Ioctl; + + ------------ + -- C_Recv -- + ------------ + + function C_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Recv (S, Msg, Len, Flags); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Recv; + + ---------------- + -- C_Recvfrom -- + ---------------- + + function C_Recvfrom + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + From : Sockaddr_In_Access; + Fromlen : access C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Recvfrom; + + ------------ + -- C_Send -- + ------------ + + function C_Send + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Send (S, Msg, Len, Flags); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Send; + + -------------- + -- C_Sendto -- + -------------- + + function C_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : Sockaddr_In_Access; + Tolen : C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); + exit when Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= Constants.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Sendto; + + -------------- + -- C_Socket -- + -------------- + + function C_Socket + (Domain : C.int; + Typ : C.int; + Protocol : C.int) return C.int + is + R : C.int; + Val : aliased C.int := 1; + + Res : C.int; + pragma Unreferenced (Res); + + begin + R := Syscall_Socket (Domain, Typ, Protocol); + + if not Thread_Blocking_IO + and then R /= Failure + then + -- Do not use C_Ioctl as this subprogram tracks sockets set + -- in non-blocking mode by user. + + Res := Syscall_Ioctl (R, Constants.FIONBIO, Val'Unchecked_Access); + -- Is it OK to ignore result ??? + Set_Non_Blocking_Socket (R, False); + end if; + + return R; + end C_Socket; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + null; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Process_Blocking_IO : Boolean) is + begin + Thread_Blocking_IO := not Process_Blocking_IO; + end Initialize; + + ------------------------- + -- Non_Blocking_Socket -- + ------------------------- + + function Non_Blocking_Socket (S : C.int) return Boolean is + R : Boolean; + + begin + Task_Lock.Lock; + R := Is_Socket_In_Set (Non_Blocking_Sockets, S); + Task_Lock.Unlock; + return R; + end Non_Blocking_Socket; + + ----------------- + -- Set_Address -- + ----------------- + + procedure Set_Address + (Sin : Sockaddr_In_Access; + Address : In_Addr) + is + begin + Sin.Sin_Addr := Address; + end Set_Address; + + ---------------- + -- Set_Family -- + ---------------- + + procedure Set_Family + (Sin : Sockaddr_In_Access; + Family : C.int) + is + begin + Sin.Sin_Family := C.unsigned_char (Family); + end Set_Family; + + ---------------- + -- Set_Length -- + ---------------- + + procedure Set_Length + (Sin : Sockaddr_In_Access; + Len : C.int) + is + begin + Sin.Sin_Length := C.unsigned_char (Len); + end Set_Length; + + ----------------------------- + -- Set_Non_Blocking_Socket -- + ----------------------------- + + procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is + begin + Task_Lock.Lock; + if V then + Insert_Socket_In_Set (Non_Blocking_Sockets, S); + else + Remove_Socket_From_Set (Non_Blocking_Sockets, S); + end if; + + Task_Lock.Unlock; + end Set_Non_Blocking_Socket; + + -------------- + -- Set_Port -- + -------------- + + procedure Set_Port + (Sin : Sockaddr_In_Access; + Port : C.unsigned_short) + is + begin + Sin.Sin_Port := Port; + end Set_Port; + + -------------------------- + -- Socket_Error_Message -- + -------------------------- + + function Socket_Error_Message + (Errno : Integer) return C.Strings.chars_ptr + is + use type Interfaces.C.Strings.chars_ptr; + + C_Msg : C.Strings.chars_ptr; + + begin + C_Msg := C_Strerror (C.int (Errno)); + + if C_Msg = C.Strings.Null_Ptr then + return Unknown_System_Error; + + else + return C_Msg; + end if; + end Socket_Error_Message; + +-- Package elaboration + +begin + Local_Hostent.all.H_Aliases := Alias_Access; + + -- VxWorks currently only supports AF_INET + + Local_Hostent.all.H_Addrtype := Constants.AF_INET; + + Local_Hostent.all.H_Length := 1; + Local_Hostent.all.H_Addr_List := In_Addr_Access_Ptr; + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-vxworks.ads b/gcc/ada/g-socthi-vxworks.ads new file mode 100644 index 00000000000..3642a038bec --- /dev/null +++ b/gcc/ada/g-socthi-vxworks.ads @@ -0,0 +1,446 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2004 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 package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This is the version for VxWorks + +with Interfaces.C.Pointers; + +with Ada.Unchecked_Conversion; +with Interfaces.C.Strings; +with GNAT.Sockets.Constants; +with GNAT.OS_Lib; + +with System; + +package GNAT.Sockets.Thin is + + package C renames Interfaces.C; + + use type C.int; + -- This is so we can declare the Failure constant below + + Success : constant C.int := 0; + Failure : constant C.int := -1; + + function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; + -- Returns last socket error number. + + function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr; + -- Returns the error message string for the error number Errno. If + -- Errno is not known it returns "Unknown system error". + + subtype Fd_Set_Access is System.Address; + No_Fd_Set : constant Fd_Set_Access := System.Null_Address; + + type Timeval_Unit is new C.int; + pragma Convention (C, Timeval_Unit); + + type Timeval is record + Tv_Sec : Timeval_Unit; + Tv_Usec : Timeval_Unit; + end record; + pragma Convention (C, Timeval); + + type Timeval_Access is access all Timeval; + pragma Convention (C, Timeval_Access); + + Immediat : constant Timeval := (0, 0); + + type Int_Access is access all C.int; + pragma Convention (C, Int_Access); + -- Access to C integers + + type Chars_Ptr_Array is array (C.size_t range <>) of + aliased C.Strings.chars_ptr; + + package Chars_Ptr_Pointers is + new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, + C.Strings.Null_Ptr); + -- Arrays of C (char *) + + type In_Addr is record + S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; + end record; + pragma Convention (C, In_Addr); + -- Internet address + + function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr); + + type In_Addr_Access is access all In_Addr; + pragma Convention (C, In_Addr_Access); + -- Access to internet address + + Inaddr_Any : aliased constant In_Addr := (others => 0); + -- Any internet address (all the interfaces) + + type In_Addr_Access_Array is array (C.size_t range <>) + of aliased In_Addr_Access; + pragma Convention (C, In_Addr_Access_Array); + + package In_Addr_Access_Pointers is + new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); + -- Array of internet addresses + + type Sockaddr is record + Sa_Length : C.unsigned_char; + Sa_Family : C.unsigned_char; + Sa_Data : C.char_array (1 .. 14); + end record; + pragma Convention (C, Sockaddr); + -- Socket address + + type Sockaddr_Access is access all Sockaddr; + pragma Convention (C, Sockaddr_Access); + -- Access to socket address + + type Sockaddr_In is record + Sin_Length : C.unsigned_char := 0; + Sin_Family : C.unsigned_char := Constants.AF_INET; + Sin_Port : C.unsigned_short := 0; + Sin_Addr : In_Addr := Inaddr_Any; + Sin_Zero : C.char_array (1 .. 8) := (others => C.char'Val (0)); + end record; + pragma Convention (C, Sockaddr_In); + -- Internet socket address + + type Sockaddr_In_Access is access all Sockaddr_In; + pragma Convention (C, Sockaddr_In_Access); + -- Access to internet socket address + + procedure Set_Length + (Sin : Sockaddr_In_Access; + Len : C.int); + pragma Inline (Set_Length); + -- Set Sin.Sin_Length to Len. + + procedure Set_Family + (Sin : Sockaddr_In_Access; + Family : C.int); + pragma Inline (Set_Family); + -- Set Sin.Sin_Family to Family. + + procedure Set_Port + (Sin : Sockaddr_In_Access; + Port : C.unsigned_short); + pragma Inline (Set_Port); + -- Set Sin.Sin_Port to Port. + + procedure Set_Address + (Sin : Sockaddr_In_Access; + Address : In_Addr); + pragma Inline (Set_Address); + -- Set Sin.Sin_Addr to Address. + + type Hostent is record + H_Name : C.Strings.chars_ptr; + H_Aliases : Chars_Ptr_Pointers.Pointer; + H_Addrtype : C.int; + H_Length : C.int; + H_Addr_List : In_Addr_Access_Pointers.Pointer; + end record; + pragma Convention (C, Hostent); + -- Host entry + + type Hostent_Access is access all Hostent; + pragma Convention (C, Hostent_Access); + -- Access to host entry + + type Servent is record + S_Name : C.Strings.chars_ptr; + S_Aliases : Chars_Ptr_Pointers.Pointer; + S_Port : C.int; + S_Proto : C.Strings.chars_ptr; + end record; + pragma Convention (C, Servent); + -- Service entry + + type Servent_Access is access all Servent; + pragma Convention (C, Servent_Access); + -- Access to service entry + + type Two_Int is array (0 .. 1) of C.int; + pragma Convention (C, Two_Int); + -- Used with pipe() + + function C_Accept + (S : C.int; + Addr : System.Address; + Addrlen : access C.int) + return C.int; + + function C_Bind + (S : C.int; + Name : System.Address; + Namelen : C.int) + return C.int; + + function C_Close + (Fd : C.int) + return C.int; + + function C_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) + return C.int; + + function C_Gethostbyaddr + (Addr : System.Address; + Len : C.int; + Typ : C.int) + return Hostent_Access; + + function C_Gethostbyname + (Name : C.char_array) + return Hostent_Access; + + function C_Gethostname + (Name : System.Address; + Namelen : C.int) + return C.int; + + function C_Getpeername + (S : C.int; + Name : System.Address; + Namelen : access C.int) + return C.int; + + function C_Getservbyname + (Name : C.char_array; + Proto : C.char_array) + return Servent_Access; + + function C_Getservbyport + (Port : C.int; + Proto : C.char_array) + return Servent_Access; + + function C_Getsockname + (S : C.int; + Name : System.Address; + Namelen : access C.int) + return C.int; + + function C_Getsockopt + (S : C.int; + Level : C.int; + Optname : C.int; + Optval : System.Address; + Optlen : access C.int) + return C.int; + + function C_Inet_Addr + (Cp : C.Strings.chars_ptr) + return C.int; + + function C_Ioctl + (S : C.int; + Req : C.int; + Arg : Int_Access) + return C.int; + + function C_Listen (S, Backlog : C.int) return C.int; + + function C_Read + (Fd : C.int; + Buf : System.Address; + Count : C.int) + return C.int; + + function C_Readv + (Fd : C.int; + Iov : System.Address; + Iovcnt : C.int) + return C.int; + + function C_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) + return C.int; + + function C_Recvfrom + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + From : Sockaddr_In_Access; + Fromlen : access C.int) + return C.int; + + function C_Select + (Nfds : C.int; + Readfds : Fd_Set_Access; + Writefds : Fd_Set_Access; + Exceptfds : Fd_Set_Access; + Timeout : Timeval_Access) + return C.int; + + function C_Send + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) + return C.int; + + function C_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : Sockaddr_In_Access; + Tolen : C.int) + return C.int; + + function C_Setsockopt + (S : C.int; + Level : C.int; + Optname : C.int; + Optval : System.Address; + Optlen : C.int) + return C.int; + + function C_Shutdown + (S : C.int; + How : C.int) + return C.int; + + function C_Socket + (Domain : C.int; + Typ : C.int; + Protocol : C.int) + return C.int; + + function C_Strerror + (Errnum : C.int) + return C.Strings.chars_ptr; + + function C_System + (Command : System.Address) + return C.int; + + function C_Write + (Fd : C.int; + Buf : System.Address; + Count : C.int) + return C.int; + + function C_Writev + (Fd : C.int; + Iov : System.Address; + Iovcnt : C.int) + return C.int; + + procedure Free_Socket_Set + (Set : Fd_Set_Access); + -- Free system-dependent socket set + + procedure Get_Socket_From_Set + (Set : Fd_Set_Access; + Socket : Int_Access; + Last : Int_Access); + -- Get last socket in Socket and remove it from the socket + -- set. The parameter Last is a maximum value of the largest + -- socket. This hint is used to avoid scanning very large socket + -- sets. After a call to Get_Socket_From_Set, Last is set back to + -- the real largest socket in the socket set. + + procedure Insert_Socket_In_Set + (Set : Fd_Set_Access; + Socket : C.int); + -- Insert socket in the socket set + + function Is_Socket_In_Set + (Set : Fd_Set_Access; + Socket : C.int) + return Boolean; + -- Check whether Socket is in the socket set + + procedure Last_Socket_In_Set + (Set : Fd_Set_Access; + Last : Int_Access); + -- Find the largest socket in the socket set. This is needed for + -- select(). When Last_Socket_In_Set is called, parameter Last is + -- a maximum value of the largest socket. This hint is used to + -- avoid scanning very large socket sets. After the call, Last is + -- set back to the real largest socket in the socket set. + + function New_Socket_Set + (Set : Fd_Set_Access) + return Fd_Set_Access; + -- Allocate a new socket set which is a system-dependent structure + -- and initialize by copying Set if it is non-null, by making it + -- empty otherwise. + + procedure Remove_Socket_From_Set + (Set : Fd_Set_Access; + Socket : C.int); + -- Remove socket from the socket set + + procedure Finalize; + procedure Initialize (Process_Blocking_IO : Boolean); + +private + + pragma Import (C, C_Bind, "bind"); + pragma Import (C, C_Close, "close"); + pragma Import (C, C_Gethostname, "gethostname"); + pragma Import (C, C_Getpeername, "getpeername"); + pragma Import (C, C_Getsockname, "getsockname"); + pragma Import (C, C_Getsockopt, "getsockopt"); + pragma Import (C, C_Inet_Addr, "inet_addr"); + pragma Import (C, C_Listen, "listen"); + pragma Import (C, C_Read, "read"); + pragma Import (C, C_Readv, "readv"); + pragma Import (C, C_Select, "select"); + pragma Import (C, C_Setsockopt, "setsockopt"); + pragma Import (C, C_Shutdown, "shutdown"); + pragma Import (C, C_Strerror, "strerror"); + pragma Import (C, C_System, "system"); + pragma Import (C, C_Write, "write"); + pragma Import (C, C_Writev, "writev"); + + pragma Import (C, Free_Socket_Set, "__gnat_free_socket_set"); + pragma Import (C, Get_Socket_From_Set, "__gnat_get_socket_from_set"); + pragma Import (C, Is_Socket_In_Set, "__gnat_is_socket_in_set"); + pragma Import (C, Last_Socket_In_Set, "__gnat_last_socket_in_set"); + pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); + pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); + pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-soliop-mingw.ads b/gcc/ada/g-soliop-mingw.ads new file mode 100644 index 00000000000..e930da934d5 --- /dev/null +++ b/gcc/ada/g-soliop-mingw.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-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 package is used to provide target specific linker_options for the +-- support of scokets as required by the package GNAT.Sockets. + +-- This is the Windows/NT version of this package + + +package GNAT.Sockets.Linker_Options is +private + pragma Linker_Options ("-lwsock32"); +end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/g-soliop-solaris.ads b/gcc/ada/g-soliop-solaris.ads new file mode 100644 index 00000000000..82ac94ff280 --- /dev/null +++ b/gcc/ada/g-soliop-solaris.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-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 package is used to provide target specific linker_options for the +-- support of scokets as required by the package GNAT.Sockets. + +-- This is the Solaris version of this package + +package GNAT.Sockets.Linker_Options is +private + pragma Linker_Options ("-lnsl"); + pragma Linker_Options ("-lsocket"); +end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/g-soliop-unixware.ads b/gcc/ada/g-soliop-unixware.ads new file mode 100644 index 00000000000..754cafd6a1e --- /dev/null +++ b/gcc/ada/g-soliop-unixware.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-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 package is used to provide target specific linker_options for the +-- support of scokets as required by the package GNAT.Sockets. + +-- This is the UnixWare version of this package + +package GNAT.Sockets.Linker_Options is +private + pragma Linker_Options ("-lnsl"); + pragma Linker_Options ("-lsocket"); +end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/g-trasym-vms.adb b/gcc/ada/g-trasym-vms.adb new file mode 100644 index 00000000000..85f541d018b --- /dev/null +++ b/gcc/ada/g-trasym-vms.adb @@ -0,0 +1,282 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T R A C E B A C K . S Y M B O L I C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2003 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Run-time symbolic traceback support for VMS + +with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; +with Interfaces.C; +with System; +with System.Aux_DEC; +with System.Soft_Links; +with System.Traceback_Entries; + +package body GNAT.Traceback.Symbolic is + + pragma Warnings (Off); + pragma Linker_Options ("--for-linker=sys$library:trace.exe"); + + use Interfaces.C; + use System; + use System.Aux_DEC; + use System.Traceback_Entries; + + subtype User_Arg_Type is Unsigned_Longword; + subtype Cond_Value_Type is Unsigned_Longword; + + type ASCIC is record + Count : unsigned_char; + Data : char_array (1 .. 255); + end record; + pragma Convention (C, ASCIC); + + for ASCIC use record + Count at 0 range 0 .. 7; + Data at 1 range 0 .. 8 * 255 - 1; + end record; + for ASCIC'Size use 8 * 256; + + function Fetch_ASCIC is new Fetch_From_Address (ASCIC); + + procedure Symbolize + (Status : out Cond_Value_Type; + Current_PC : in Address; + Adjusted_PC : in Address; + Current_FP : in Address; + Current_R26 : in Address; + Image_Name : out Address; + Module_Name : out Address; + Routine_Name : out Address; + Line_Number : out Integer; + Relative_PC : out Address; + Absolute_PC : out Address; + PC_Is_Valid : out Long_Integer; + User_Act_Proc : Address := Address'Null_Parameter; + User_Arg_Value : User_Arg_Type := User_Arg_Type'Null_Parameter); + + pragma Interface (External, Symbolize); + + pragma Import_Valued_Procedure + (Symbolize, "TBK$SYMBOLIZE", + (Cond_Value_Type, Address, Address, Address, Address, + Address, Address, Address, Integer, + Address, Address, Long_Integer, + Address, User_Arg_Type), + (Value, Value, Value, Value, Value, + Reference, Reference, Reference, Reference, + Reference, Reference, Reference, + Value, Value), + User_Act_Proc); + + function Decode_Ada_Name (Encoded_Name : String) return String; + -- Decodes an Ada identifier name. Removes leading "_ada_" and trailing + -- __{DIGIT}+ or ${DIGIT}+, converts other "__" to '.' + + --------------------- + -- Decode_Ada_Name -- + --------------------- + + function Decode_Ada_Name (Encoded_Name : String) return String is + Decoded_Name : String (1 .. Encoded_Name'Length); + Pos : Integer := Encoded_Name'First; + Last : Integer := Encoded_Name'Last; + DPos : Integer := 1; + + begin + if Pos > Last then + return ""; + end if; + + -- Skip leading _ada_ + + if Encoded_Name'Length > 4 + and then Encoded_Name (Pos .. Pos + 4) = "_ada_" + then + Pos := Pos + 5; + end if; + + -- Skip trailing __{DIGIT}+ or ${DIGIT}+ + + if Encoded_Name (Last) in '0' .. '9' then + for J in reverse Pos + 2 .. Last - 1 loop + case Encoded_Name (J) is + when '0' .. '9' => + null; + when '$' => + Last := J - 1; + exit; + when '_' => + if Encoded_Name (J - 1) = '_' then + Last := J - 2; + end if; + exit; + when others => + exit; + end case; + end loop; + end if; + + -- Now just copy encoded name to decoded name, converting "__" to '.' + + while Pos <= Last loop + if Encoded_Name (Pos) = '_' and then Encoded_Name (Pos + 1) = '_' + and then Pos /= Encoded_Name'First + then + Decoded_Name (DPos) := '.'; + Pos := Pos + 2; + + else + Decoded_Name (DPos) := Encoded_Name (Pos); + Pos := Pos + 1; + end if; + + DPos := DPos + 1; + end loop; + + return Decoded_Name (1 .. DPos - 1); + end Decode_Ada_Name; + + ------------------------ + -- Symbolic_Traceback -- + ------------------------ + + function Symbolic_Traceback (Traceback : Tracebacks_Array) return String is + Status : Cond_Value_Type; + Image_Name : ASCIC; + Image_Name_Addr : Address; + Module_Name : ASCIC; + Module_Name_Addr : Address; + Routine_Name : ASCIC; + Routine_Name_Addr : Address; + Line_Number : Integer; + Relative_PC : Address; + Absolute_PC : Address; + PC_Is_Valid : Long_Integer; + Return_Address : Address; + Res : String (1 .. 256 * Traceback'Length); + Len : Integer; + + begin + if Traceback'Length > 0 then + Len := 0; + + -- Since image computation is not thread-safe we need task lockout + + System.Soft_Links.Lock_Task.all; + + for J in Traceback'Range loop + if J = Traceback'Last then + Return_Address := Address_Zero; + else + Return_Address := PC_For (Traceback (J + 1)); + end if; + + Symbolize + (Status, + PC_For (Traceback (J)), + PC_For (Traceback (J)), + PV_For (Traceback (J)), + Return_Address, + Image_Name_Addr, + Module_Name_Addr, + Routine_Name_Addr, + Line_Number, + Relative_PC, + Absolute_PC, + PC_Is_Valid); + + Image_Name := Fetch_ASCIC (Image_Name_Addr); + Module_Name := Fetch_ASCIC (Module_Name_Addr); + Routine_Name := Fetch_ASCIC (Routine_Name_Addr); + + declare + First : Integer := Len + 1; + Last : Integer := First + 80 - 1; + Pos : Integer; + Routine_Name_D : String := Decode_Ada_Name + (To_Ada + (Routine_Name.Data (1 .. size_t (Routine_Name.Count)), + False)); + + begin + Res (First .. Last) := (others => ' '); + + Res (First .. First + Integer (Image_Name.Count) - 1) := + To_Ada + (Image_Name.Data (1 .. size_t (Image_Name.Count)), + False); + + Res (First + 10 .. + First + 10 + Integer (Module_Name.Count) - 1) := + To_Ada + (Module_Name.Data (1 .. size_t (Module_Name.Count)), + False); + + Res (First + 30 .. + First + 30 + Routine_Name_D'Length - 1) := + Routine_Name_D; + + -- If routine name doesn't fit 20 characters, output + -- the line number on next line at 50th position + + if Routine_Name_D'Length > 20 then + Pos := First + 30 + Routine_Name_D'Length; + Res (Pos) := ASCII.LF; + Last := Pos + 80; + Res (Pos + 1 .. Last) := (others => ' '); + Pos := Pos + 51; + else + Pos := First + 50; + end if; + + Res (Pos .. Pos + Integer'Image (Line_Number)'Length - 1) := + Integer'Image (Line_Number); + + Res (Last) := ASCII.LF; + Len := Last; + end; + end loop; + + System.Soft_Links.Unlock_Task.all; + return Res (1 .. Len); + + else + return ""; + end if; + end Symbolic_Traceback; + + function Symbolic_Traceback (E : Exception_Occurrence) return String is + begin + return Symbolic_Traceback (Tracebacks (E)); + end Symbolic_Traceback; + +end GNAT.Traceback.Symbolic; diff --git a/gcc/ada/i-cpp-vms.adb b/gcc/ada/i-cpp-vms.adb new file mode 100644 index 00000000000..a0a8a49962e --- /dev/null +++ b/gcc/ada/i-cpp-vms.adb @@ -0,0 +1,346 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/i-cstrea-vms.adb b/gcc/ada/i-cstrea-vms.adb new file mode 100644 index 00000000000..75b35966021 --- /dev/null +++ b/gcc/ada/i-cstrea-vms.adb @@ -0,0 +1,255 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/interfac-vms.ads b/gcc/ada/interfac-vms.ads new file mode 100644 index 00000000000..e4c39108cc9 --- /dev/null +++ b/gcc/ada/interfac-vms.ads @@ -0,0 +1,194 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/mlib-tgt-aix.adb b/gcc/ada/mlib-tgt-aix.adb new file mode 100644 index 00000000000..c95d64893a4 --- /dev/null +++ b/gcc/ada/mlib-tgt-aix.adb @@ -0,0 +1,391 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T -- +-- (AIX Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2004, 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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a set of target dependent routines to build +-- static, dynamic or relocatable libraries. + +-- This is the AIX version of the body. + +with Ada.Strings.Fixed; use Ada.Strings.Fixed; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +with MLib.Fil; +with MLib.Utl; +with Namet; use Namet; +with Osint; use Osint; +with Opt; +with Output; use Output; +with Prj.Com; +with Prj.Util; use Prj.Util; + +package body MLib.Tgt is + + No_Arguments : aliased Argument_List := (1 .. 0 => null); + Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; + + Wl_Initfini_String : constant String := "-Wl,-binitfini:"; + + Init_Fini_List : constant Argument_List_Access := + new Argument_List'(1 => null); + -- Used to put switch for automatic elaboration/finalization + + Bexpall : aliased String := "-Wl,-bexpall"; + Bexpall_Option : constant String_Access := Bexpall'Access; + -- The switch to export all symbols + + Lpthreads : aliased String := "-lpthreads"; + Native_Thread_Options : aliased Argument_List := (1 => Lpthreads'Access); + -- The switch to use when linking a library against libgnarl when using + -- Native threads. + + Lgthreads : aliased String := "-lgthreads"; + Lmalloc : aliased String := "-lmalloc"; + FSU_Thread_Options : aliased Argument_List := + (1 => Lgthreads'Access, 2 => Lmalloc'Access); + -- The switches to use when linking a library against libgnarl when using + -- FSU threads. + + Thread_Options : Argument_List_Access := null; + -- Designate the thread switches to used when linking a library against + -- libgnarl. Depends on the thread library (Native or FSU). Resolved for + -- the first library linked against libgnarl. + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return "ar"; + end Archive_Builder; + + ----------------------------- + -- Archive_Builder_Options -- + ----------------------------- + + function Archive_Builder_Options return String_List_Access is + begin + return new String_List'(1 => new String'("cr")); + end Archive_Builder_Options; + + ----------------- + -- Archive_Ext -- + ----------------- + + function Archive_Ext return String is + begin + return "a"; + end Archive_Ext; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return "ranlib"; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Foreign : Argument_List; + Afiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Address : String := ""; + Lib_Version : String := ""; + Relocatable : Boolean := False; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Foreign); + pragma Unreferenced (Afiles); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Lib_Address); + pragma Unreferenced (Lib_Version); + pragma Unreferenced (Relocatable); + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + MLib.Fil.Ext_To (Lib_Filename, DLL_Ext); + -- The file name of the library + + Init_Fini : Argument_List_Access := Empty_Argument_List; + -- The switch for automatic initialization of Stand-Alone Libraries. + -- Changed to a real switch when Auto_Init is True. + + Options_2 : Argument_List_Access := Empty_Argument_List; + -- Changed to the thread options, if -lgnarl is specified + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_File); + end if; + + -- If specified, add automatic elaboration/finalization + + if Auto_Init then + Init_Fini := Init_Fini_List; + Init_Fini (1) := + new String'(Wl_Initfini_String & Lib_Filename & "init:" & + Lib_Filename & "final"); + end if; + + -- Look for -lgnarl in Options. If found, set the thread options. + + for J in Options'Range loop + if Options (J).all = "-lgnarl" then + + -- If Thread_Options is null, read s-osinte.ads to discover the + -- thread library and set Thread_Options accordingly. + + if Thread_Options = null then + declare + File : Text_File; + Line : String (1 .. 100); + Last : Natural; + + begin + Open + (File, Include_Dir_Default_Prefix & "/s-osinte.ads"); + + while not End_Of_File (File) loop + Get_Line (File, Line, Last); + + if Index (Line (1 .. Last), "-lpthreads") /= 0 then + Thread_Options := Native_Thread_Options'Access; + exit; + + elsif Index (Line (1 .. Last), "-lgthreads") /= 0 then + Thread_Options := FSU_Thread_Options'Access; + exit; + end if; + end loop; + + Close (File); + + if Thread_Options = null then + Prj.Com.Fail ("cannot find the thread library in use"); + end if; + + exception + when others => + Prj.Com.Fail ("cannot open s-osinte.ads"); + end; + end if; + + Options_2 := Thread_Options; + exit; + end if; + end loop; + + -- Finally, call GCC (or the driver specified) to build the library + + MLib.Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles, + Options => Options & Bexpall_Option & Init_Fini.all, + Driver_Name => Driver_Name, + Options_2 => Options_2.all); + end Build_Dynamic_Library; + + ------------------------- + -- Default_DLL_Address -- + ------------------------- + + function Default_DLL_Address return String is + begin + return ""; + end Default_DLL_Address; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "a"; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return "-shared"; + end Dynamic_Option; + + ------------------- + -- Is_Object_Ext -- + ------------------- + + function Is_Object_Ext (Ext : String) return Boolean is + begin + return Ext = ".o"; + end Is_Object_Ext; + + -------------- + -- Is_C_Ext -- + -------------- + + function Is_C_Ext (Ext : String) return Boolean is + begin + return Ext = ".c"; + end Is_C_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a"; + end Is_Archive_Ext; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + begin + return "libgnat.a"; + end Libgnat; + + ------------------------ + -- Library_Exists_For -- + ------------------------ + + function Library_Exists_For (Project : Project_Id) return Boolean is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & + "for non library project"); + return False; + + else + declare + Lib_Dir : constant String := + Get_Name_String + (Projects.Table (Project).Library_Dir); + Lib_Name : constant String := + Get_Name_String + (Projects.Table (Project).Library_Name); + + begin + if Projects.Table (Project).Library_Kind = Static then + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + end; + end if; + end Library_Exists_For; + + --------------------------- + -- Library_File_Name_For -- + --------------------------- + + function Library_File_Name_For (Project : Project_Id) return Name_Id is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & + "for non library project"); + return No_Name; + + else + declare + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "lib"; + + if Projects.Table (Project).Library_Kind = Static then + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + + return Name_Find; + end; + end if; + end Library_File_Name_For; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return "o"; + end Object_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return "-fPIC"; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return True; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Full; + end Support_For_Libraries; + +end MLib.Tgt; diff --git a/gcc/ada/mlib-tgt-hpux.adb b/gcc/ada/mlib-tgt-hpux.adb new file mode 100644 index 00000000000..4eb2934cb51 --- /dev/null +++ b/gcc/ada/mlib-tgt-hpux.adb @@ -0,0 +1,368 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T -- +-- (HP-UX Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2004, 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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a set of target dependent routines to build +-- libraries (static only on HP-UX). + +-- This is the HP-UX version of the body. + +with MLib.Fil; +with MLib.Utl; +with Namet; use Namet; +with Opt; +with Output; use Output; +with Prj.Com; +with System; + +package body MLib.Tgt is + + No_Arguments : aliased Argument_List := (1 .. 0 => null); + Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; + + Wl_Init_String : aliased String := "-Wl,+init"; + Wl_Init : constant String_Access := Wl_Init_String'Access; + Wl_Fini_String : aliased String := "-Wl,+fini"; + Wl_Fini : constant String_Access := Wl_Fini_String'Access; + + Init_Fini_List : constant Argument_List_Access := + new Argument_List'(1 => Wl_Init, + 2 => null, + 3 => Wl_Fini, + 4 => null); + -- Used to put switches for automatic elaboration/finalization + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return "ar"; + end Archive_Builder; + + ----------------------------- + -- Archive_Builder_Options -- + ----------------------------- + + function Archive_Builder_Options return String_List_Access is + begin + return new String_List'(1 => new String'("cr")); + end Archive_Builder_Options; + + ----------------- + -- Archive_Ext -- + ----------------- + + function Archive_Ext return String is + begin + return "a"; + end Archive_Ext; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return "ranlib"; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Foreign : Argument_List; + Afiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Address : String := ""; + Lib_Version : String := ""; + Relocatable : Boolean := False; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Foreign); + pragma Unreferenced (Afiles); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Lib_Address); + pragma Unreferenced (Relocatable); + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + MLib.Fil.Ext_To (Lib_Filename, DLL_Ext); + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + Init_Fini : Argument_List_Access := Empty_Argument_List; + + Common_Options : constant Argument_List := + Options & new String'(PIC_Option); + -- Common set of options to the gcc command performing the link. + -- On HPUX, this command eventually resorts to collect2, which may + -- generate a C file and compile it on the fly. This compilation shall + -- also generate position independant code for the final link to + -- succeed. + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_File); + end if; + + -- If specified, add automatic elaboration/finalization + if Auto_Init then + Init_Fini := Init_Fini_List; + Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init"); + Init_Fini (4) := new String'("-Wl," & Lib_Filename & "final"); + end if; + + if Lib_Version = "" then + MLib.Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles, + Options => Common_Options & Init_Fini.all, + Driver_Name => Driver_Name); + + else + Version_Arg := new String'("-Wl,+h," & Lib_Version); + + if Is_Absolute_Path (Lib_Version) then + MLib.Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => Common_Options & Version_Arg & Init_Fini.all, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := Lib_Version /= Lib_File; + + else + MLib.Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => Common_Options & Version_Arg & Init_Fini.all, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_File; + end if; + + if Symbolic_Link_Needed then + declare + Success : Boolean; + Oldpath : String (1 .. Lib_Version'Length + 1); + Newpath : String (1 .. Lib_File'Length + 1); + + Result : Integer; + pragma Unreferenced (Result); + + function Symlink + (Oldpath : System.Address; + Newpath : System.Address) return Integer; + pragma Import (C, Symlink, "__gnat_symlink"); + + begin + Oldpath (1 .. Lib_Version'Length) := Lib_Version; + Oldpath (Oldpath'Last) := ASCII.NUL; + Newpath (1 .. Lib_File'Length) := Lib_File; + Newpath (Newpath'Last) := ASCII.NUL; + + Delete_File (Lib_File, Success); + + Result := Symlink (Oldpath'Address, Newpath'Address); + end; + end if; + end if; + end Build_Dynamic_Library; + + ------------------------- + -- Default_DLL_Address -- + ------------------------- + + function Default_DLL_Address return String is + begin + return ""; + end Default_DLL_Address; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "sl"; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return "-shared"; + end Dynamic_Option; + + ------------------- + -- Is_Object_Ext -- + ------------------- + + function Is_Object_Ext (Ext : String) return Boolean is + begin + return Ext = ".o"; + end Is_Object_Ext; + + -------------- + -- Is_C_Ext -- + -------------- + + function Is_C_Ext (Ext : String) return Boolean is + begin + return Ext = ".c"; + end Is_C_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + begin + return "libgnat.a"; + end Libgnat; + + ------------------------ + -- Library_Exists_For -- + ------------------------ + + function Library_Exists_For (Project : Project_Id) return Boolean is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & + "for non library project"); + return False; + + else + declare + Lib_Dir : constant String := + Get_Name_String (Projects.Table (Project).Library_Dir); + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + if Projects.Table (Project).Library_Kind = Static then + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + end; + end if; + end Library_Exists_For; + + --------------------------- + -- Library_File_Name_For -- + --------------------------- + + function Library_File_Name_For (Project : Project_Id) return Name_Id is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & + "for non library project"); + return No_Name; + + else + declare + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "lib"; + + if Projects.Table (Project).Library_Kind = Static then + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + + return Name_Find; + end; + end if; + end Library_File_Name_For; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return "o"; + end Object_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return "-fPIC"; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return True; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Full; + end Support_For_Libraries; + +end MLib.Tgt; diff --git a/gcc/ada/mlib-tgt-irix.adb b/gcc/ada/mlib-tgt-irix.adb new file mode 100644 index 00000000000..c18819918dd --- /dev/null +++ b/gcc/ada/mlib-tgt-irix.adb @@ -0,0 +1,363 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T -- +-- (IRIX Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2004, 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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a set of target dependent routines to build +-- static, dynamic and shared libraries. + +-- This is the IRIX version of the body. + +with MLib.Fil; +with MLib.Utl; +with Namet; use Namet; +with Opt; +with Output; use Output; +with Prj.Com; +with System; + +package body MLib.Tgt is + + No_Arguments : aliased Argument_List := (1 .. 0 => null); + Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; + + Wl_Init_String : aliased String := "-Wl,-init"; + Wl_Init : constant String_Access := Wl_Init_String'Access; + Wl_Fini_String : aliased String := "-Wl,-fini"; + Wl_Fini : constant String_Access := Wl_Fini_String'Access; + + Init_Fini_List : constant Argument_List_Access := + new Argument_List'(1 => Wl_Init, + 2 => null, + 3 => Wl_Fini, + 4 => null); + -- Used to put switches for automatic elaboration/finalization + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return "ar"; + end Archive_Builder; + + ----------------------------- + -- Archive_Builder_Options -- + ----------------------------- + + function Archive_Builder_Options return String_List_Access is + begin + return new String_List'(1 => new String'("cr")); + end Archive_Builder_Options; + + ----------------- + -- Archive_Ext -- + ----------------- + + function Archive_Ext return String is + begin + return "a"; + end Archive_Ext; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return "ranlib"; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Foreign : Argument_List; + Afiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Address : String := ""; + Lib_Version : String := ""; + Relocatable : Boolean := False; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Foreign); + pragma Unreferenced (Afiles); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Lib_Address); + pragma Unreferenced (Relocatable); + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + MLib.Fil.Ext_To (Lib_Filename, DLL_Ext); + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + Init_Fini : Argument_List_Access := Empty_Argument_List; + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_File); + end if; + + -- If specified, add automatic elaboration/finalization + if Auto_Init then + Init_Fini := Init_Fini_List; + Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init"); + Init_Fini (4) := new String'("-Wl," & Lib_Filename & "final"); + end if; + + if Lib_Version = "" then + MLib.Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles, + Options => Options & Init_Fini.all, + Driver_Name => Driver_Name); + + else + Version_Arg := new String'("-Wl,-soname," & Lib_Version); + + if Is_Absolute_Path (Lib_Version) then + MLib.Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => Options & Version_Arg & Init_Fini.all, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := Lib_Version /= Lib_File; + + else + MLib.Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => Options & Version_Arg & Init_Fini.all, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_File; + end if; + + if Symbolic_Link_Needed then + declare + Success : Boolean; + Oldpath : String (1 .. Lib_Version'Length + 1); + Newpath : String (1 .. Lib_File'Length + 1); + + Result : Integer; + pragma Unreferenced (Result); + + function Symlink + (Oldpath : System.Address; + Newpath : System.Address) + return Integer; + pragma Import (C, Symlink, "__gnat_symlink"); + + begin + Oldpath (1 .. Lib_Version'Length) := Lib_Version; + Oldpath (Oldpath'Last) := ASCII.NUL; + Newpath (1 .. Lib_File'Length) := Lib_File; + Newpath (Newpath'Last) := ASCII.NUL; + + Delete_File (Lib_File, Success); + + Result := Symlink (Oldpath'Address, Newpath'Address); + end; + end if; + end if; + end Build_Dynamic_Library; + + ------------------------- + -- Default_DLL_Address -- + ------------------------- + + function Default_DLL_Address return String is + begin + return ""; + end Default_DLL_Address; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "so"; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return "-shared"; + end Dynamic_Option; + + ------------------- + -- Is_Object_Ext -- + ------------------- + + function Is_Object_Ext (Ext : String) return Boolean is + begin + return Ext = ".o"; + end Is_Object_Ext; + + -------------- + -- Is_C_Ext -- + -------------- + + function Is_C_Ext (Ext : String) return Boolean is + begin + return Ext = ".c"; + end Is_C_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + begin + return "libgnat.a"; + end Libgnat; + + ------------------------ + -- Library_Exists_For -- + ------------------------ + + function Library_Exists_For (Project : Project_Id) return Boolean is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & + "for non library project"); + return False; + + else + declare + Lib_Dir : constant String := + Get_Name_String (Projects.Table (Project).Library_Dir); + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + if Projects.Table (Project).Library_Kind = Static then + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + end; + end if; + end Library_Exists_For; + + --------------------------- + -- Library_File_Name_For -- + --------------------------- + + function Library_File_Name_For (Project : Project_Id) return Name_Id is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & + "for non library project"); + return No_Name; + + else + declare + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "lib"; + + if Projects.Table (Project).Library_Kind = Static then + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + + return Name_Find; + end; + end if; + end Library_File_Name_For; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return "o"; + end Object_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return "-fPIC"; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return True; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Full; + end Support_For_Libraries; + +end MLib.Tgt; diff --git a/gcc/ada/mlib-tgt-linux.adb b/gcc/ada/mlib-tgt-linux.adb new file mode 100644 index 00000000000..00ab3928b79 --- /dev/null +++ b/gcc/ada/mlib-tgt-linux.adb @@ -0,0 +1,365 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T -- +-- (GNU/Linux Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a set of target dependent routines to build +-- static, dynamic and shared libraries. + +-- This is the GNU/Linux version of the body. + +with MLib.Fil; +with MLib.Utl; +with Namet; use Namet; +with Opt; +with Output; use Output; +with Prj.Com; +with System; + +package body MLib.Tgt is + + use GNAT; + use MLib; + + No_Arguments : aliased Argument_List := (1 .. 0 => null); + Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; + + Wl_Init_String : aliased String := "-Wl,-init"; + Wl_Init : constant String_Access := Wl_Init_String'Access; + Wl_Fini_String : aliased String := "-Wl,-fini"; + Wl_Fini : constant String_Access := Wl_Fini_String'Access; + + Init_Fini_List : constant Argument_List_Access := + new Argument_List'(1 => Wl_Init, + 2 => null, + 3 => Wl_Fini, + 4 => null); + -- Used to put switches for automatic elaboration/finalization + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return "ar"; + end Archive_Builder; + + ----------------------------- + -- Archive_Builder_Options -- + ----------------------------- + + function Archive_Builder_Options return String_List_Access is + begin + return new String_List'(1 => new String'("cr")); + end Archive_Builder_Options; + + ----------------- + -- Archive_Ext -- + ----------------- + + function Archive_Ext return String is + begin + return "a"; + end Archive_Ext; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return "ranlib"; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Foreign : Argument_List; + Afiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Address : String := ""; + Lib_Version : String := ""; + Relocatable : Boolean := False; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Foreign); + pragma Unreferenced (Afiles); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Lib_Address); + pragma Unreferenced (Relocatable); + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Filename, DLL_Ext); + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + Init_Fini : Argument_List_Access := Empty_Argument_List; + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_File); + end if; + + -- If specified, add automatic elaboration/finalization + if Auto_Init then + Init_Fini := Init_Fini_List; + Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init"); + Init_Fini (4) := new String'("-Wl," & Lib_Filename & "final"); + end if; + + if Lib_Version = "" then + Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles, + Options => Options & Init_Fini.all, + Driver_Name => Driver_Name); + + else + Version_Arg := new String'("-Wl,-soname," & Lib_Version); + + if Is_Absolute_Path (Lib_Version) then + Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => Options & Version_Arg & Init_Fini.all, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := Lib_Version /= Lib_File; + + else + Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => Options & Version_Arg & Init_Fini.all, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_File; + end if; + + if Symbolic_Link_Needed then + declare + Success : Boolean; + Oldpath : String (1 .. Lib_Version'Length + 1); + Newpath : String (1 .. Lib_File'Length + 1); + + Result : Integer; + pragma Unreferenced (Result); + + function Symlink + (Oldpath : System.Address; + Newpath : System.Address) return Integer; + pragma Import (C, Symlink, "__gnat_symlink"); + + begin + Oldpath (1 .. Lib_Version'Length) := Lib_Version; + Oldpath (Oldpath'Last) := ASCII.NUL; + Newpath (1 .. Lib_File'Length) := Lib_File; + Newpath (Newpath'Last) := ASCII.NUL; + + Delete_File (Lib_File, Success); + + Result := Symlink (Oldpath'Address, Newpath'Address); + end; + end if; + end if; + end Build_Dynamic_Library; + + ------------------------- + -- Default_DLL_Address -- + ------------------------- + + function Default_DLL_Address return String is + begin + return ""; + end Default_DLL_Address; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "so"; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return "-shared"; + end Dynamic_Option; + + ------------------- + -- Is_Object_Ext -- + ------------------- + + function Is_Object_Ext (Ext : String) return Boolean is + begin + return Ext = ".o"; + end Is_Object_Ext; + + -------------- + -- Is_C_Ext -- + -------------- + + function Is_C_Ext (Ext : String) return Boolean is + begin + return Ext = ".c"; + end Is_C_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + begin + return "libgnat.a"; + end Libgnat; + + ------------------------ + -- Library_Exists_For -- + ------------------------ + + function Library_Exists_For (Project : Project_Id) return Boolean is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & + "for non library project"); + return False; + + else + declare + Lib_Dir : constant String := + Get_Name_String (Projects.Table (Project).Library_Dir); + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + if Projects.Table (Project).Library_Kind = Static then + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + end; + end if; + end Library_Exists_For; + + --------------------------- + -- Library_File_Name_For -- + --------------------------- + + function Library_File_Name_For (Project : Project_Id) return Name_Id is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & + "for non library project"); + return No_Name; + + else + declare + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "lib"; + + if Projects.Table (Project).Library_Kind = Static then + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + + return Name_Find; + end; + end if; + end Library_File_Name_For; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return "o"; + end Object_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return "-fPIC"; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return True; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Full; + end Support_For_Libraries; + +end MLib.Tgt; diff --git a/gcc/ada/mlib-tgt-mingw.adb b/gcc/ada/mlib-tgt-mingw.adb new file mode 100644 index 00000000000..485be34bea6 --- /dev/null +++ b/gcc/ada/mlib-tgt-mingw.adb @@ -0,0 +1,347 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T -- +-- (Windows Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2004, 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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a set of target dependent routines to build +-- static, dynamic and shared libraries. + +-- This is the Windows version of the body. + +with Namet; use Namet; +with Opt; +with Output; use Output; +with Prj.Com; + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +with MDLL; +with MDLL.Utl; +with MLib.Fil; + +package body MLib.Tgt is + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return "ar"; + end Archive_Builder; + + ----------------------------- + -- Archive_Builder_Options -- + ----------------------------- + + function Archive_Builder_Options return String_List_Access is + begin + return new String_List'(1 => new String'("cr")); + end Archive_Builder_Options; + + ----------------- + -- Archive_Ext -- + ----------------- + + function Archive_Ext return String is + begin + return "a"; + end Archive_Ext; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return "ranlib"; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Foreign : Argument_List; + Afiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Address : String := ""; + Lib_Version : String := ""; + Relocatable : Boolean := False; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Ofiles); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Driver_Name); + pragma Unreferenced (Lib_Version); + pragma Unreferenced (Auto_Init); + + Imp_File : constant String := + "lib" & MLib.Fil.Ext_To (Lib_Filename, Archive_Ext); + -- Name of the import library + + DLL_File : constant String := MLib.Fil.Ext_To (Lib_Filename, DLL_Ext); + -- Name of the DLL file + + Lib_File : constant String := Lib_Dir & Directory_Separator & DLL_File; + -- Full path of the DLL file + + Success : Boolean; + + begin + if Opt.Verbose_Mode then + if Relocatable then + Write_Str ("building relocatable shared library "); + else + Write_Str ("building non-relocatable shared library "); + end if; + + Write_Line (Lib_File); + end if; + + MDLL.Verbose := Opt.Verbose_Mode; + MDLL.Quiet := not MDLL.Verbose; + + MDLL.Utl.Locate; + + MDLL.Build_Dynamic_Library + (Foreign, Afiles, + MDLL.Null_Argument_List, MDLL.Null_Argument_List, Options, + Lib_Filename, Lib_Filename & ".def", + Lib_Address, True, Relocatable); + + -- Move the DLL and import library in the lib directory + + Copy_File (DLL_File, Lib_Dir, Success, Mode => Overwrite); + + if not Success then + Fail ("could not copy DLL to library dir"); + end if; + + Copy_File (Imp_File, Lib_Dir, Success, Mode => Overwrite); + + if not Success then + Fail ("could not copy import library to library dir"); + end if; + + -- Delete files + + Delete_File (DLL_File, Success); + + if not Success then + Fail ("could not delete DLL from build dir"); + end if; + + Delete_File (Imp_File, Success); + + if not Success then + Fail ("could not delete import library from build dir"); + end if; + end Build_Dynamic_Library; + + ------------------------- + -- Default_DLL_Address -- + ------------------------- + + function Default_DLL_Address return String is + begin + return "0x11000000"; + end Default_DLL_Address; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "dll"; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return ""; + end Dynamic_Option; + + ------------------- + -- Is_Object_Ext -- + ------------------- + + function Is_Object_Ext (Ext : String) return Boolean is + begin + return Ext = ".o"; + end Is_Object_Ext; + + -------------- + -- Is_C_Ext -- + -------------- + + function Is_C_Ext (Ext : String) return Boolean is + begin + return Ext = ".c"; + end Is_C_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a"; + end Is_Archive_Ext; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + begin + return "libgnat.a"; + end Libgnat; + + ------------------------ + -- Library_Exists_For -- + ------------------------ + + function Library_Exists_For (Project : Project_Id) return Boolean is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & + "for non library project"); + return False; + + else + declare + Lib_Dir : constant String := + Get_Name_String (Projects.Table (Project).Library_Dir); + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + if Projects.Table (Project).Library_Kind = Static then + + -- Static libraries are named : lib.a + + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + MLib.Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + -- Shared libraries are named : .dll + + return Is_Regular_File + (Lib_Dir & Directory_Separator & + MLib.Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + end; + end if; + end Library_Exists_For; + + --------------------------- + -- Library_File_Name_For -- + --------------------------- + + function Library_File_Name_For (Project : Project_Id) return Name_Id is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & + "for non library project"); + return No_Name; + + else + declare + Lib_Name : constant String := + Get_Name_String + (Projects.Table (Project).Library_Name); + + begin + if Projects.Table (Project).Library_Kind = Static then + + -- Static libraries are named : lib.a + + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "lib"; + + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + -- Shared libraries are named : .dll + + Name_Len := 0; + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + + return Name_Find; + end; + end if; + end Library_File_Name_For; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return "o"; + end Object_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return False; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Full; + end Support_For_Libraries; + +end MLib.Tgt; diff --git a/gcc/ada/mlib-tgt-solaris.adb b/gcc/ada/mlib-tgt-solaris.adb new file mode 100644 index 00000000000..ac5e4b937fe --- /dev/null +++ b/gcc/ada/mlib-tgt-solaris.adb @@ -0,0 +1,362 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T -- +-- (Solaris Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a set of target dependent routines to build +-- static, dynamic and shared libraries. + +-- This is the Solaris version of the body + +with MLib.Fil; +with MLib.Utl; +with Namet; use Namet; +with Opt; +with Output; use Output; +with Prj.Com; +with System; + +package body MLib.Tgt is + + No_Arguments : aliased Argument_List := (1 .. 0 => null); + Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; + + Wl_Init_String : constant String := "-Wl,-zinitarray="; + Wl_Fini_String : constant String := "-Wl,-zfiniarray="; + + Init_Fini_List : constant Argument_List_Access := + new Argument_List'(1 => null, + 2 => null); + + -- Used to put switches for automatic elaboration/finalization + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return "ar"; + end Archive_Builder; + + ----------------------------- + -- Archive_Builder_Options -- + ----------------------------- + + function Archive_Builder_Options return String_List_Access is + begin + return new String_List'(1 => new String'("cr")); + end Archive_Builder_Options; + + ----------------- + -- Archive_Ext -- + ----------------- + + function Archive_Ext return String is + begin + return "a"; + end Archive_Ext; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return "ranlib"; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Foreign : Argument_List; + Afiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Address : String := ""; + Lib_Version : String := ""; + Relocatable : Boolean := False; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Foreign); + pragma Unreferenced (Afiles); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Lib_Address); + pragma Unreferenced (Relocatable); + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Filename, DLL_Ext); + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + Init_Fini : Argument_List_Access := Empty_Argument_List; + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_File); + end if; + + -- If specified, add automatic elaboration/finalization + if Auto_Init then + Init_Fini := Init_Fini_List; + Init_Fini (1) := + new String'(Wl_Init_String & Lib_Filename & "init"); + Init_Fini (2) := + new String'(Wl_Fini_String & Lib_Filename & "final"); + end if; + + if Lib_Version = "" then + Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles, + Options => Options & Init_Fini.all, + Driver_Name => Driver_Name); + + else + Version_Arg := new String'("-Wl,-h," & Lib_Version); + + if Is_Absolute_Path (Lib_Version) then + Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => Options & Version_Arg & Init_Fini.all, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := Lib_Version /= Lib_File; + + else + Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => Options & Version_Arg & Init_Fini.all, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_File; + end if; + + if Symbolic_Link_Needed then + declare + Success : Boolean; + Oldpath : String (1 .. Lib_Version'Length + 1); + Newpath : String (1 .. Lib_File'Length + 1); + + Result : Integer; + pragma Unreferenced (Result); + + function Symlink + (Oldpath : System.Address; + Newpath : System.Address) + return Integer; + pragma Import (C, Symlink, "__gnat_symlink"); + + begin + Oldpath (1 .. Lib_Version'Length) := Lib_Version; + Oldpath (Oldpath'Last) := ASCII.NUL; + Newpath (1 .. Lib_File'Length) := Lib_File; + Newpath (Newpath'Last) := ASCII.NUL; + + Delete_File (Lib_File, Success); + + Result := Symlink (Oldpath'Address, Newpath'Address); + end; + end if; + end if; + end Build_Dynamic_Library; + + ------------------------- + -- Default_DLL_Address -- + ------------------------- + + function Default_DLL_Address return String is + begin + return ""; + end Default_DLL_Address; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "so"; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return "-shared"; + end Dynamic_Option; + + ------------------- + -- Is_Object_Ext -- + ------------------- + + function Is_Object_Ext (Ext : String) return Boolean is + begin + return Ext = ".o"; + end Is_Object_Ext; + + -------------- + -- Is_C_Ext -- + -------------- + + function Is_C_Ext (Ext : String) return Boolean is + begin + return Ext = ".c"; + end Is_C_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + begin + return "libgnat.a"; + end Libgnat; + + ------------------------ + -- Library_Exists_For -- + ------------------------ + + function Library_Exists_For (Project : Project_Id) return Boolean is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & + "for non library project"); + return False; + + else + declare + Lib_Dir : constant String := + Get_Name_String (Projects.Table (Project).Library_Dir); + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + if Projects.Table (Project).Library_Kind = Static then + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + end; + end if; + end Library_Exists_For; + + --------------------------- + -- Library_File_Name_For -- + --------------------------- + + function Library_File_Name_For (Project : Project_Id) return Name_Id is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & + "for non library project"); + return No_Name; + + else + declare + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "lib"; + + if Projects.Table (Project).Library_Kind = Static then + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + + return Name_Find; + end; + end if; + end Library_File_Name_For; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return "o"; + end Object_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return "-fPIC"; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return True; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Full; + end Support_For_Libraries; + +end MLib.Tgt; diff --git a/gcc/ada/mlib-tgt-tru64.adb b/gcc/ada/mlib-tgt-tru64.adb new file mode 100644 index 00000000000..2474da3ea84 --- /dev/null +++ b/gcc/ada/mlib-tgt-tru64.adb @@ -0,0 +1,380 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T -- +-- (True64 Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a set of target dependent routines to build +-- static, dynamic and shared libraries. + +-- This is the True64 version of the body. + +with MLib.Fil; +with MLib.Utl; +with Namet; use Namet; +with Opt; +with Output; use Output; +with Prj.Com; +with System; + +package body MLib.Tgt is + + use GNAT; + use MLib; + + Expect_Unresolved : aliased String := "-Wl,-expect_unresolved,*"; + + No_Arguments : aliased Argument_List := (1 .. 0 => null); + Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access; + + Wl_Init_String : aliased String := "-Wl,-init"; + Wl_Init : constant String_Access := Wl_Init_String'Access; + Wl_Fini_String : aliased String := "-Wl,-fini"; + Wl_Fini : constant String_Access := Wl_Fini_String'Access; + + Init_Fini_List : constant Argument_List_Access := + new Argument_List'(1 => Wl_Init, + 2 => null, + 3 => Wl_Fini, + 4 => null); + -- Used to put switches for automatic elaboration/finalization + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return "ar"; + end Archive_Builder; + + ----------------------------- + -- Archive_Builder_Options -- + ----------------------------- + + function Archive_Builder_Options return String_List_Access is + begin + return new String_List'(1 => new String'("cr")); + end Archive_Builder_Options; + + ----------------- + -- Archive_Ext -- + ----------------- + + function Archive_Ext return String is + begin + return "a"; + end Archive_Ext; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return "ranlib"; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Foreign : Argument_List; + Afiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Address : String := ""; + Lib_Version : String := ""; + Relocatable : Boolean := False; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Foreign); + pragma Unreferenced (Afiles); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Lib_Address); + pragma Unreferenced (Relocatable); + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Filename, DLL_Ext); + + Version_Arg : String_Access; + Symbolic_Link_Needed : Boolean := False; + + Init_Fini : Argument_List_Access := Empty_Argument_List; + + begin + if Opt.Verbose_Mode then + Write_Str ("building relocatable shared library "); + Write_Line (Lib_File); + end if; + + -- If specified, add automatic elaboration/finalization + + if Auto_Init then + Init_Fini := Init_Fini_List; + Init_Fini (2) := new String'("-Wl," & Lib_Filename & "init"); + Init_Fini (4) := new String'("-Wl," & Lib_Filename & "final"); + end if; + + if Lib_Version = "" then + Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles, + Options => + Options & + Expect_Unresolved'Access & + Init_Fini.all, + Driver_Name => Driver_Name); + + else + Version_Arg := new String'("-Wl,-soname," & Lib_Version); + + if Is_Absolute_Path (Lib_Version) then + Utl.Gcc + (Output_File => Lib_Version, + Objects => Ofiles, + Options => + Options & + Version_Arg & + Expect_Unresolved'Access & + Init_Fini.all, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := Lib_Version /= Lib_File; + + else + Utl.Gcc + (Output_File => Lib_Dir & Directory_Separator & Lib_Version, + Objects => Ofiles, + Options => + Options & + Version_Arg & + Expect_Unresolved'Access & + Init_Fini.all, + Driver_Name => Driver_Name); + Symbolic_Link_Needed := + Lib_Dir & Directory_Separator & Lib_Version /= Lib_File; + end if; + + if Symbolic_Link_Needed then + declare + Success : Boolean; + Oldpath : String (1 .. Lib_Version'Length + 1); + Newpath : String (1 .. Lib_File'Length + 1); + + Result : Integer; + pragma Unreferenced (Result); + + function Symlink + (Oldpath : System.Address; + Newpath : System.Address) + return Integer; + pragma Import (C, Symlink, "__gnat_symlink"); + + begin + Oldpath (1 .. Lib_Version'Length) := Lib_Version; + Oldpath (Oldpath'Last) := ASCII.NUL; + Newpath (1 .. Lib_File'Length) := Lib_File; + Newpath (Newpath'Last) := ASCII.NUL; + + Delete_File (Lib_File, Success); + + Result := Symlink (Oldpath'Address, Newpath'Address); + end; + end if; + end if; + end Build_Dynamic_Library; + + ------------------------- + -- Default_DLL_Address -- + ------------------------- + + function Default_DLL_Address return String is + begin + return ""; + end Default_DLL_Address; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "so"; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return "-shared"; + end Dynamic_Option; + + ------------------- + -- Is_Object_Ext -- + ------------------- + + function Is_Object_Ext (Ext : String) return Boolean is + begin + return Ext = ".o"; + end Is_Object_Ext; + + -------------- + -- Is_C_Ext -- + -------------- + + function Is_C_Ext (Ext : String) return Boolean is + begin + return Ext = ".c"; + end Is_C_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a" or else Ext = ".so"; + end Is_Archive_Ext; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + begin + return "libgnat.a"; + end Libgnat; + + ------------------------ + -- Library_Exists_For -- + ------------------------ + + function Library_Exists_For (Project : Project_Id) return Boolean is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & + "for non library project"); + return False; + + else + declare + Lib_Dir : constant String := + Get_Name_String (Projects.Table (Project).Library_Dir); + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + if Projects.Table (Project).Library_Kind = Static then + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + end; + end if; + end Library_Exists_For; + + --------------------------- + -- Library_File_Name_For -- + --------------------------- + + function Library_File_Name_For (Project : Project_Id) return Name_Id is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & + "for non library project"); + return No_Name; + + else + declare + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "lib"; + + if Projects.Table (Project).Library_Kind = Static then + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + + return Name_Find; + end; + end if; + end Library_File_Name_For; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return "o"; + end Object_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return True; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Full; + end Support_For_Libraries; + +end MLib.Tgt; diff --git a/gcc/ada/mlib-tgt-vms.adb b/gcc/ada/mlib-tgt-vms.adb new file mode 100644 index 00000000000..6db0dccb9dc --- /dev/null +++ b/gcc/ada/mlib-tgt-vms.adb @@ -0,0 +1,703 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T -- +-- (VMS Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VMS version of the body + +with Ada.Characters.Handling; use Ada.Characters.Handling; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +with MLib.Fil; +with MLib.Utl; +with Namet; use Namet; +with Opt; use Opt; +with Output; use Output; +with Prj.Com; +with System; use System; +with System.Case_Util; use System.Case_Util; + +package body MLib.Tgt is + + use GNAT; + + Empty_Argument_List : aliased Argument_List := (1 .. 0 => null); + Additional_Objects : Argument_List_Access := Empty_Argument_List'Access; + -- Used to add the generated auto-init object files for auto-initializing + -- stand-alone libraries. + + Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler"; + -- The name of the command to invoke the macro-assembler + + VMS_Options : Argument_List := (1 .. 1 => null); + + Gnatsym_Name : constant String := "gnatsym"; + + Gnatsym_Path : String_Access; + + Arguments : Argument_List_Access := null; + Last_Argument : Natural := 0; + + Success : Boolean := False; + + Shared_Libgcc : aliased String := "-shared-libgcc"; + + No_Shared_Libgcc_Switch : aliased Argument_List := (1 .. 0 => null); + Shared_Libgcc_Switch : aliased Argument_List := + (1 => Shared_Libgcc'Access); + Link_With_Shared_Libgcc : Argument_List_Access := + No_Shared_Libgcc_Switch'Access; + + ------------------------------ + -- Target dependent section -- + ------------------------------ + + function Popen (Command, Mode : System.Address) return System.Address; + pragma Import (C, Popen); + + function Pclose (File : System.Address) return Integer; + pragma Import (C, Pclose); + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return "ar"; + end Archive_Builder; + + ----------------------------- + -- Archive_Builder_Options -- + ----------------------------- + + function Archive_Builder_Options return String_List_Access is + begin + return new String_List'(1 => new String'("cr")); + end Archive_Builder_Options; + + ----------------- + -- Archive_Ext -- + ----------------- + + function Archive_Ext return String is + begin + return "olb"; + end Archive_Ext; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return "ranlib"; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Foreign : Argument_List; + Afiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Address : String := ""; + Lib_Version : String := ""; + Relocatable : Boolean := False; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Foreign); + pragma Unreferenced (Afiles); + pragma Unreferenced (Lib_Address); + pragma Unreferenced (Relocatable); + + Lib_File : constant String := + Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Filename, DLL_Ext); + + Opts : Argument_List := Options; + Last_Opt : Natural := Opts'Last; + Opts2 : Argument_List (Options'Range); + Last_Opt2 : Natural := Opts2'First - 1; + + Inter : constant Argument_List := Interfaces; + + function Is_Interface (Obj_File : String) return Boolean; + -- For a Stand-Alone Library, returns True if Obj_File is the object + -- file name of an interface of the SAL. + -- For other libraries, always return True. + + function Option_File_Name return String; + -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt" + + function Version_String return String; + -- Returns Lib_Version if not empty, otherwise returns "1". + -- Fails gnatmake if Lib_Version is not the image of a positive number. + + ------------------ + -- Is_Interface -- + ------------------ + + function Is_Interface (Obj_File : String) return Boolean is + ALI : constant String := + Fil.Ext_To + (Filename => To_Lower (Base_Name (Obj_File)), + New_Ext => "ali"); + + begin + if Inter'Length = 0 then + return True; + + elsif ALI'Length > 2 and then + ALI (ALI'First .. ALI'First + 1) = "b$" + then + return True; + + else + for J in Inter'Range loop + if Inter (J).all = ALI then + return True; + end if; + end loop; + + return False; + end if; + end Is_Interface; + + ---------------------- + -- Option_File_Name -- + ---------------------- + + function Option_File_Name return String is + begin + if Symbol_Data.Symbol_File = No_Name then + return "symvec.opt"; + else + Get_Name_String (Symbol_Data.Symbol_File); + To_Lower (Name_Buffer (1 .. Name_Len)); + return Name_Buffer (1 .. Name_Len); + end if; + end Option_File_Name; + + -------------------- + -- Version_String -- + -------------------- + + function Version_String return String is + Version : Integer := 0; + begin + if Lib_Version = "" then + return "1"; + + else + begin + Version := Integer'Value (Lib_Version); + + if Version <= 0 then + raise Constraint_Error; + end if; + + return Lib_Version; + + exception + when Constraint_Error => + Fail ("illegal version """, Lib_Version, + """ (on VMS version must be a positive number)"); + return ""; + end; + end if; + end Version_String; + + Opt_File_Name : constant String := Option_File_Name; + Version : constant String := Version_String; + For_Linker_Opt : String_Access; + + -- Start of processing for Build_Dynamic_Library + + begin + -- Invoke gcc with -shared-libgcc, but only for GCC 3 or higher + + if GCC_Version >= 3 then + Link_With_Shared_Libgcc := Shared_Libgcc_Switch'Access; + else + Link_With_Shared_Libgcc := No_Shared_Libgcc_Switch'Access; + end if; + + -- If option file name does not ends with ".opt", append "/OPTIONS" + -- to its specification for the VMS linker. + + if Opt_File_Name'Length > 4 + and then + Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt" + then + For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name); + else + For_Linker_Opt := + new String'("--for-linker=" & Opt_File_Name & "/OPTIONS"); + end if; + + VMS_Options (VMS_Options'First) := For_Linker_Opt; + + for J in Inter'Range loop + To_Lower (Inter (J).all); + end loop; + + -- "gnatsym" is necessary for building the option file + + if Gnatsym_Path = null then + Gnatsym_Path := OS_Lib.Locate_Exec_On_Path (Gnatsym_Name); + + if Gnatsym_Path = null then + Fail (Gnatsym_Name, " not found in path"); + end if; + end if; + + -- For auto-initialization of a stand-alone library, we create + -- a macro-assembly file and we invoke the macro-assembler. + + if Auto_Init then + declare + Macro_File_Name : constant String := Lib_Filename & "$init.asm"; + Macro_File : File_Descriptor; + Init_Proc : String := Lib_Filename & "INIT"; + Popen_Result : System.Address; + Pclose_Result : Integer; + Len : Natural; + OK : Boolean := True; + + Command : constant String := + Macro_Name & " " & Macro_File_Name & ASCII.NUL; + -- The command to invoke the assembler on the generated auto-init + -- assembly file. + + Mode : constant String := "r" & ASCII.NUL; + -- The mode for the invocation of Popen + + begin + To_Upper (Init_Proc); + + if Verbose_Mode then + Write_Str ("Creating auto-init assembly file """); + Write_Str (Macro_File_Name); + Write_Line (""""); + end if; + + -- Create and write the auto-init assembly file + + declare + First_Line : constant String := + ASCII.HT & ".section LIB$INITIALIZE,GBL,NOWRT" & + ASCII.LF; + Second_Line : constant String := + ASCII.HT & ".long " & Init_Proc & ASCII.LF; + -- First and second lines of the auto-init assembly file + + begin + Macro_File := Create_File (Macro_File_Name, Text); + OK := Macro_File /= Invalid_FD; + + if OK then + Len := Write + (Macro_File, First_Line (First_Line'First)'Address, + First_Line'Length); + OK := Len = First_Line'Length; + end if; + + if OK then + Len := Write + (Macro_File, Second_Line (Second_Line'First)'Address, + Second_Line'Length); + OK := Len = Second_Line'Length; + end if; + + if OK then + Close (Macro_File, OK); + end if; + + if not OK then + Fail ("creation of auto-init assembly file """, + Macro_File_Name, """ failed"); + end if; + end; + + -- Invoke the macro-assembler + + if Verbose_Mode then + Write_Str ("Assembling auto-init assembly file """); + Write_Str (Macro_File_Name); + Write_Line (""""); + end if; + + Popen_Result := Popen (Command (Command'First)'Address, + Mode (Mode'First)'Address); + + if Popen_Result = Null_Address then + Fail ("assembly of auto-init assembly file """, + Macro_File_Name, """ failed"); + end if; + + -- Wait for the end of execution of the macro-assembler + + Pclose_Result := Pclose (Popen_Result); + + if Pclose_Result < 0 then + Fail ("assembly of auto init assembly file """, + Macro_File_Name, """ failed"); + end if; + + -- Add the generated object file to the list of objects to be + -- included in the library. + + Additional_Objects := + new Argument_List' + (1 => new String'(Lib_Filename & "$init.obj")); + end; + end if; + + -- Allocate the argument list and put the symbol file name, the + -- reference (if any) and the policy (if not autonomous). + + Arguments := new Argument_List (1 .. Ofiles'Length + 8); + + Last_Argument := 0; + + -- Verbosity + + if Verbose_Mode then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-v"); + end if; + + -- Version number (major ID) + + if Lib_Version /= "" then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-V"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Version); + end if; + + -- Symbol file + + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-s"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Opt_File_Name); + + -- Reference Symbol File + + if Symbol_Data.Reference /= No_Name then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-r"); + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := + new String'(Get_Name_String (Symbol_Data.Reference)); + end if; + + -- Policy + + case Symbol_Data.Symbol_Policy is + when Autonomous => + null; + + when Compliant => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-c"); + + when Controlled => + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'("-C"); + end case; + + -- Add each relevant object file + + for Index in Ofiles'Range loop + if Is_Interface (Ofiles (Index).all) then + Last_Argument := Last_Argument + 1; + Arguments (Last_Argument) := new String'(Ofiles (Index).all); + end if; + end loop; + + -- Spawn gnatsym + + Spawn (Program_Name => Gnatsym_Path.all, + Args => Arguments (1 .. Last_Argument), + Success => Success); + + if not Success then + Fail ("unable to create symbol file for library """, + Lib_Filename, """"); + end if; + + Free (Arguments); + + -- Move all the -l switches from Opts to Opts2 + + declare + Index : Natural := Opts'First; + Opt : String_Access; + + begin + while Index <= Last_Opt loop + Opt := Opts (Index); + + if Opt'Length > 2 and then + Opt (Opt'First .. Opt'First + 1) = "-l" + then + if Index < Last_Opt then + Opts (Index .. Last_Opt - 1) := + Opts (Index + 1 .. Last_Opt); + end if; + + Last_Opt := Last_Opt - 1; + + Last_Opt2 := Last_Opt2 + 1; + Opts2 (Last_Opt2) := Opt; + + else + Index := Index + 1; + end if; + end loop; + end; + + -- Invoke gcc to build the library + + Utl.Gcc + (Output_File => Lib_File, + Objects => Ofiles & Additional_Objects.all, + Options => VMS_Options, + Options_2 => Link_With_Shared_Libgcc.all & + Opts (Opts'First .. Last_Opt) & + Opts2 (Opts2'First .. Last_Opt2), + Driver_Name => Driver_Name); + + -- The auto-init object file need to be deleted, so that it will not + -- be included in the library as a regular object file, otherwise + -- it will be included twice when the library will be built next + -- time, which may lead to errors. + + if Auto_Init then + declare + Auto_Init_Object_File_Name : constant String := + Lib_Filename & "$init.obj"; + Disregard : Boolean; + + begin + if Verbose_Mode then + Write_Str ("deleting auto-init object file """); + Write_Str (Auto_Init_Object_File_Name); + Write_Line (""""); + end if; + + Delete_File (Auto_Init_Object_File_Name, Success => Disregard); + end; + end if; + end Build_Dynamic_Library; + + ------------------------- + -- Default_DLL_Address -- + ------------------------- + + function Default_DLL_Address return String is + begin + return ""; + end Default_DLL_Address; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return "exe"; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return "-shared"; + end Dynamic_Option; + + ------------------- + -- Is_Object_Ext -- + ------------------- + + function Is_Object_Ext (Ext : String) return Boolean is + begin + return Ext = ".obj"; + end Is_Object_Ext; + + -------------- + -- Is_C_Ext -- + -------------- + + function Is_C_Ext (Ext : String) return Boolean is + begin + return Ext = ".c"; + end Is_C_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".olb" or else Ext = ".exe"; + end Is_Archive_Ext; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + Libgnat_A : constant String := "libgnat.a"; + Libgnat_Olb : constant String := "libgnat.olb"; + + begin + Name_Len := Libgnat_A'Length; + Name_Buffer (1 .. Name_Len) := Libgnat_A; + + if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then + return Libgnat_A; + + else + return Libgnat_Olb; + end if; + end Libgnat; + + ------------------------ + -- Library_Exists_For -- + ------------------------ + + function Library_Exists_For (Project : Project_Id) return Boolean is + begin + if not Projects.Table (Project).Library then + Fail ("INTERNAL ERROR: Library_Exists_For called " & + "for non library project"); + return False; + + else + declare + Lib_Dir : constant String := + Get_Name_String (Projects.Table (Project).Library_Dir); + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + if Projects.Table (Project).Library_Kind = Static then + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + end; + end if; + end Library_Exists_For; + + --------------------------- + -- Library_File_Name_For -- + --------------------------- + + function Library_File_Name_For (Project : Project_Id) return Name_Id is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & + "for non library project"); + return No_Name; + + else + declare + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "lib"; + + if Projects.Table (Project).Library_Kind = Static then + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + + return Name_Find; + end; + end if; + end Library_File_Name_For; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return "obj"; + end Object_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return True; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Full; + end Support_For_Libraries; + +end MLib.Tgt; diff --git a/gcc/ada/mlib-tgt-vxworks.adb b/gcc/ada/mlib-tgt-vxworks.adb new file mode 100644 index 00000000000..9b3f5757463 --- /dev/null +++ b/gcc/ada/mlib-tgt-vxworks.adb @@ -0,0 +1,317 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M L I B . T G T -- +-- (VxWorks Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a set of target dependent routines to build +-- static libraries. + +-- This is the VxWorks version of the body + +with MLib.Fil; +with Namet; use Namet; +with Prj.Com; +with Sdefault; + +package body MLib.Tgt is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Get_Target_Suffix return String; + -- Returns the required suffix for some utilities + -- (such as ar and ranlib) that depend on the real target. + + --------------------- + -- Archive_Builder -- + --------------------- + + function Archive_Builder return String is + begin + return "ar" & Get_Target_Suffix; + end Archive_Builder; + + ----------------------------- + -- Archive_Builder_Options -- + ----------------------------- + + function Archive_Builder_Options return String_List_Access is + begin + return new String_List'(1 => new String'("cr")); + end Archive_Builder_Options; + + ----------------- + -- Archive_Ext -- + ----------------- + + function Archive_Ext return String is + begin + return "a"; + end Archive_Ext; + + --------------------- + -- Archive_Indexer -- + --------------------- + + function Archive_Indexer return String is + begin + return "ranlib" & Get_Target_Suffix; + end Archive_Indexer; + + --------------------------- + -- Build_Dynamic_Library -- + --------------------------- + + procedure Build_Dynamic_Library + (Ofiles : Argument_List; + Foreign : Argument_List; + Afiles : Argument_List; + Options : Argument_List; + Interfaces : Argument_List; + Lib_Filename : String; + Lib_Dir : String; + Symbol_Data : Symbol_Record; + Driver_Name : Name_Id := No_Name; + Lib_Address : String := ""; + Lib_Version : String := ""; + Relocatable : Boolean := False; + Auto_Init : Boolean := False) + is + pragma Unreferenced (Ofiles); + pragma Unreferenced (Foreign); + pragma Unreferenced (Afiles); + pragma Unreferenced (Options); + pragma Unreferenced (Interfaces); + pragma Unreferenced (Lib_Filename); + pragma Unreferenced (Lib_Dir); + pragma Unreferenced (Symbol_Data); + pragma Unreferenced (Driver_Name); + pragma Unreferenced (Lib_Address); + pragma Unreferenced (Lib_Version); + pragma Unreferenced (Relocatable); + pragma Unreferenced (Auto_Init); + + begin + null; + end Build_Dynamic_Library; + + ------------------------- + -- Default_DLL_Address -- + ------------------------- + + function Default_DLL_Address return String is + begin + return ""; + end Default_DLL_Address; + + ------------- + -- DLL_Ext -- + ------------- + + function DLL_Ext return String is + begin + return ""; + end DLL_Ext; + + -------------------- + -- Dynamic_Option -- + -------------------- + + function Dynamic_Option return String is + begin + return ""; + end Dynamic_Option; + + ----------------------------- + -- Get_Target_Suffix -- + ----------------------------- + + function Get_Target_Suffix return String is + Target_Name : constant String_Ptr := Sdefault.Target_Name; + Index : Positive := Target_Name'First; + + begin + while Index < Target_Name'Last + and then Target_Name (Index + 1) /= '-' + loop + Index := Index + 1; + end loop; + + if Target_Name (Target_Name'First .. Index) = "m68k" then + return "68k"; + elsif Target_Name (Target_Name'First .. Index) = "mips" then + return "mips"; + elsif Target_Name (Target_Name'First .. Index) = "powerpc" then + return "ppc"; + elsif Target_Name (Target_Name'First .. Index) = "sparc" then + return "sparc"; + elsif Target_Name (Target_Name'First .. Index) = "sparc64" then + return "sparc64"; + elsif Target_Name (Target_Name'First .. Index) = "xscale" then + return "arm"; + else + return ""; + end if; + end Get_Target_Suffix; + + ------------------- + -- Is_Object_Ext -- + ------------------- + + function Is_Object_Ext (Ext : String) return Boolean is + begin + return Ext = ".o"; + end Is_Object_Ext; + + -------------- + -- Is_C_Ext -- + -------------- + + function Is_C_Ext (Ext : String) return Boolean is + begin + return Ext = ".c"; + end Is_C_Ext; + + -------------------- + -- Is_Archive_Ext -- + -------------------- + + function Is_Archive_Ext (Ext : String) return Boolean is + begin + return Ext = ".a"; + end Is_Archive_Ext; + + ------------- + -- Libgnat -- + ------------- + + function Libgnat return String is + begin + return "libgnat.a"; + end Libgnat; + + ------------------------ + -- Library_Exists_For -- + ------------------------ + + function Library_Exists_For (Project : Project_Id) return Boolean is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " & + "for non library project"); + return False; -- To avoid warning; + + else + declare + Lib_Dir : constant String := + Get_Name_String (Projects.Table (Project).Library_Dir); + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + if Projects.Table (Project).Library_Kind = Static then + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + return Is_Regular_File + (Lib_Dir & Directory_Separator & "lib" & + Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + end; + end if; + end Library_Exists_For; + + --------------------------- + -- Library_File_Name_For -- + --------------------------- + + function Library_File_Name_For (Project : Project_Id) return Name_Id is + begin + if not Projects.Table (Project).Library then + Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " & + "for non library project"); + return No_Name; + + else + declare + Lib_Name : constant String := + Get_Name_String (Projects.Table (Project).Library_Name); + + begin + Name_Len := 3; + Name_Buffer (1 .. Name_Len) := "lib"; + + if Projects.Table (Project).Library_Kind = Static then + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, Archive_Ext)); + + else + Add_Str_To_Name_Buffer (Fil.Ext_To (Lib_Name, DLL_Ext)); + end if; + + return Name_Find; + end; + end if; + end Library_File_Name_For; + + ---------------- + -- Object_Ext -- + ---------------- + + function Object_Ext return String is + begin + return "o"; + end Object_Ext; + + ---------------- + -- PIC_Option -- + ---------------- + + function PIC_Option return String is + begin + return ""; + end PIC_Option; + + ----------------------------------------------- + -- Standalone_Library_Auto_Init_Is_Supported -- + ----------------------------------------------- + + function Standalone_Library_Auto_Init_Is_Supported return Boolean is + begin + return False; + end Standalone_Library_Auto_Init_Is_Supported; + + --------------------------- + -- Support_For_Libraries -- + --------------------------- + + function Support_For_Libraries return Library_Support is + begin + return Static_Only; + end Support_For_Libraries; + +end MLib.Tgt; diff --git a/gcc/ada/s-asthan-vms.adb b/gcc/ada/s-asthan-vms.adb new file mode 100644 index 00000000000..86d04025dbf --- /dev/null +++ b/gcc/ada/s-asthan-vms.adb @@ -0,0 +1,597 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A S T _ H A N D L I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-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 version. + +with System; use System; + +with System.IO; + +with System.Machine_Code; +with System.Parameters; +with System.Storage_Elements; + +with System.Tasking; +with System.Tasking.Rendezvous; +with System.Tasking.Initialization; +with System.Tasking.Utilities; + +with System.Task_Primitives; +with System.Task_Primitives.Operations; +with System.Task_Primitives.Operations.DEC; + +-- with Ada.Finalization; +-- removed, because of problem with controlled attribute ??? + +with Ada.Task_Attributes; +with Ada.Task_Identification; + +with Ada.Exceptions; use Ada.Exceptions; + +with Ada.Unchecked_Conversion; + +package body System.AST_Handling is + + package ATID renames Ada.Task_Identification; + + package SP renames System.Parameters; + package ST renames System.Tasking; + package STR renames System.Tasking.Rendezvous; + package STI renames System.Tasking.Initialization; + package STU renames System.Tasking.Utilities; + + package SSE renames System.Storage_Elements; + package STPO renames System.Task_Primitives.Operations; + package STPOD renames System.Task_Primitives.Operations.DEC; + + AST_Lock : aliased System.Task_Primitives.RTS_Lock; + -- This is a global lock; it is used to execute in mutual exclusion + -- from all other AST tasks. It is only used by Lock_AST and + -- Unlock_AST. + + procedure Lock_AST (Self_ID : ST.Task_ID); + -- Locks out other AST tasks. Preceding a section of code by Lock_AST and + -- following it by Unlock_AST creates a critical region. + + procedure Unlock_AST (Self_ID : ST.Task_ID); + -- Releases lock previously set by call to Lock_AST. + -- All nested locks must be released before other tasks competing for the + -- tasking lock are released. + + -------------- + -- Lock_AST -- + -------------- + + procedure Lock_AST (Self_ID : ST.Task_ID) is + begin + STI.Defer_Abort_Nestable (Self_ID); + STPO.Write_Lock (AST_Lock'Access, Global_Lock => True); + end Lock_AST; + + ---------------- + -- Unlock_AST -- + ---------------- + + procedure Unlock_AST (Self_ID : ST.Task_ID) is + begin + STPO.Unlock (AST_Lock'Access, Global_Lock => True); + STI.Undefer_Abort_Nestable (Self_ID); + end Unlock_AST; + + --------------------------------- + -- AST_Handler Data Structures -- + --------------------------------- + + -- As noted in the private part of the spec of System.Aux_DEC, the + -- AST_Handler type is simply a pointer to a procedure that takes + -- a single 64bit parameter. The following is a local copy + -- of that definition. + + -- We need our own copy because we need to get our hands on this + -- and we cannot see the private part of System.Aux_DEC. We don't + -- want to be a child of Aux_Dec because of complications resulting + -- from the use of pragma Extend_System. We will use unchecked + -- conversions between the two versions of the declarations. + + type AST_Handler is access procedure (Param : Long_Integer); + + -- However, this declaration is somewhat misleading, since the values + -- referenced by AST_Handler values (all produced in this package by + -- calls to Create_AST_Handler) are highly stylized. + + -- The first point is that in VMS/Alpha, procedure pointers do not in + -- fact point to code, but rather to a 48-byte procedure descriptor. + -- So a value of type AST_Handler is in fact a pointer to one of these + -- 48-byte descriptors. + + type Descriptor_Type is new SSE.Storage_Array (1 .. 48); + for Descriptor_Type'Alignment use Standard'Maximum_Alignment; + pragma Warnings (Off, Descriptor_Type); + -- Suppress harmless warnings about alignment. + -- Should explain why this warning is harmless ??? + + type Descriptor_Ref is access all Descriptor_Type; + + -- Normally, there is only one such descriptor for a given procedure, but + -- it works fine to make a copy of the single allocated descriptor, and + -- use the copy itself, and we take advantage of this in the design here. + -- The idea is that AST_Handler values will all point to a record with the + -- following structure: + + -- Note: When we say it works fine, there is one delicate point, which + -- is that the code for the AST procedure itself requires the original + -- descriptor address. We handle this by saving the orignal descriptor + -- address in this structure and restoring in Process_AST. + + type AST_Handler_Data is record + Descriptor : Descriptor_Type; + Original_Descriptor_Ref : Descriptor_Ref; + Taskid : ATID.Task_Id; + Entryno : Natural; + end record; + + type AST_Handler_Data_Ref is access all AST_Handler_Data; + + function To_AST_Handler is new Ada.Unchecked_Conversion + (AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler); + + -- Each time Create_AST_Handler is called, a new value of this record + -- type is created, containing a copy of the procedure descriptor for + -- the routine used to handle all AST's (Process_AST), and the Task_Id + -- and entry number parameters identifying the task entry involved. + + -- The AST_Handler value returned is a pointer to this record. Since + -- the record starts with the procedure descriptor, it can be used + -- by the system in the normal way to call the procedure. But now + -- when the procedure gets control, it can determine the address of + -- the procedure descriptor used to call it (since the ABI specifies + -- that this is left sitting in register r27 on entry), and then use + -- that address to retrieve the Task_Id and entry number so that it + -- knows on which entry to queue the AST request. + + -- The next issue is where are these records placed. Since we intend + -- to pass pointers to these records to asynchronous system service + -- routines, they have to be on the heap, which means we have to worry + -- about when to allocate them and deallocate them. + + -- We solve this problem by introducing a task attribute that points to + -- a vector, indexed by the entry number, of AST_Handler_Data records + -- for a given task. The pointer itself is a controlled object allowing + -- us to write a finalization routine that frees the referenced vector. + + -- An entry in this vector is either initialized (Entryno non-zero) and + -- can be used for any subsequent reference to the same entry, or it is + -- unused, marked by the Entryno value being zero. + + type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data; + type AST_Handler_Vector_Ref is access all AST_Handler_Vector; + +-- type AST_Vector_Ptr is new Ada.Finalization.Controlled with record +-- removed due to problem with controlled attribute, consequence is that +-- we have a memory leak if a task that has AST attribute entries is +-- terminated. ??? + + type AST_Vector_Ptr is record + Vector : AST_Handler_Vector_Ref; + end record; + + AST_Vector_Init : AST_Vector_Ptr; + -- Initial value, treated as constant, Vector will be null. + + package AST_Attribute is new Ada.Task_Attributes + (Attribute => AST_Vector_Ptr, + Initial_Value => AST_Vector_Init); + + use AST_Attribute; + + ----------------------- + -- AST Service Queue -- + ----------------------- + + -- The following global data structures are used to queue pending + -- AST requests. When an AST is signalled, the AST service routine + -- Process_AST is called, and it makes an entry in this structure. + + type AST_Instance is record + Taskid : ATID.Task_Id; + Entryno : Natural; + Param : Long_Integer; + end record; + -- The Taskid and Entryno indicate the entry on which this AST is to + -- be queued, and Param is the parameter provided from the AST itself. + + AST_Service_Queue_Size : constant := 256; + AST_Service_Queue_Limit : constant := 250; + type AST_Service_Queue_Index is mod AST_Service_Queue_Size; + -- Index used to refer to entries in the circular buffer which holds + -- active AST_Instance values. The upper bound reflects the maximum + -- number of AST instances that can be stored in the buffer. Since + -- these entries are immediately serviced by the high priority server + -- task that does the actual entry queuing, it is very unusual to have + -- any significant number of entries simulaneously queued. + + AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance; + pragma Volatile_Components (AST_Service_Queue); + -- The circular buffer used to store active AST requests. + + AST_Service_Queue_Put : AST_Service_Queue_Index := 0; + AST_Service_Queue_Get : AST_Service_Queue_Index := 0; + pragma Atomic (AST_Service_Queue_Put); + pragma Atomic (AST_Service_Queue_Get); + -- These two variables point to the next slots in the AST_Service_Queue + -- to be used for putting a new entry in and taking an entry out. This + -- is a circular buffer, so these pointers wrap around. If the two values + -- are equal the buffer is currently empty. The pointers are atomic to + -- ensure proper synchronization between the single producer (namely the + -- Process_AST procedure), and the single consumer (the AST_Service_Task). + + -------------------------------- + -- AST Server Task Structures -- + -------------------------------- + + -- The basic approach is that when an AST comes in, a call is made to + -- the Process_AST procedure. It queues the request in the service queue + -- and then wakes up an AST server task to perform the actual call to the + -- required entry. We use this intermediate server task, since the AST + -- procedure itself cannot wait to return, and we need some caller for + -- the rendezvous so that we can use the normal rendezvous mechanism. + + -- It would work to have only one AST server task, but then we would lose + -- all overlap in AST processing, and furthermore, we could get priority + -- inversion effects resulting in starvation of AST requests. + + -- We therefore maintain a small pool of AST server tasks. We adjust + -- the size of the pool dynamically to reflect traffic, so that we have + -- a sufficient number of server tasks to avoid starvation. + + Max_AST_Servers : constant Natural := 16; + -- Maximum number of AST server tasks that can be allocated + + Num_AST_Servers : Natural := 0; + -- Number of AST server tasks currently active + + Num_Waiting_AST_Servers : Natural := 0; + -- This is the number of AST server tasks that are either waiting for + -- work, or just about to go to sleep and wait for work. + + Is_Waiting : array (1 .. Max_AST_Servers) of Boolean := (others => False); + -- An array of flags showing which AST server tasks are currently waiting + + AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_ID; + -- Task Id's of allocated AST server tasks + + task type AST_Server_Task (Num : Natural) is + pragma Priority (Priority'Last); + end AST_Server_Task; + -- Declaration for AST server task. This task has no entries, it is + -- controlled by sleep and wakeup calls at the task primitives level. + + type AST_Server_Task_Ptr is access all AST_Server_Task; + -- Type used to allocate server tasks + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Allocate_New_AST_Server; + -- Allocate an additional AST server task + + procedure Process_AST (Param : Long_Integer); + -- This is the central routine for processing all AST's, it is referenced + -- as the code address of all created AST_Handler values. See detailed + -- description in body to understand how it works to have a single such + -- procedure for all AST's even though it does not get any indication of + -- the entry involved passed as an explicit parameter. The single explicit + -- parameter Param is the parameter passed by the system with the AST. + + ----------------------------- + -- Allocate_New_AST_Server -- + ----------------------------- + + procedure Allocate_New_AST_Server is + Dummy : AST_Server_Task_Ptr; + pragma Unreferenced (Dummy); + + begin + if Num_AST_Servers = Max_AST_Servers then + return; + + else + -- Note: it is safe to increment Num_AST_Servers immediately, since + -- no one will try to activate this task until it indicates that it + -- is sleeping by setting its entry in Is_Waiting to True. + + Num_AST_Servers := Num_AST_Servers + 1; + Dummy := new AST_Server_Task (Num_AST_Servers); + end if; + end Allocate_New_AST_Server; + + --------------------- + -- AST_Server_Task -- + --------------------- + + task body AST_Server_Task is + Taskid : ATID.Task_Id; + Entryno : Natural; + Param : aliased Long_Integer; + Self_Id : constant ST.Task_ID := ST.Self; + + pragma Volatile (Param); + + begin + -- By making this task independent of master, when the environment + -- task is finalizing, the AST_Server_Task will be notified that it + -- should terminate. + + STU.Make_Independent; + + -- Record our task Id for access by Process_AST + + AST_Task_Ids (Num) := Self_Id; + + -- Note: this entire task operates with the main task lock set, except + -- when it is sleeping waiting for work, or busy doing a rendezvous + -- with an AST server. This lock protects the data structures that + -- are shared by multiple instances of the server task. + + Lock_AST (Self_Id); + + -- This is the main infinite loop of the task. We go to sleep and + -- wait to be woken up by Process_AST when there is some work to do. + + loop + Num_Waiting_AST_Servers := Num_Waiting_AST_Servers + 1; + + Unlock_AST (Self_Id); + + STI.Defer_Abort (Self_Id); + + if SP.Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + + Is_Waiting (Num) := True; + + Self_Id.Common.State := ST.AST_Server_Sleep; + STPO.Sleep (Self_Id, ST.AST_Server_Sleep); + Self_Id.Common.State := ST.Runnable; + + STPO.Unlock (Self_Id); + + if SP.Single_Lock then + STPO.Unlock_RTS; + end if; + + -- If the process is finalizing, Undefer_Abort will simply end + -- this task. + + STI.Undefer_Abort (Self_Id); + + -- We are awake, there is something to do! + + Lock_AST (Self_Id); + Num_Waiting_AST_Servers := Num_Waiting_AST_Servers - 1; + + -- Loop here to service outstanding requests. We are always + -- locked on entry to this loop. + + while AST_Service_Queue_Get /= AST_Service_Queue_Put loop + Taskid := AST_Service_Queue (AST_Service_Queue_Get).Taskid; + Entryno := AST_Service_Queue (AST_Service_Queue_Get).Entryno; + Param := AST_Service_Queue (AST_Service_Queue_Get).Param; + + AST_Service_Queue_Get := AST_Service_Queue_Get + 1; + + -- This is a manual expansion of the normal call simple code + + declare + type AA is access all Long_Integer; + P : AA := Param'Unrestricted_Access; + + function To_ST_Task_Id is new Ada.Unchecked_Conversion + (ATID.Task_Id, ST.Task_ID); + + begin + Unlock_AST (Self_Id); + STR.Call_Simple + (Acceptor => To_ST_Task_Id (Taskid), + E => ST.Task_Entry_Index (Entryno), + Uninterpreted_Data => P'Address); + + exception + when E : others => + System.IO.Put_Line ("%Debugging event"); + System.IO.Put_Line (Exception_Name (E) & + " raised when trying to deliver an AST."); + + if Exception_Message (E)'Length /= 0 then + System.IO.Put_Line (Exception_Message (E)); + end if; + + System.IO.Put_Line ("Task type is " & "Receiver_Type"); + System.IO.Put_Line ("Task id is " & ATID.Image (Taskid)); + end; + + Lock_AST (Self_Id); + end loop; + end loop; + end AST_Server_Task; + + ------------------------ + -- Create_AST_Handler -- + ------------------------ + + function Create_AST_Handler + (Taskid : ATID.Task_Id; + Entryno : Natural) return System.Aux_DEC.AST_Handler + is + Attr_Ref : Attribute_Handle; + + Process_AST_Ptr : constant AST_Handler := Process_AST'Access; + -- Reference to standard procedure descriptor for Process_AST + + function To_Descriptor_Ref is new Ada.Unchecked_Conversion + (AST_Handler, Descriptor_Ref); + + Original_Descriptor_Ref : constant Descriptor_Ref := + To_Descriptor_Ref (Process_AST_Ptr); + + begin + if ATID.Is_Terminated (Taskid) then + raise Program_Error; + end if; + + Attr_Ref := Reference (Taskid); + + -- Allocate another server if supply is getting low + + if Num_Waiting_AST_Servers < 2 then + Allocate_New_AST_Server; + end if; + + -- No point in creating more if we have zillions waiting to + -- be serviced. + + while AST_Service_Queue_Put - AST_Service_Queue_Get + > AST_Service_Queue_Limit + loop + delay 0.01; + end loop; + + -- If no AST vector allocated, or the one we have is too short, then + -- allocate one of right size and initialize all entries except the + -- one we will use to unused. Note that the assignment automatically + -- frees the old allocated table if there is one. + + if Attr_Ref.Vector = null + or else Attr_Ref.Vector'Length < Entryno + then + Attr_Ref.Vector := new AST_Handler_Vector (1 .. Entryno); + + for E in 1 .. Entryno loop + Attr_Ref.Vector (E).Descriptor := + Original_Descriptor_Ref.all; + Attr_Ref.Vector (E).Original_Descriptor_Ref := + Original_Descriptor_Ref; + Attr_Ref.Vector (E).Taskid := Taskid; + Attr_Ref.Vector (E).Entryno := E; + end loop; + end if; + + return To_AST_Handler (Attr_Ref.Vector (Entryno)'Unrestricted_Access); + end Create_AST_Handler; + + ---------------------------- + -- Expand_AST_Packet_Pool -- + ---------------------------- + + procedure Expand_AST_Packet_Pool + (Requested_Packets : in Natural; + Actual_Number : out Natural; + Total_Number : out Natural) + is + pragma Unreferenced (Requested_Packets); + begin + -- The AST implementation of GNAT does not permit dynamic expansion + -- of the pool, so we simply add no entries and return the total. If + -- it is necessary to expand the allocation, then this package body + -- must be recompiled with a larger value for AST_Service_Queue_Size. + + Actual_Number := 0; + Total_Number := AST_Service_Queue_Size; + end Expand_AST_Packet_Pool; + + ----------------- + -- Process_AST -- + ----------------- + + procedure Process_AST (Param : Long_Integer) is + + Handler_Data_Ptr : AST_Handler_Data_Ref; + -- This variable is set to the address of the descriptor through + -- which Process_AST is called. Since the descriptor is part of + -- an AST_Handler value, this is also the address of this value, + -- from which we can obtain the task and entry number information. + + function To_Address is new Ada.Unchecked_Conversion + (ST.Task_ID, System.Address); + + begin + System.Machine_Code.Asm + (Template => "addl $27,0,%0", + Outputs => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr), + Volatile => True); + + System.Machine_Code.Asm + (Template => "ldl $27,%0", + Inputs => Descriptor_Ref'Asm_Input + ("m", Handler_Data_Ptr.Original_Descriptor_Ref), + Volatile => True); + + AST_Service_Queue (AST_Service_Queue_Put) := AST_Instance' + (Taskid => Handler_Data_Ptr.Taskid, + Entryno => Handler_Data_Ptr.Entryno, + Param => Param); + + -- OpenVMS Programming Concepts manual, chapter 8.2.3: + -- "Implicit synchronization can be achieved for data that is shared + -- for write by using only AST routines to write the data, since only + -- one AST can be running at any one time." + + -- This subprogram runs at AST level so is guaranteed to be + -- called sequentially at a given access level. + + AST_Service_Queue_Put := AST_Service_Queue_Put + 1; + + -- Need to wake up processing task. If there is no waiting server + -- then we have temporarily run out, but things should still be + -- OK, since one of the active ones will eventually pick up the + -- service request queued in the AST_Service_Queue. + + for J in 1 .. Num_AST_Servers loop + if Is_Waiting (J) then + Is_Waiting (J) := False; + + -- Sleeps are handled by ASTs on VMS, so don't call Wakeup. + + STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J))); + exit; + end if; + end loop; + end Process_AST; + +begin + STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level); +end System.AST_Handling; diff --git a/gcc/ada/s-gloloc-mingw.adb b/gcc/ada/s-gloloc-mingw.adb new file mode 100644 index 00000000000..2b775b239db --- /dev/null +++ b/gcc/ada/s-gloloc-mingw.adb @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . G L O B A L _ L O C K S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This implementation is specific to NT. + +with GNAT.Task_Lock; + +with Interfaces.C.Strings; +with System.OS_Interface; + +package body System.Global_Locks is + + package TSL renames GNAT.Task_Lock; + package OSI renames System.OS_Interface; + package ICS renames Interfaces.C.Strings; + + subtype Lock_File_Entry is OSI.HANDLE; + + Last_Lock : Lock_Type := Null_Lock; + Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry; + + ----------------- + -- Create_Lock -- + ----------------- + + procedure Create_Lock + (Lock : out Lock_Type; + Name : in String) + is + L : Lock_Type; + + begin + TSL.Lock; + Last_Lock := Last_Lock + 1; + L := Last_Lock; + TSL.Unlock; + + if L > Lock_Table'Last then + raise Lock_Error; + end if; + + Lock_Table (L) := + OSI.CreateMutex (null, OSI.BOOL (False), ICS.New_String (Name)); + Lock := L; + end Create_Lock; + + ------------------ + -- Acquire_Lock -- + ------------------ + + procedure Acquire_Lock + (Lock : in out Lock_Type) + is + use type OSI.DWORD; + + Res : OSI.DWORD; + begin + Res := OSI.WaitForSingleObject (Lock_Table (Lock), OSI.Wait_Infinite); + + if Res = OSI.WAIT_FAILED then + raise Lock_Error; + end if; + end Acquire_Lock; + + ------------------ + -- Release_Lock -- + ------------------ + + procedure Release_Lock + (Lock : in out Lock_Type) + is + use type OSI.BOOL; + + Res : OSI.BOOL; + begin + Res := OSI.ReleaseMutex (Lock_Table (Lock)); + + if Res = OSI.False then + raise Lock_Error; + end if; + end Release_Lock; + +end System.Global_Locks; diff --git a/gcc/ada/s-inmaop-dummy.adb b/gcc/ada/s-inmaop-dummy.adb new file mode 100644 index 00000000000..f99a104f671 --- /dev/null +++ b/gcc/ada/s-inmaop-dummy.adb @@ -0,0 +1,194 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2001 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a NO tasking version of this package. + +package body System.Interrupt_Management.Operations is + + -- Turn off warnings since many unused formals + + pragma Warnings (Off); + + ---------------------------- + -- Thread_Block_Interrupt -- + ---------------------------- + + procedure Thread_Block_Interrupt + (Interrupt : Interrupt_ID) + is + begin + null; + end Thread_Block_Interrupt; + + ------------------------------ + -- Thread_Unblock_Interrupt -- + ------------------------------ + + procedure Thread_Unblock_Interrupt + (Interrupt : Interrupt_ID) + is + begin + null; + end Thread_Unblock_Interrupt; + + ------------------------ + -- Set_Interrupt_Mask -- + ------------------------ + + procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is + begin + null; + end Set_Interrupt_Mask; + + procedure Set_Interrupt_Mask + (Mask : access Interrupt_Mask; + OMask : access Interrupt_Mask) is + begin + null; + end Set_Interrupt_Mask; + + ------------------------ + -- Get_Interrupt_Mask -- + ------------------------ + + procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is + begin + null; + end Get_Interrupt_Mask; + + -------------------- + -- Interrupt_Wait -- + -------------------- + + function Interrupt_Wait + (Mask : access Interrupt_Mask) + return Interrupt_ID + is + begin + return 0; + end Interrupt_Wait; + + ---------------------------- + -- Install_Default_Action -- + ---------------------------- + + procedure Install_Default_Action (Interrupt : Interrupt_ID) is + begin + null; + end Install_Default_Action; + + --------------------------- + -- Install_Ignore_Action -- + --------------------------- + + procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is + begin + null; + end Install_Ignore_Action; + + ------------------------- + -- Fill_Interrupt_Mask -- + ------------------------- + + procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is + begin + null; + end Fill_Interrupt_Mask; + + -------------------------- + -- Empty_Interrupt_Mask -- + -------------------------- + + procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is + begin + null; + end Empty_Interrupt_Mask; + + ----------------------- + -- Add_To_Sigal_Mask -- + ----------------------- + + procedure Add_To_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) + is + begin + null; + end Add_To_Interrupt_Mask; + + -------------------------------- + -- Delete_From_Interrupt_Mask -- + -------------------------------- + + procedure Delete_From_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) + is + begin + null; + end Delete_From_Interrupt_Mask; + + --------------- + -- Is_Member -- + --------------- + + function Is_Member + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) return Boolean + is + begin + return False; + end Is_Member; + + ------------------------- + -- Copy_Interrupt_Mask -- + ------------------------- + + procedure Copy_Interrupt_Mask + (X : out Interrupt_Mask; + Y : Interrupt_Mask) + is + begin + X := Y; + end Copy_Interrupt_Mask; + + ------------------------- + -- Interrupt_Self_Process -- + ------------------------- + + procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is + begin + null; + end Interrupt_Self_Process; + +end System.Interrupt_Management.Operations; diff --git a/gcc/ada/s-inmaop-posix.adb b/gcc/ada/s-inmaop-posix.adb new file mode 100644 index 00000000000..8fe6b3a89bd --- /dev/null +++ b/gcc/ada/s-inmaop-posix.adb @@ -0,0 +1,359 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-inmaop-vms.adb b/gcc/ada/s-inmaop-vms.adb new file mode 100644 index 00000000000..2cbfd0eb715 --- /dev/null +++ b/gcc/ada/s-inmaop-vms.adb @@ -0,0 +1,298 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T . -- +-- O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 a OpenVMS/Alpha version of this package. + +with System.OS_Interface; +-- used for various type, constant, and operations + +with System.Aux_DEC; +-- used for Short_Address + +with System.Parameters; + +with System.Tasking; + +with System.Tasking.Initialization; + +with System.Task_Primitives.Operations; + +with System.Task_Primitives.Operations.DEC; + +with Unchecked_Conversion; + +package body System.Interrupt_Management.Operations is + + use System.OS_Interface; + use System.Parameters; + use System.Tasking; + use type unsigned_short; + + function To_Address is new Unchecked_Conversion (Task_ID, System.Address); + package POP renames System.Task_Primitives.Operations; + + ---------------------------- + -- Thread_Block_Interrupt -- + ---------------------------- + + procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID) is + pragma Warnings (Off, Interrupt); + begin + null; + end Thread_Block_Interrupt; + + ------------------------------ + -- Thread_Unblock_Interrupt -- + ------------------------------ + + procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID) is + pragma Warnings (Off, Interrupt); + begin + null; + end Thread_Unblock_Interrupt; + + ------------------------ + -- Set_Interrupt_Mask -- + ------------------------ + + procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is + pragma Warnings (Off, Mask); + begin + null; + end Set_Interrupt_Mask; + + procedure Set_Interrupt_Mask + (Mask : access Interrupt_Mask; + OMask : access Interrupt_Mask) + is + pragma Warnings (Off, Mask); + pragma Warnings (Off, OMask); + begin + null; + end Set_Interrupt_Mask; + + ------------------------ + -- Get_Interrupt_Mask -- + ------------------------ + + procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is + pragma Warnings (Off, Mask); + begin + null; + end Get_Interrupt_Mask; + + -------------------- + -- Interrupt_Wait -- + -------------------- + + function To_unsigned_long is new + Unchecked_Conversion (System.Aux_DEC.Short_Address, unsigned_long); + + function Interrupt_Wait (Mask : access Interrupt_Mask) + return Interrupt_ID + is + Self_ID : constant Task_ID := Self; + Iosb : IO_Status_Block_Type := (0, 0, 0); + Status : Cond_Value_Type; + + begin + + -- A QIO read is registered. The system call returns immediately + -- after scheduling an AST to be fired when the operation + -- completes. + + Sys_QIO + (Status => Status, + Chan => Rcv_Interrupt_Chan, + Func => IO_READVBLK, + Iosb => Iosb, + Astadr => + POP.DEC.Interrupt_AST_Handler'Access, + Astprm => To_Address (Self_ID), + P1 => To_unsigned_long (Interrupt_Mailbox'Address), + P2 => Interrupt_ID'Size / 8); + + pragma Assert ((Status and 1) = 1); + + loop + + -- Wait to be woken up. Could be that the AST has fired, + -- in which case the Iosb.Status variable will be non-zero, + -- or maybe the wait is being aborted. + + POP.Sleep + (Self_ID, + System.Tasking.Interrupt_Server_Blocked_On_Event_Flag); + + if Iosb.Status /= 0 then + if (Iosb.Status and 1) = 1 + and then Mask (Signal (Interrupt_Mailbox)) + then + return Interrupt_Mailbox; + else + return 0; + end if; + else + POP.Unlock (Self_ID); + + if Single_Lock then + POP.Unlock_RTS; + end if; + + System.Tasking.Initialization.Undefer_Abort (Self_ID); + System.Tasking.Initialization.Defer_Abort (Self_ID); + + if Single_Lock then + POP.Lock_RTS; + end if; + + POP.Write_Lock (Self_ID); + end if; + end loop; + end Interrupt_Wait; + + ---------------------------- + -- Install_Default_Action -- + ---------------------------- + + procedure Install_Default_Action (Interrupt : Interrupt_ID) is + pragma Warnings (Off, Interrupt); + begin + null; + end Install_Default_Action; + + --------------------------- + -- Install_Ignore_Action -- + --------------------------- + + procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is + pragma Warnings (Off, Interrupt); + begin + null; + end Install_Ignore_Action; + + ------------------------- + -- Fill_Interrupt_Mask -- + ------------------------- + + procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is + begin + Mask.all := (others => True); + end Fill_Interrupt_Mask; + + -------------------------- + -- Empty_Interrupt_Mask -- + -------------------------- + + procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is + begin + Mask.all := (others => False); + end Empty_Interrupt_Mask; + + --------------------------- + -- Add_To_Interrupt_Mask -- + --------------------------- + + procedure Add_To_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) + is + begin + Mask (Signal (Interrupt)) := True; + end Add_To_Interrupt_Mask; + + -------------------------------- + -- Delete_From_Interrupt_Mask -- + -------------------------------- + + procedure Delete_From_Interrupt_Mask + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) + is + begin + Mask (Signal (Interrupt)) := False; + end Delete_From_Interrupt_Mask; + + --------------- + -- Is_Member -- + --------------- + + function Is_Member + (Mask : access Interrupt_Mask; + Interrupt : Interrupt_ID) return Boolean + is + begin + return Mask (Signal (Interrupt)); + end Is_Member; + + ------------------------- + -- Copy_Interrupt_Mask -- + ------------------------- + + procedure Copy_Interrupt_Mask + (X : out Interrupt_Mask; + Y : Interrupt_Mask) + is + begin + X := Y; + end Copy_Interrupt_Mask; + + ------------------------- + -- Interrupt_Self_Process -- + ------------------------- + + procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is + Status : Cond_Value_Type; + begin + Sys_QIO + (Status => Status, + Chan => Snd_Interrupt_Chan, + Func => IO_WRITEVBLK, + P1 => To_unsigned_long (Interrupt'Address), + P2 => Interrupt_ID'Size / 8); + + pragma Assert ((Status and 1) = 1); + end Interrupt_Self_Process; + +begin + Environment_Mask := (others => False); + All_Tasks_Mask := (others => True); + + for J in Interrupt_ID loop + if Keep_Unmasked (J) then + Environment_Mask (Signal (J)) := True; + All_Tasks_Mask (Signal (J)) := False; + end if; + end loop; +end System.Interrupt_Management.Operations; diff --git a/gcc/ada/s-interr-dummy.adb b/gcc/ada/s-interr-dummy.adb new file mode 100644 index 00000000000..7dbe33f26a7 --- /dev/null +++ b/gcc/ada/s-interr-dummy.adb @@ -0,0 +1,307 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T S -- +-- -- +-- 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 an OS/2 version of this package. + +-- This version is a stub, for systems that +-- do not support interrupts (or signals). + +with Ada.Exceptions; + +package body System.Interrupts is + + pragma Warnings (Off); -- kill warnings on unreferenced formals + + use System.Tasking; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Unimplemented; + -- This procedure raises a Program_Error with an appropriate message + -- indicating that an unimplemented feature has been used. + + -------------------- + -- Attach_Handler -- + -------------------- + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) + is + begin + Unimplemented; + end Attach_Handler; + + ----------------------------- + -- Bind_Interrupt_To_Entry -- + ----------------------------- + + procedure Bind_Interrupt_To_Entry + (T : Task_ID; + E : Task_Entry_Index; + Int_Ref : System.Address) + is + begin + Unimplemented; + end Bind_Interrupt_To_Entry; + + --------------------- + -- Block_Interrupt -- + --------------------- + + procedure Block_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented; + end Block_Interrupt; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler + (Interrupt : Interrupt_ID) + return Parameterless_Handler + is + begin + Unimplemented; + return null; + end Current_Handler; + + -------------------- + -- Detach_Handler -- + -------------------- + + procedure Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean := False) + is + begin + Unimplemented; + end Detach_Handler; + + ------------------------------ + -- Detach_Interrupt_Entries -- + ------------------------------ + + procedure Detach_Interrupt_Entries (T : Task_ID) is + begin + Unimplemented; + end Detach_Interrupt_Entries; + + ---------------------- + -- Exchange_Handler -- + ---------------------- + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) + is + begin + Old_Handler := null; + Unimplemented; + end Exchange_Handler; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Static_Interrupt_Protection) is + begin + Unimplemented; + end Finalize; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + function Has_Interrupt_Or_Attach_Handler + (Object : access Dynamic_Interrupt_Protection) + return Boolean + is + pragma Warnings (Off, Object); + + begin + Unimplemented; + return True; + end Has_Interrupt_Or_Attach_Handler; + + function Has_Interrupt_Or_Attach_Handler + (Object : access Static_Interrupt_Protection) + return Boolean + is + pragma Warnings (Off, Object); + + begin + Unimplemented; + return True; + end Has_Interrupt_Or_Attach_Handler; + + ---------------------- + -- Ignore_Interrupt -- + ---------------------- + + procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented; + end Ignore_Interrupt; + + ---------------------- + -- Install_Handlers -- + ---------------------- + + procedure Install_Handlers + (Object : access Static_Interrupt_Protection; + New_Handlers : New_Handler_Array) + is + begin + Unimplemented; + end Install_Handlers; + + ---------------- + -- Is_Blocked -- + ---------------- + + function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is + begin + Unimplemented; + return True; + end Is_Blocked; + + ----------------------- + -- Is_Entry_Attached -- + ----------------------- + + function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + Unimplemented; + return True; + end Is_Entry_Attached; + + ------------------------- + -- Is_Handler_Attached -- + ------------------------- + + function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + Unimplemented; + return True; + end Is_Handler_Attached; + + ---------------- + -- Is_Ignored -- + ---------------- + + function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is + begin + Unimplemented; + return True; + end Is_Ignored; + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is + begin + Unimplemented; + return True; + end Is_Reserved; + + --------------- + -- Reference -- + --------------- + + function Reference (Interrupt : Interrupt_ID) return System.Address is + begin + Unimplemented; + return Interrupt'Address; + end Reference; + + -------------------------------- + -- Register_Interrupt_Handler -- + -------------------------------- + + procedure Register_Interrupt_Handler + (Handler_Addr : System.Address) + is + begin + Unimplemented; + end Register_Interrupt_Handler; + + ----------------------- + -- Unblock_Interrupt -- + ----------------------- + + procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented; + end Unblock_Interrupt; + + ------------------ + -- Unblocked_By -- + ------------------ + + function Unblocked_By (Interrupt : Interrupt_ID) + return System.Tasking.Task_ID is + begin + Unimplemented; + return null; + end Unblocked_By; + + ------------------------ + -- Unignore_Interrupt -- + ------------------------ + + procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented; + end Unignore_Interrupt; + + ------------------- + -- Unimplemented; -- + ------------------- + + procedure Unimplemented is + begin + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, "interrupts/signals not implemented"); + raise Program_Error; + end Unimplemented; + +end System.Interrupts; diff --git a/gcc/ada/s-interr-sigaction.adb b/gcc/ada/s-interr-sigaction.adb new file mode 100644 index 00000000000..4ee53e00b09 --- /dev/null +++ b/gcc/ada/s-interr-sigaction.adb @@ -0,0 +1,682 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2004 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 the IRIX & NT version of this package. + +with Ada.Task_Identification; +-- used for Task_Id + +with Ada.Exceptions; +-- used for Raise_Exception + +with System.OS_Interface; +-- used for intr_attach + +with System.Storage_Elements; +-- used for To_Address +-- To_Integer + +with System.Task_Primitives.Operations; +-- used for Self +-- Sleep +-- Wakeup +-- Write_Lock +-- Unlock + +with System.Tasking.Utilities; +-- used for Make_Independent + +with System.Tasking.Rendezvous; +-- used for Call_Simple + +with System.Tasking.Initialization; +-- used for Defer_Abort +-- Undefer_Abort + +with System.Interrupt_Management; + +with System.Parameters; +-- used for Single_Lock + +with Interfaces.C; +-- used for int + +with Unchecked_Conversion; + +package body System.Interrupts is + + use Parameters; + use Tasking; + use Ada.Exceptions; + use System.OS_Interface; + use Interfaces.C; + + package STPO renames System.Task_Primitives.Operations; + package IMNG renames System.Interrupt_Management; + + subtype int is Interfaces.C.int; + + function To_System is new Unchecked_Conversion + (Ada.Task_Identification.Task_Id, Task_ID); + + type Handler_Kind is (Unknown, Task_Entry, Protected_Procedure); + + type Handler_Desc is record + Kind : Handler_Kind := Unknown; + T : Task_ID; + E : Task_Entry_Index; + H : Parameterless_Handler; + Static : Boolean := False; + end record; + + task type Server_Task (Interrupt : Interrupt_ID) is + pragma Interrupt_Priority (System.Interrupt_Priority'Last); + end Server_Task; + + type Server_Task_Access is access Server_Task; + + Attached_Interrupts : array (Interrupt_ID) of Boolean; + Handlers : array (Interrupt_ID) of Task_ID; + Descriptors : array (Interrupt_ID) of Handler_Desc; + Interrupt_Count : array (Interrupt_ID) of Integer := (others => 0); + + pragma Volatile_Components (Interrupt_Count); + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean); + -- This internal procedure is needed to finalize protected objects + -- that contain interrupt handlers. + + procedure Signal_Handler (Sig : Interrupt_ID); + -- This procedure is used to handle all the signals. + + -- Type and Head, Tail of the list containing Registered Interrupt + -- Handlers. These definitions are used to register the handlers + -- specified by the pragma Interrupt_Handler. + + -- + -- Handler Registration: + -- + + type Registered_Handler; + type R_Link is access all Registered_Handler; + + type Registered_Handler is record + H : System.Address := System.Null_Address; + Next : R_Link := null; + end record; + + Registered_Handlers : R_Link := null; + + function Is_Registered (Handler : Parameterless_Handler) return Boolean; + -- See if the Handler has been "pragma"ed using Interrupt_Handler. + -- Always consider a null handler as registered. + + type Handler_Ptr is access procedure (Sig : Interrupt_ID); + + function TISR is new Unchecked_Conversion (Handler_Ptr, isr_address); + + procedure Signal_Handler (Sig : Interrupt_ID) is + Handler : Task_ID renames Handlers (Sig); + begin + if Intr_Attach_Reset and then + intr_attach (int (Sig), TISR (Signal_Handler'Access)) = FUNC_ERR + then + raise Program_Error; + end if; + + if Handler /= null then + Interrupt_Count (Sig) := Interrupt_Count (Sig) + 1; + STPO.Wakeup (Handler, Interrupt_Server_Idle_Sleep); + end if; + end Signal_Handler; + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is + begin + return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt)); + end Is_Reserved; + + ----------------------- + -- Is_Entry_Attached -- + ----------------------- + + function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + return Descriptors (Interrupt).T /= Null_Task; + end Is_Entry_Attached; + + ------------------------- + -- Is_Handler_Attached -- + ------------------------- + + function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + return Descriptors (Interrupt).Kind /= Unknown; + end Is_Handler_Attached; + + ---------------- + -- Is_Ignored -- + ---------------- + + function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is + begin + raise Program_Error; + return False; + end Is_Ignored; + + ------------------ + -- Unblocked_By -- + ------------------ + + function Unblocked_By (Interrupt : Interrupt_ID) return Task_ID is + begin + raise Program_Error; + return Null_Task; + end Unblocked_By; + + ---------------------- + -- Ignore_Interrupt -- + ---------------------- + + procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is + begin + raise Program_Error; + end Ignore_Interrupt; + + ------------------------ + -- Unignore_Interrupt -- + ------------------------ + + procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is + begin + raise Program_Error; + end Unignore_Interrupt; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + function Has_Interrupt_Or_Attach_Handler + (Object : access Dynamic_Interrupt_Protection) return Boolean + is + pragma Unreferenced (Object); + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + ---------------- + -- Finalize -- + ---------------- + + procedure Finalize (Object : in out Static_Interrupt_Protection) is + begin + -- ??? loop to be executed only when we're not doing library level + -- finalization, since in this case all interrupt tasks are gone. + + for N in reverse Object.Previous_Handlers'Range loop + Attach_Handler + (New_Handler => Object.Previous_Handlers (N).Handler, + Interrupt => Object.Previous_Handlers (N).Interrupt, + Static => Object.Previous_Handlers (N).Static, + Restoration => True); + end loop; + + Tasking.Protected_Objects.Entries.Finalize + (Tasking.Protected_Objects.Entries.Protection_Entries (Object)); + end Finalize; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + function Has_Interrupt_Or_Attach_Handler + (Object : access Static_Interrupt_Protection) return Boolean + is + pragma Unreferenced (Object); + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + ---------------------- + -- Install_Handlers -- + ---------------------- + + procedure Install_Handlers + (Object : access Static_Interrupt_Protection; + New_Handlers : New_Handler_Array) + is + begin + for N in New_Handlers'Range loop + + -- We need a lock around this ??? + + Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt; + Object.Previous_Handlers (N).Static := Descriptors + (New_Handlers (N).Interrupt).Static; + + -- We call Exchange_Handler and not directly Interrupt_Manager. + -- Exchange_Handler so we get the Is_Reserved check. + + Exchange_Handler + (Old_Handler => Object.Previous_Handlers (N).Handler, + New_Handler => New_Handlers (N).Handler, + Interrupt => New_Handlers (N).Interrupt, + Static => True); + end loop; + end Install_Handlers; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler + (Interrupt : Interrupt_ID) return Parameterless_Handler + is + begin + if Is_Reserved (Interrupt) then + raise Program_Error; + end if; + + if Descriptors (Interrupt).Kind = Protected_Procedure then + return Descriptors (Interrupt).H; + else + return null; + end if; + end Current_Handler; + + -------------------- + -- Attach_Handler -- + -------------------- + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) is + begin + Attach_Handler (New_Handler, Interrupt, Static, False); + end Attach_Handler; + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean) + is + New_Task : Server_Task_Access; + + begin + if Is_Reserved (Interrupt) then + raise Program_Error; + end if; + + if not Restoration and then not Static + + -- Tries to overwrite a static Interrupt Handler with a + -- dynamic Handler + + and then (Descriptors (Interrupt).Static + + -- The new handler is not specified as an + -- Interrupt Handler by a pragma. + + or else not Is_Registered (New_Handler)) + then + Raise_Exception (Program_Error'Identity, + "Trying to overwrite a static Interrupt Handler with a " & + "dynamic Handler"); + end if; + + if Handlers (Interrupt) = null then + New_Task := new Server_Task (Interrupt); + Handlers (Interrupt) := To_System (New_Task.all'Identity); + end if; + + if intr_attach (int (Interrupt), + TISR (Signal_Handler'Access)) = FUNC_ERR + then + raise Program_Error; + end if; + + if New_Handler = null then + + -- The null handler means we are detaching the handler. + + Attached_Interrupts (Interrupt) := False; + Descriptors (Interrupt) := + (Kind => Unknown, T => null, E => 0, H => null, Static => False); + + else + Descriptors (Interrupt).Kind := Protected_Procedure; + Descriptors (Interrupt).H := New_Handler; + Descriptors (Interrupt).Static := Static; + Attached_Interrupts (Interrupt) := True; + end if; + end Attach_Handler; + + ---------------------- + -- Exchange_Handler -- + ---------------------- + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) is + begin + if Is_Reserved (Interrupt) then + raise Program_Error; + end if; + + if Descriptors (Interrupt).Kind = Task_Entry then + + -- In case we have an Interrupt Entry already installed. + -- raise a program error. (propagate it to the caller). + + Raise_Exception (Program_Error'Identity, + "An interrupt is already installed"); + end if; + + Old_Handler := Current_Handler (Interrupt); + Attach_Handler (New_Handler, Interrupt, Static); + end Exchange_Handler; + + -------------------- + -- Detach_Handler -- + -------------------- + + procedure Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean := False) is + begin + if Is_Reserved (Interrupt) then + raise Program_Error; + end if; + + if Descriptors (Interrupt).Kind = Task_Entry then + Raise_Exception (Program_Error'Identity, + "Trying to detach an Interrupt Entry"); + end if; + + if not Static and then Descriptors (Interrupt).Static then + Raise_Exception (Program_Error'Identity, + "Trying to detach a static Interrupt Handler"); + end if; + + Attached_Interrupts (Interrupt) := False; + Descriptors (Interrupt) := + (Kind => Unknown, T => null, E => 0, H => null, Static => False); + + if intr_attach (int (Interrupt), null) = FUNC_ERR then + raise Program_Error; + end if; + end Detach_Handler; + + --------------- + -- Reference -- + --------------- + + function Reference (Interrupt : Interrupt_ID) return System.Address is + Signal : constant System.Address := + System.Storage_Elements.To_Address + (System.Storage_Elements.Integer_Address (Interrupt)); + + begin + if Is_Reserved (Interrupt) then + + -- Only usable Interrupts can be used for binding it to an Entry + + raise Program_Error; + end if; + + return Signal; + end Reference; + + -------------------------------- + -- Register_Interrupt_Handler -- + -------------------------------- + + procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is + begin + Registered_Handlers := + new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers); + end Register_Interrupt_Handler; + + ------------------- + -- Is_Registered -- + ------------------- + + -- See if the Handler has been "pragma"ed using Interrupt_Handler. + -- Always consider a null handler as registered. + + function Is_Registered (Handler : Parameterless_Handler) return Boolean is + Ptr : R_Link := Registered_Handlers; + + type Fat_Ptr is record + Object_Addr : System.Address; + Handler_Addr : System.Address; + end record; + + function To_Fat_Ptr is new Unchecked_Conversion + (Parameterless_Handler, Fat_Ptr); + + Fat : Fat_Ptr; + + begin + if Handler = null then + return True; + end if; + + Fat := To_Fat_Ptr (Handler); + + while Ptr /= null loop + + if Ptr.H = Fat.Handler_Addr then + return True; + end if; + + Ptr := Ptr.Next; + end loop; + + return False; + end Is_Registered; + + ----------------------------- + -- Bind_Interrupt_To_Entry -- + ----------------------------- + + procedure Bind_Interrupt_To_Entry + (T : Task_ID; + E : Task_Entry_Index; + Int_Ref : System.Address) + is + Interrupt : constant Interrupt_ID := + Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); + + New_Task : Server_Task_Access; + + begin + if Is_Reserved (Interrupt) then + raise Program_Error; + end if; + + if Descriptors (Interrupt).Kind /= Unknown then + Raise_Exception (Program_Error'Identity, + "A binding for this interrupt is already present"); + end if; + + if Handlers (Interrupt) = null then + New_Task := new Server_Task (Interrupt); + Handlers (Interrupt) := To_System (New_Task.all'Identity); + end if; + + if intr_attach (int (Interrupt), + TISR (Signal_Handler'Access)) = FUNC_ERR + then + raise Program_Error; + end if; + + Descriptors (Interrupt).Kind := Task_Entry; + Descriptors (Interrupt).T := T; + Descriptors (Interrupt).E := E; + + -- Indicate the attachment of Interrupt Entry in ATCB. + -- This is need so that when an Interrupt Entry task terminates + -- the binding can be cleaned. The call to unbinding must be + -- make by the task before it terminates. + + T.Interrupt_Entry := True; + + Attached_Interrupts (Interrupt) := True; + end Bind_Interrupt_To_Entry; + + ------------------------------ + -- Detach_Interrupt_Entries -- + ------------------------------ + + procedure Detach_Interrupt_Entries (T : Task_ID) is + begin + for I in Interrupt_ID loop + if not Is_Reserved (I) then + if Descriptors (I).Kind = Task_Entry and then + Descriptors (I).T = T then + Attached_Interrupts (I) := False; + Descriptors (I).Kind := Unknown; + + if intr_attach (int (I), null) = FUNC_ERR then + raise Program_Error; + end if; + end if; + end if; + end loop; + + -- Indicate in ATCB that no Interrupt Entries are attached. + + T.Interrupt_Entry := True; + end Detach_Interrupt_Entries; + + --------------------- + -- Block_Interrupt -- + --------------------- + + procedure Block_Interrupt (Interrupt : Interrupt_ID) is + begin + raise Program_Error; + end Block_Interrupt; + + ----------------------- + -- Unblock_Interrupt -- + ----------------------- + + procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is + begin + raise Program_Error; + end Unblock_Interrupt; + + ---------------- + -- Is_Blocked -- + ---------------- + + function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is + begin + raise Program_Error; + return False; + end Is_Blocked; + + task body Server_Task is + Desc : Handler_Desc renames Descriptors (Interrupt); + Self_Id : constant Task_ID := STPO.Self; + Temp : Parameterless_Handler; + + begin + Utilities.Make_Independent; + + loop + while Interrupt_Count (Interrupt) > 0 loop + Interrupt_Count (Interrupt) := Interrupt_Count (Interrupt) - 1; + begin + case Desc.Kind is + when Unknown => + null; + when Task_Entry => + Rendezvous.Call_Simple (Desc.T, Desc.E, Null_Address); + when Protected_Procedure => + Temp := Desc.H; + Temp.all; + end case; + exception + when others => null; + end; + end loop; + + Initialization.Defer_Abort (Self_Id); + + if Single_Lock then + STPO.Lock_RTS; + end if; + + STPO.Write_Lock (Self_Id); + Self_Id.Common.State := Interrupt_Server_Idle_Sleep; + STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep); + Self_Id.Common.State := Runnable; + STPO.Unlock (Self_Id); + + if Single_Lock then + STPO.Unlock_RTS; + end if; + + Initialization.Undefer_Abort (Self_Id); + + -- Undefer abort here to allow a window for this task + -- to be aborted at the time of system shutdown. + + end loop; + end Server_Task; + +end System.Interrupts; diff --git a/gcc/ada/s-interr-vms.adb b/gcc/ada/s-interr-vms.adb new file mode 100644 index 00000000000..f302ead12e3 --- /dev/null +++ b/gcc/ada/s-interr-vms.adb @@ -0,0 +1,1176 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 an OpenVMS/Alpha version of this package. + +-- Invariants: + +-- Once we associate a Server_Task with an interrupt, the task never +-- goes away, and we never remove the association. + +-- There is no more than one interrupt per Server_Task and no more than +-- one Server_Task per interrupt. + +-- Within this package, the lock L is used to protect the various status +-- tables. If there is a Server_Task associated with an interrupt, we use +-- the per-task lock of the Server_Task instead so that we protect the +-- status between Interrupt_Manager and Server_Task. Protection among +-- service requests are done using User Request to Interrupt_Manager +-- rendezvous. + +with Ada.Task_Identification; +-- used for Task_ID type + +with Ada.Exceptions; +-- used for Raise_Exception + +with System.Task_Primitives; +-- used for RTS_Lock +-- Self + +with System.Interrupt_Management; +-- used for Reserve +-- Interrupt_ID +-- Interrupt_Mask +-- Abort_Task_Interrupt + +with System.Interrupt_Management.Operations; +-- used for Thread_Block_Interrupt +-- Thread_Unblock_Interrupt +-- Install_Default_Action +-- Install_Ignore_Action +-- Copy_Interrupt_Mask +-- Set_Interrupt_Mask +-- Empty_Interrupt_Mask +-- Fill_Interrupt_Mask +-- Add_To_Interrupt_Mask +-- Delete_From_Interrupt_Mask +-- Interrupt_Wait +-- Interrupt_Self_Process +-- Get_Interrupt_Mask +-- Set_Interrupt_Mask +-- IS_Member +-- Environment_Mask +pragma Elaborate_All (System.Interrupt_Management.Operations); + +with System.Task_Primitives.Operations; +-- used for Write_Lock +-- Unlock +-- Abort +-- Wakeup_Task +-- Sleep +-- Initialize_Lock + +with System.Task_Primitives.Interrupt_Operations; +-- used for Set_Interrupt_ID + +with System.Storage_Elements; +-- used for To_Address +-- To_Integer +-- Integer_Address + +with System.Tasking; +-- used for Task_ID +-- Task_Entry_Index +-- Null_Task +-- Self +-- Interrupt_Manager_ID + +with System.Tasking.Utilities; +-- used for Make_Independent + +with System.Tasking.Rendezvous; +-- used for Call_Simple +pragma Elaborate_All (System.Tasking.Rendezvous); + +with System.Tasking.Initialization; +-- used for Defer_Abort +-- Undefer_Abort + +with System.Parameters; +-- used for Single_Lock + +with Unchecked_Conversion; + +package body System.Interrupts is + + use Tasking; + use System.Parameters; + use Ada.Exceptions; + + package POP renames System.Task_Primitives.Operations; + package PIO renames System.Task_Primitives.Interrupt_Operations; + package IMNG renames System.Interrupt_Management; + package IMOP renames System.Interrupt_Management.Operations; + + function To_System is new Unchecked_Conversion + (Ada.Task_Identification.Task_Id, Task_ID); + + ----------------- + -- Local Tasks -- + ----------------- + + -- WARNING: System.Tasking.Stages performs calls to this task + -- with low-level constructs. Do not change this spec without synchro- + -- nizing it. + + task Interrupt_Manager is + entry Detach_Interrupt_Entries (T : Task_ID); + + entry Initialize (Mask : IMNG.Interrupt_Mask); + + entry Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False); + + entry Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean); + + entry Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean); + + entry Bind_Interrupt_To_Entry + (T : Task_ID; + E : Task_Entry_Index; + Interrupt : Interrupt_ID); + + entry Block_Interrupt (Interrupt : Interrupt_ID); + + entry Unblock_Interrupt (Interrupt : Interrupt_ID); + + entry Ignore_Interrupt (Interrupt : Interrupt_ID); + + entry Unignore_Interrupt (Interrupt : Interrupt_ID); + + pragma Interrupt_Priority (System.Interrupt_Priority'Last); + end Interrupt_Manager; + + task type Server_Task (Interrupt : Interrupt_ID) is + pragma Priority (System.Interrupt_Priority'Last); + -- Note: the above pragma Priority is strictly speaking improper + -- since it is outside the range of allowed priorities, but the + -- compiler treats system units specially and does not apply + -- this range checking rule to system units. + + end Server_Task; + + type Server_Task_Access is access Server_Task; + + -------------------------------- + -- Local Types and Variables -- + -------------------------------- + + type Entry_Assoc is record + T : Task_ID; + E : Task_Entry_Index; + end record; + + type Handler_Assoc is record + H : Parameterless_Handler; + Static : Boolean; -- Indicates static binding; + end record; + + User_Handler : array (Interrupt_ID'Range) of Handler_Assoc := + (others => (null, Static => False)); + pragma Volatile_Components (User_Handler); + -- Holds the protected procedure handler (if any) and its Static + -- information for each interrupt. A handler is a Static one if + -- it is specified through the pragma Attach_Handler. + -- Attach_Handler. Otherwise, not static) + + User_Entry : array (Interrupt_ID'Range) of Entry_Assoc := + (others => (T => Null_Task, E => Null_Task_Entry)); + pragma Volatile_Components (User_Entry); + -- Holds the task and entry index (if any) for each interrupt + + Blocked : constant array (Interrupt_ID'Range) of Boolean := + (others => False); +-- ??? pragma Volatile_Components (Blocked); + -- True iff the corresponding interrupt is blocked in the process level + + Ignored : array (Interrupt_ID'Range) of Boolean := (others => False); + pragma Volatile_Components (Ignored); + -- True iff the corresponding interrupt is blocked in the process level + + Last_Unblocker : constant array (Interrupt_ID'Range) of Task_ID := + (others => Null_Task); +-- ??? pragma Volatile_Components (Last_Unblocker); + -- Holds the ID of the last Task which Unblocked this Interrupt. + -- It contains Null_Task if no tasks have ever requested the + -- Unblocking operation or the Interrupt is currently Blocked. + + Server_ID : array (Interrupt_ID'Range) of Task_ID := + (others => Null_Task); + pragma Atomic_Components (Server_ID); + -- Holds the Task_ID of the Server_Task for each interrupt. + -- Task_ID is needed to accomplish locking per Interrupt base. Also + -- is needed to decide whether to create a new Server_Task. + + -- Type and Head, Tail of the list containing Registered Interrupt + -- Handlers. These definitions are used to register the handlers + -- specified by the pragma Interrupt_Handler. + + type Registered_Handler; + type R_Link is access all Registered_Handler; + + type Registered_Handler is record + H : System.Address := System.Null_Address; + Next : R_Link := null; + end record; + + Registered_Handler_Head : R_Link := null; + Registered_Handler_Tail : R_Link := null; + + Access_Hold : Server_Task_Access; + -- variable used to allocate Server_Task using "new". + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Registered (Handler : Parameterless_Handler) return Boolean; + -- See if the Handler has been "pragma"ed using Interrupt_Handler. + -- Always consider a null handler as registered. + + -------------------------------- + -- Register_Interrupt_Handler -- + -------------------------------- + + procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is + New_Node_Ptr : R_Link; + begin + -- This routine registers the Handler as usable for Dynamic + -- Interrupt Handler. Routines attaching and detaching Handler + -- dynamically should first consult if the Handler is rgistered. + -- A Program Error should be raised if it is not registered. + + -- The pragma Interrupt_Handler can only appear in the library + -- level PO definition and instantiation. Therefore, we do not need + -- to implement Unregistering operation. Neither we need to + -- protect the queue structure using a Lock. + + pragma Assert (Handler_Addr /= System.Null_Address); + + New_Node_Ptr := new Registered_Handler; + New_Node_Ptr.H := Handler_Addr; + + if Registered_Handler_Head = null then + Registered_Handler_Head := New_Node_Ptr; + Registered_Handler_Tail := New_Node_Ptr; + + else + Registered_Handler_Tail.Next := New_Node_Ptr; + Registered_Handler_Tail := New_Node_Ptr; + end if; + end Register_Interrupt_Handler; + + ------------------- + -- Is_Registered -- + ------------------- + + function Is_Registered (Handler : Parameterless_Handler) return Boolean is + type Fat_Ptr is record + Object_Addr : System.Address; + Handler_Addr : System.Address; + end record; + + function To_Fat_Ptr is new Unchecked_Conversion + (Parameterless_Handler, Fat_Ptr); + + Ptr : R_Link; + Fat : Fat_Ptr; + + begin + if Handler = null then + return True; + end if; + + Fat := To_Fat_Ptr (Handler); + + Ptr := Registered_Handler_Head; + + while Ptr /= null loop + if Ptr.H = Fat.Handler_Addr then + return True; + end if; + + Ptr := Ptr.Next; + end loop; + + return False; + + end Is_Registered; + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is + begin + return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt)); + end Is_Reserved; + + ----------------------- + -- Is_Entry_Attached -- + ----------------------- + + function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + return User_Entry (Interrupt).T /= Null_Task; + end Is_Entry_Attached; + + ------------------------- + -- Is_Handler_Attached -- + ------------------------- + + function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + return User_Handler (Interrupt).H /= null; + end Is_Handler_Attached; + + ---------------- + -- Is_Blocked -- + ---------------- + + function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + return Blocked (Interrupt); + end Is_Blocked; + + ---------------- + -- Is_Ignored -- + ---------------- + + function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + return Ignored (Interrupt); + end Is_Ignored; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler (Interrupt : Interrupt_ID) + return Parameterless_Handler is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + -- ??? Since Parameterless_Handler is not Atomic, the + -- current implementation is wrong. We need a new service in + -- Interrupt_Manager to ensure atomicity. + + return User_Handler (Interrupt).H; + end Current_Handler; + + -------------------- + -- Attach_Handler -- + -------------------- + + -- Calling this procedure with New_Handler = null and Static = True + -- means we want to detach the current handler regardless of the + -- previous handler's binding status (ie. do not care if it is a + -- dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we + -- can detach handlers attached through pragma Attach_Handler. + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); + + end Attach_Handler; + + ---------------------- + -- Exchange_Handler -- + ---------------------- + + -- Calling this procedure with New_Handler = null and Static = True + -- means we want to detach the current handler regardless of the + -- previous handler's binding status (ie. do not care if it is a + -- dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we + -- can detach handlers attached through pragma Attach_Handler. + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + Interrupt_Manager.Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static); + + end Exchange_Handler; + + -------------------- + -- Detach_Handler -- + -------------------- + + -- Calling this procedure with Static = True means we want to Detach the + -- current handler regardless of the previous handler's binding status + -- (i.e. do not care if it is a dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we can + -- detach handlers attached through pragma Attach_Handler. + + procedure Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean := False) + is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + Interrupt_Manager.Detach_Handler (Interrupt, Static); + end Detach_Handler; + + --------------- + -- Reference -- + --------------- + + function Reference (Interrupt : Interrupt_ID) return System.Address is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + return Storage_Elements.To_Address + (Storage_Elements.Integer_Address (Interrupt)); + end Reference; + + ----------------------------- + -- Bind_Interrupt_To_Entry -- + ----------------------------- + + -- This procedure raises a Program_Error if it tries to + -- bind an interrupt to which an Entry or a Procedure is + -- already bound. + + procedure Bind_Interrupt_To_Entry + (T : Task_ID; + E : Task_Entry_Index; + Int_Ref : System.Address) + is + Interrupt : constant Interrupt_ID := + Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); + + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); + + end Bind_Interrupt_To_Entry; + + ------------------------------ + -- Detach_Interrupt_Entries -- + ------------------------------ + + procedure Detach_Interrupt_Entries (T : Task_ID) is + begin + Interrupt_Manager.Detach_Interrupt_Entries (T); + end Detach_Interrupt_Entries; + + --------------------- + -- Block_Interrupt -- + --------------------- + + procedure Block_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + Interrupt_Manager.Block_Interrupt (Interrupt); + end Block_Interrupt; + + ----------------------- + -- Unblock_Interrupt -- + ----------------------- + + procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + Interrupt_Manager.Unblock_Interrupt (Interrupt); + end Unblock_Interrupt; + + ------------------ + -- Unblocked_By -- + ------------------ + + function Unblocked_By + (Interrupt : Interrupt_ID) return System.Tasking.Task_ID is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + return Last_Unblocker (Interrupt); + end Unblocked_By; + + ---------------------- + -- Ignore_Interrupt -- + ---------------------- + + procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + Interrupt_Manager.Ignore_Interrupt (Interrupt); + end Ignore_Interrupt; + + ------------------------ + -- Unignore_Interrupt -- + ------------------------ + + procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + Raise_Exception (Program_Error'Identity, "Interrupt" & + Interrupt_ID'Image (Interrupt) & " is reserved"); + end if; + + Interrupt_Manager.Unignore_Interrupt (Interrupt); + end Unignore_Interrupt; + + ----------------------- + -- Interrupt_Manager -- + ----------------------- + + task body Interrupt_Manager is + + --------------------- + -- Local Routines -- + --------------------- + + procedure Unprotected_Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False); + + procedure Unprotected_Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean); + + ---------------------------------- + -- Unprotected_Exchange_Handler -- + ---------------------------------- + + procedure Unprotected_Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False) + is + begin + if User_Entry (Interrupt).T /= Null_Task then + -- In case we have an Interrupt Entry already installed. + -- raise a program error. (propagate it to the caller). + + Raise_Exception (Program_Error'Identity, + "An interrupt is already installed"); + end if; + + -- Note : A null handler with Static = True will + -- pass the following check. That is the case when we want to + -- Detach a handler regardless of the Static status + -- of the current_Handler. + -- We don't check anything if Restoration is True, since we + -- may be detaching a static handler to restore a dynamic one. + + if not Restoration and then not Static + -- Tries to overwrite a static Interrupt Handler with a + -- dynamic Handler + + and then (User_Handler (Interrupt).Static + + -- The new handler is not specified as an + -- Interrupt Handler by a pragma. + + or else not Is_Registered (New_Handler)) + then + Raise_Exception (Program_Error'Identity, + "Trying to overwrite a static Interrupt Handler with a " & + "dynamic Handler"); + end if; + + -- The interrupt should no longer be ingnored if + -- it was ever ignored. + + Ignored (Interrupt) := False; + + -- Save the old handler + + Old_Handler := User_Handler (Interrupt).H; + + -- The new handler + + User_Handler (Interrupt).H := New_Handler; + + if New_Handler = null then + + -- The null handler means we are detaching the handler. + + User_Handler (Interrupt).Static := False; + + else + User_Handler (Interrupt).Static := Static; + end if; + + -- Invoke a corresponding Server_Task if not yet created. + -- Place Task_ID info in Server_ID array. + + if Server_ID (Interrupt) = Null_Task then + Access_Hold := new Server_Task (Interrupt); + Server_ID (Interrupt) := To_System (Access_Hold.all'Identity); + else + POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep); + end if; + + end Unprotected_Exchange_Handler; + + -------------------------------- + -- Unprotected_Detach_Handler -- + -------------------------------- + + procedure Unprotected_Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean) + is + begin + if User_Entry (Interrupt).T /= Null_Task then + -- In case we have an Interrupt Entry installed. + -- raise a program error. (propagate it to the caller). + + Raise_Exception (Program_Error'Identity, + "An interrupt entry is already installed"); + end if; + + -- Note : Static = True will pass the following check. That is the + -- case when we want to detach a handler regardless of the static + -- status of the current_Handler. + + if not Static and then User_Handler (Interrupt).Static then + -- Tries to detach a static Interrupt Handler. + -- raise a program error. + + Raise_Exception (Program_Error'Identity, + "Trying to detach a static Interrupt Handler"); + end if; + + -- The interrupt should no longer be ignored if + -- it was ever ignored. + + Ignored (Interrupt) := False; + + -- The new handler + + User_Handler (Interrupt).H := null; + User_Handler (Interrupt).Static := False; + IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (Interrupt)); + + end Unprotected_Detach_Handler; + + -- Start of processing for Interrupt_Manager + + begin + -- By making this task independent of master, when the process + -- goes away, the Interrupt_Manager will terminate gracefully. + + System.Tasking.Utilities.Make_Independent; + + -- Environmen task gets its own interrupt mask, saves it, + -- and then masks all interrupts except the Keep_Unmasked set. + + -- During rendezvous, the Interrupt_Manager receives the old + -- interrupt mask of the environment task, and sets its own + -- interrupt mask to that value. + + -- The environment task will call the entry of Interrupt_Manager some + -- during elaboration of the body of this package. + + accept Initialize (Mask : IMNG.Interrupt_Mask) do + pragma Warnings (Off, Mask); + null; + end Initialize; + + -- Note: All tasks in RTS will have all the Reserve Interrupts + -- being masked (except the Interrupt_Manager) and Keep_Unmasked + -- unmasked when created. + + -- Abort_Task_Interrupt is one of the Interrupt unmasked + -- in all tasks. We mask the Interrupt in this particular task + -- so that "sigwait" is possible to catch an explicitely sent + -- Abort_Task_Interrupt from the Server_Tasks. + + -- This sigwaiting is needed so that we make sure a Server_Task is + -- out of its own sigwait state. This extra synchronization is + -- necessary to prevent following senarios. + + -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the + -- Server_Task then changes its own interrupt mask (OS level). + -- If an interrupt (corresponding to the Server_Task) arrives + -- in the nean time we have the Interrupt_Manager umnasked and + -- the Server_Task waiting on sigwait. + + -- 2) For unbinding handler, we install a default action in the + -- Interrupt_Manager. POSIX.1c states that the result of using + -- "sigwait" and "sigaction" simaltaneously on the same interrupt + -- is undefined. Therefore, we need to be informed from the + -- Server_Task of the fact that the Server_Task is out of its + -- sigwait stage. + + loop + -- A block is needed to absorb Program_Error exception + + declare + Old_Handler : Parameterless_Handler; + begin + select + + accept Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False) + do + Unprotected_Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static, Restoration); + end Attach_Handler; + + or accept Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean) + do + Unprotected_Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static); + end Exchange_Handler; + + or accept Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean) + do + Unprotected_Detach_Handler (Interrupt, Static); + end Detach_Handler; + + or accept Bind_Interrupt_To_Entry + (T : Task_ID; + E : Task_Entry_Index; + Interrupt : Interrupt_ID) + do + -- if there is a binding already (either a procedure or an + -- entry), raise Program_Error (propagate it to the caller). + + if User_Handler (Interrupt).H /= null + or else User_Entry (Interrupt).T /= Null_Task + then + Raise_Exception (Program_Error'Identity, + "A binding for this interrupt is already present"); + end if; + + -- The interrupt should no longer be ingnored if + -- it was ever ignored. + + Ignored (Interrupt) := False; + User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E); + + -- Indicate the attachment of Interrupt Entry in ATCB. + -- This is need so that when an Interrupt Entry task + -- terminates the binding can be cleaned. + -- The call to unbinding must be + -- make by the task before it terminates. + + T.Interrupt_Entry := True; + + -- Invoke a corresponding Server_Task if not yet created. + -- Place Task_ID info in Server_ID array. + + if Server_ID (Interrupt) = Null_Task then + + Access_Hold := new Server_Task (Interrupt); + Server_ID (Interrupt) := + To_System (Access_Hold.all'Identity); + else + POP.Wakeup (Server_ID (Interrupt), + Interrupt_Server_Idle_Sleep); + end if; + end Bind_Interrupt_To_Entry; + + or accept Detach_Interrupt_Entries (T : Task_ID) + do + for J in Interrupt_ID'Range loop + if not Is_Reserved (J) then + if User_Entry (J).T = T then + + -- The interrupt should no longer be ignored if + -- it was ever ignored. + + Ignored (J) := False; + User_Entry (J) := + Entry_Assoc'(T => Null_Task, E => Null_Task_Entry); + IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (J)); + end if; + end if; + end loop; + + -- Indicate in ATCB that no Interrupt Entries are attached. + + T.Interrupt_Entry := False; + end Detach_Interrupt_Entries; + + or accept Block_Interrupt (Interrupt : Interrupt_ID) do + pragma Warnings (Off, Interrupt); + raise Program_Error; + end Block_Interrupt; + + or accept Unblock_Interrupt (Interrupt : Interrupt_ID) do + pragma Warnings (Off, Interrupt); + raise Program_Error; + end Unblock_Interrupt; + + or accept Ignore_Interrupt (Interrupt : Interrupt_ID) do + pragma Warnings (Off, Interrupt); + raise Program_Error; + end Ignore_Interrupt; + + or accept Unignore_Interrupt (Interrupt : Interrupt_ID) do + pragma Warnings (Off, Interrupt); + raise Program_Error; + end Unignore_Interrupt; + + end select; + + exception + -- If there is a program error we just want to propagate it + -- to the caller and do not want to stop this task. + + when Program_Error => + null; + + when others => + pragma Assert (False); + null; + end; + end loop; + end Interrupt_Manager; + + ----------------- + -- Server_Task -- + ----------------- + + task body Server_Task is + Self_ID : constant Task_ID := Self; + Tmp_Handler : Parameterless_Handler; + Tmp_ID : Task_ID; + Tmp_Entry_Index : Task_Entry_Index; + Intwait_Mask : aliased IMNG.Interrupt_Mask; + + begin + -- By making this task independent of master, when the process + -- goes away, the Server_Task will terminate gracefully. + + System.Tasking.Utilities.Make_Independent; + + -- Install default action in system level. + + IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); + + -- Set up the mask (also clears the event flag) + + IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); + IMOP.Add_To_Interrupt_Mask + (Intwait_Mask'Access, IMNG.Interrupt_ID (Interrupt)); + + -- Remember the Interrupt_ID for Abort_Task. + + PIO.Set_Interrupt_ID (IMNG.Interrupt_ID (Interrupt), Self_ID); + + -- Note: All tasks in RTS will have all the Reserve Interrupts + -- being masked (except the Interrupt_Manager) and Keep_Unmasked + -- unmasked when created. + + loop + System.Tasking.Initialization.Defer_Abort (Self_ID); + + -- A Handler or an Entry is installed. At this point all tasks + -- mask for the Interrupt is masked. Catch the Interrupt using + -- sigwait. + + -- This task may wake up from sigwait by receiving an interrupt + -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding + -- a Procedure Handler or an Entry. Or it could be a wake up + -- from status change (Unblocked -> Blocked). If that is not + -- the case, we should exceute the attached Procedure or Entry. + + if Single_Lock then + POP.Lock_RTS; + end if; + + POP.Write_Lock (Self_ID); + + if User_Handler (Interrupt).H = null + and then User_Entry (Interrupt).T = Null_Task + then + -- No Interrupt binding. If there is an interrupt, + -- Interrupt_Manager will take default action. + + Self_ID.Common.State := Interrupt_Server_Idle_Sleep; + POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep); + Self_ID.Common.State := Runnable; + + else + Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag; + Self_ID.Common.State := Runnable; + + if not (Self_ID.Deferral_Level = 0 + and then Self_ID.Pending_ATC_Level + < Self_ID.ATC_Nesting_Level) + then + if User_Handler (Interrupt).H /= null then + Tmp_Handler := User_Handler (Interrupt).H; + + -- RTS calls should not be made with self being locked. + + POP.Unlock (Self_ID); + + if Single_Lock then + POP.Unlock_RTS; + end if; + + Tmp_Handler.all; + + if Single_Lock then + POP.Lock_RTS; + end if; + + POP.Write_Lock (Self_ID); + + elsif User_Entry (Interrupt).T /= Null_Task then + Tmp_ID := User_Entry (Interrupt).T; + Tmp_Entry_Index := User_Entry (Interrupt).E; + + -- RTS calls should not be made with self being locked. + + POP.Unlock (Self_ID); + + if Single_Lock then + POP.Unlock_RTS; + end if; + + System.Tasking.Rendezvous.Call_Simple + (Tmp_ID, Tmp_Entry_Index, System.Null_Address); + + if Single_Lock then + POP.Lock_RTS; + end if; + + POP.Write_Lock (Self_ID); + end if; + end if; + end if; + + POP.Unlock (Self_ID); + + if Single_Lock then + POP.Unlock_RTS; + end if; + + System.Tasking.Initialization.Undefer_Abort (Self_ID); + + -- Undefer abort here to allow a window for this task + -- to be aborted at the time of system shutdown. + end loop; + end Server_Task; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + function Has_Interrupt_Or_Attach_Handler + (Object : access Dynamic_Interrupt_Protection) + return Boolean + is + pragma Warnings (Off, Object); + + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + ---------------- + -- Finalize -- + ---------------- + + procedure Finalize (Object : in out Static_Interrupt_Protection) is + begin + -- ??? loop to be executed only when we're not doing library level + -- finalization, since in this case all interrupt tasks are gone. + if not Interrupt_Manager'Terminated then + for N in reverse Object.Previous_Handlers'Range loop + Interrupt_Manager.Attach_Handler + (New_Handler => Object.Previous_Handlers (N).Handler, + Interrupt => Object.Previous_Handlers (N).Interrupt, + Static => Object.Previous_Handlers (N).Static, + Restoration => True); + end loop; + end if; + + Tasking.Protected_Objects.Entries.Finalize + (Tasking.Protected_Objects.Entries.Protection_Entries (Object)); + end Finalize; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + function Has_Interrupt_Or_Attach_Handler + (Object : access Static_Interrupt_Protection) + return Boolean + is + pragma Warnings (Off, Object); + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + ---------------------- + -- Install_Handlers -- + ---------------------- + + procedure Install_Handlers + (Object : access Static_Interrupt_Protection; + New_Handlers : New_Handler_Array) + is + begin + for N in New_Handlers'Range loop + + -- We need a lock around this ??? + + Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt; + Object.Previous_Handlers (N).Static := User_Handler + (New_Handlers (N).Interrupt).Static; + + -- We call Exchange_Handler and not directly Interrupt_Manager. + -- Exchange_Handler so we get the Is_Reserved check. + + Exchange_Handler + (Old_Handler => Object.Previous_Handlers (N).Handler, + New_Handler => New_Handlers (N).Handler, + Interrupt => New_Handlers (N).Interrupt, + Static => True); + end loop; + end Install_Handlers; + +-- Elaboration code for package System.Interrupts +begin + + -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent. + + Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); + + -- During the elaboration of this package body we want RTS to + -- inherit the interrupt mask from the Environment Task. + + -- The Environment Task should have gotten its mask from + -- the enclosing process during the RTS start up. (See + -- in s-inmaop.adb). Pass the Interrupt_Mask of the Environment + -- task to the Interrupt_Manager. + + -- Note : At this point we know that all tasks (including + -- RTS internal servers) are masked for non-reserved signals + -- (see s-taprop.adb). Only the Interrupt_Manager will have + -- masks set up differently inheriting the original Environment + -- Task's mask. + + Interrupt_Manager.Initialize (IMOP.Environment_Mask); +end System.Interrupts; diff --git a/gcc/ada/s-interr-vxworks.adb b/gcc/ada/s-interr-vxworks.adb new file mode 100644 index 00000000000..5898e6d7e26 --- /dev/null +++ b/gcc/ada/s-interr-vxworks.adb @@ -0,0 +1,1146 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . I N T E R R U P T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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. -- +-- -- +------------------------------------------------------------------------------ + +-- Invariants: + +-- All user-handleable signals are masked at all times in all +-- tasks/threads except possibly for the Interrupt_Manager task. + +-- When a user task wants to have the effect of masking/unmasking an +-- signal, it must call Block_Interrupt/Unblock_Interrupt, which +-- will have the effect of unmasking/masking the signal in the +-- Interrupt_Manager task. These comments do not apply to vectored +-- hardware interrupts, which may be masked or unmasked using routined +-- interfaced to the relevant VxWorks system calls. + +-- Once we associate a Signal_Server_Task with an signal, the task never +-- goes away, and we never remove the association. On the other hand, it +-- is more convenient to terminate an associated Interrupt_Server_Task +-- for a vectored hardware interrupt (since we use a binary semaphore +-- for synchronization with the umbrella handler). + +-- There is no more than one signal per Signal_Server_Task and no more than +-- one Signal_Server_Task per signal. The same relation holds for hardware +-- interrupts and Interrupt_Server_Task's at any given time. That is, +-- only one non-terminated Interrupt_Server_Task exists for a give +-- interrupt at any time. + +-- Within this package, the lock L is used to protect the various status +-- tables. If there is a Server_Task associated with a signal or interrupt, +-- we use the per-task lock of the Server_Task instead so that we protect the +-- status between Interrupt_Manager and Server_Task. Protection among +-- service requests are ensured via user calls to the Interrupt_Manager +-- entries. + +-- This is the VxWorks version of this package, supporting vectored hardware +-- interrupts. + +with Unchecked_Conversion; + +with System.OS_Interface; use System.OS_Interface; + +with Interfaces.VxWorks; + +with Ada.Task_Identification; +-- used for Task_ID type + +with Ada.Exceptions; +-- used for Raise_Exception + +with System.Interrupt_Management; +-- used for Reserve + +with System.Task_Primitives.Operations; +-- used for Write_Lock +-- Unlock +-- Abort +-- Wakeup_Task +-- Sleep +-- Initialize_Lock + +with System.Storage_Elements; +-- used for To_Address +-- To_Integer +-- Integer_Address + +with System.Tasking; +-- used for Task_ID +-- Task_Entry_Index +-- Null_Task +-- Self +-- Interrupt_Manager_ID + +with System.Tasking.Utilities; +-- used for Make_Independent + +with System.Tasking.Rendezvous; +-- used for Call_Simple +pragma Elaborate_All (System.Tasking.Rendezvous); + +package body System.Interrupts is + + use Tasking; + use Ada.Exceptions; + + package POP renames System.Task_Primitives.Operations; + + function To_Ada is new Unchecked_Conversion + (System.Tasking.Task_ID, Ada.Task_Identification.Task_Id); + + function To_System is new Unchecked_Conversion + (Ada.Task_Identification.Task_Id, Task_ID); + + ----------------- + -- Local Tasks -- + ----------------- + + -- WARNING: System.Tasking.Stages performs calls to this task + -- with low-level constructs. Do not change this spec without synchro- + -- nizing it. + + task Interrupt_Manager is + entry Detach_Interrupt_Entries (T : Task_ID); + + entry Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False); + + entry Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean); + + entry Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean); + + entry Bind_Interrupt_To_Entry + (T : Task_ID; + E : Task_Entry_Index; + Interrupt : Interrupt_ID); + + pragma Interrupt_Priority (System.Interrupt_Priority'First); + end Interrupt_Manager; + + task type Interrupt_Server_Task + (Interrupt : Interrupt_ID; Int_Sema : SEM_ID) is + -- Server task for vectored hardware interrupt handling + pragma Interrupt_Priority (System.Interrupt_Priority'First + 2); + end Interrupt_Server_Task; + + type Interrupt_Task_Access is access Interrupt_Server_Task; + + ------------------------------- + -- Local Types and Variables -- + ------------------------------- + + type Entry_Assoc is record + T : Task_ID; + E : Task_Entry_Index; + end record; + + type Handler_Assoc is record + H : Parameterless_Handler; + Static : Boolean; -- Indicates static binding; + end record; + + User_Handler : array (Interrupt_ID) of Handler_Assoc := + (others => (null, Static => False)); + pragma Volatile_Components (User_Handler); + -- Holds the protected procedure handler (if any) and its Static + -- information for each interrupt or signal. A handler is static + -- iff it is specified through the pragma Attach_Handler. + + User_Entry : array (Interrupt_ID) of Entry_Assoc := + (others => (T => Null_Task, E => Null_Task_Entry)); + pragma Volatile_Components (User_Entry); + -- Holds the task and entry index (if any) for each interrupt / signal + + -- Type and Head, Tail of the list containing Registered Interrupt + -- Handlers. These definitions are used to register the handlers + -- specified by the pragma Interrupt_Handler. + + type Registered_Handler; + type R_Link is access all Registered_Handler; + + type Registered_Handler is record + H : System.Address := System.Null_Address; + Next : R_Link := null; + end record; + + Registered_Handler_Head : R_Link := null; + Registered_Handler_Tail : R_Link := null; + + Server_ID : array (Interrupt_ID) of System.Tasking.Task_ID := + (others => System.Tasking.Null_Task); + pragma Atomic_Components (Server_ID); + -- Holds the Task_ID of the Server_Task for each interrupt / signal. + -- Task_ID is needed to accomplish locking per interrupt base. Also + -- is needed to determine whether to create a new Server_Task. + + Semaphore_ID_Map : array + (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt) + of SEM_ID := (others => 0); + -- Array of binary semaphores associated with vectored interrupts + -- Note that the last bound should be Max_HW_Interrupt, but this will raise + -- Storage_Error if Num_HW_Interrupts is null, so use an extra 4 bytes + -- instead. + + Interrupt_Access_Hold : Interrupt_Task_Access; + -- Variable for allocating an Interrupt_Server_Task + + Default_Handler : array (HW_Interrupt) of Interfaces.VxWorks.VOIDFUNCPTR; + -- Vectored interrupt handlers installed prior to program startup. + -- These are saved only when the umbrella handler is installed for + -- a given interrupt number. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID); + -- Check if Id is a reserved interrupt, and if so raise Program_Error + -- with an appropriate message, otherwise return. + + procedure Finalize_Interrupt_Servers; + -- Unbind the handlers for hardware interrupt server tasks at program + -- termination. + + function Is_Registered (Handler : Parameterless_Handler) return Boolean; + -- See if Handler has been "pragma"ed using Interrupt_Handler. + -- Always consider a null handler as registered. + + procedure Notify_Interrupt (Param : System.Address); + -- Umbrella handler for vectored interrupts (not signals) + + procedure Install_Default_Action (Interrupt : HW_Interrupt); + -- Restore a handler that was in place prior to program execution + + procedure Install_Umbrella_Handler + (Interrupt : HW_Interrupt; + Handler : Interfaces.VxWorks.VOIDFUNCPTR); + -- Install the runtime umbrella handler for a vectored hardware + -- interrupt + + procedure Unimplemented (Feature : String); + pragma No_Return (Unimplemented); + -- Used to mark a call to an unimplemented function. Raises Program_Error + -- with an appropriate message noting that Feature is unimplemented. + + -------------------- + -- Attach_Handler -- + -------------------- + + -- Calling this procedure with New_Handler = null and Static = True + -- means we want to detach the current handler regardless of the + -- previous handler's binding status (ie. do not care if it is a + -- dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we + -- can detach handlers attached through pragma Attach_Handler. + + procedure Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) is + begin + Check_Reserved_Interrupt (Interrupt); + Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); + end Attach_Handler; + + ----------------------------- + -- Bind_Interrupt_To_Entry -- + ----------------------------- + + -- This procedure raises a Program_Error if it tries to + -- bind an interrupt to which an Entry or a Procedure is + -- already bound. + + procedure Bind_Interrupt_To_Entry + (T : Task_ID; + E : Task_Entry_Index; + Int_Ref : System.Address) + is + Interrupt : constant Interrupt_ID := + Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); + + begin + Check_Reserved_Interrupt (Interrupt); + Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); + end Bind_Interrupt_To_Entry; + + --------------------- + -- Block_Interrupt -- + --------------------- + + procedure Block_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented ("Block_Interrupt"); + end Block_Interrupt; + + ------------------------------ + -- Check_Reserved_Interrupt -- + ------------------------------ + + procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is + begin + if Is_Reserved (Interrupt) then + Raise_Exception + (Program_Error'Identity, + "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"); + else + return; + end if; + end Check_Reserved_Interrupt; + + --------------------- + -- Current_Handler -- + --------------------- + + function Current_Handler + (Interrupt : Interrupt_ID) return Parameterless_Handler is + begin + Check_Reserved_Interrupt (Interrupt); + + -- ??? Since Parameterless_Handler is not Atomic, the + -- current implementation is wrong. We need a new service in + -- Interrupt_Manager to ensure atomicity. + + return User_Handler (Interrupt).H; + end Current_Handler; + + -------------------- + -- Detach_Handler -- + -------------------- + + -- Calling this procedure with Static = True means we want to Detach the + -- current handler regardless of the previous handler's binding status + -- (i.e. do not care if it is a dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we can + -- detach handlers attached through pragma Attach_Handler. + + procedure Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean := False) is + begin + Check_Reserved_Interrupt (Interrupt); + Interrupt_Manager.Detach_Handler (Interrupt, Static); + end Detach_Handler; + + ------------------------------ + -- Detach_Interrupt_Entries -- + ------------------------------ + + procedure Detach_Interrupt_Entries (T : Task_ID) is + begin + Interrupt_Manager.Detach_Interrupt_Entries (T); + end Detach_Interrupt_Entries; + + ---------------------- + -- Exchange_Handler -- + ---------------------- + + -- Calling this procedure with New_Handler = null and Static = True + -- means we want to detach the current handler regardless of the + -- previous handler's binding status (ie. do not care if it is a + -- dynamic or static handler). + + -- This option is needed so that during the finalization of a PO, we + -- can detach handlers attached through pragma Attach_Handler. + + procedure Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean := False) is + begin + Check_Reserved_Interrupt (Interrupt); + Interrupt_Manager.Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static); + end Exchange_Handler; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Static_Interrupt_Protection) is + begin + -- ??? loop to be executed only when we're not doing library level + -- finalization, since in this case all interrupt / signal tasks are + -- gone. + + if not Interrupt_Manager'Terminated then + for N in reverse Object.Previous_Handlers'Range loop + Interrupt_Manager.Attach_Handler + (New_Handler => Object.Previous_Handlers (N).Handler, + Interrupt => Object.Previous_Handlers (N).Interrupt, + Static => Object.Previous_Handlers (N).Static, + Restoration => True); + end loop; + end if; + + Tasking.Protected_Objects.Entries.Finalize + (Tasking.Protected_Objects.Entries.Protection_Entries (Object)); + end Finalize; + + -------------------------------- + -- Finalize_Interrupt_Servers -- + -------------------------------- + + -- Restore default handlers for interrupt servers. + + -- This is called by the Interrupt_Manager task when it receives the abort + -- signal during program finalization. + + procedure Finalize_Interrupt_Servers is + HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0; + + begin + if HW_Interrupts then + for Int in HW_Interrupt loop + if Server_ID (Interrupt_ID (Int)) /= null + and then + not Ada.Task_Identification.Is_Terminated + (To_Ada (Server_ID (Interrupt_ID (Int)))) + then + Interrupt_Manager.Attach_Handler + (New_Handler => null, + Interrupt => Interrupt_ID (Int), + Static => True, + Restoration => True); + end if; + end loop; + end if; + end Finalize_Interrupt_Servers; + + ------------------------------------- + -- Has_Interrupt_Or_Attach_Handler -- + ------------------------------------- + + function Has_Interrupt_Or_Attach_Handler + (Object : access Dynamic_Interrupt_Protection) + return Boolean + is + pragma Unreferenced (Object); + + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + function Has_Interrupt_Or_Attach_Handler + (Object : access Static_Interrupt_Protection) + return Boolean + is + pragma Unreferenced (Object); + + begin + return True; + end Has_Interrupt_Or_Attach_Handler; + + ---------------------- + -- Ignore_Interrupt -- + ---------------------- + + procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented ("Ignore_Interrupt"); + end Ignore_Interrupt; + + ---------------------------- + -- Install_Default_Action -- + ---------------------------- + + procedure Install_Default_Action (Interrupt : HW_Interrupt) is + begin + -- Restore original interrupt handler + + Interfaces.VxWorks.intVecSet + (Interfaces.VxWorks.INUM_TO_IVEC (Integer (Interrupt)), + Default_Handler (Interrupt)); + Default_Handler (Interrupt) := null; + end Install_Default_Action; + + ---------------------- + -- Install_Handlers -- + ---------------------- + + procedure Install_Handlers + (Object : access Static_Interrupt_Protection; + New_Handlers : New_Handler_Array) is + begin + for N in New_Handlers'Range loop + -- We need a lock around this ??? + + Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt; + Object.Previous_Handlers (N).Static := User_Handler + (New_Handlers (N).Interrupt).Static; + + -- We call Exchange_Handler and not directly Interrupt_Manager. + -- Exchange_Handler so we get the Is_Reserved check. + + Exchange_Handler + (Old_Handler => Object.Previous_Handlers (N).Handler, + New_Handler => New_Handlers (N).Handler, + Interrupt => New_Handlers (N).Interrupt, + Static => True); + end loop; + end Install_Handlers; + + ------------------------------ + -- Install_Umbrella_Handler -- + ------------------------------ + + procedure Install_Umbrella_Handler + (Interrupt : HW_Interrupt; + Handler : Interfaces.VxWorks.VOIDFUNCPTR) + is + use Interfaces.VxWorks; + + Vec : constant Interrupt_Vector := + INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt)); + + Old_Handler : constant VOIDFUNCPTR := + intVecGet + (INUM_TO_IVEC (Interfaces.VxWorks.int (Interrupt))); + + Stat : Interfaces.VxWorks.STATUS; + pragma Unreferenced (Stat); + -- ??? shouldn't we test Stat at least in a pragma Assert? + + begin + -- Only install umbrella handler when no Ada handler has already been + -- installed. Note that the interrupt number is passed as a parameter + -- when an interrupt occurs, so the umbrella handler has a different + -- wrapper generated by intConnect for each interrupt number. + + if Default_Handler (Interrupt) = null then + Stat := + intConnect (Vec, Handler, System.Address (Interrupt)); + Default_Handler (Interrupt) := Old_Handler; + end if; + end Install_Umbrella_Handler; + + ---------------- + -- Is_Blocked -- + ---------------- + + function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is + begin + Unimplemented ("Is_Blocked"); + return False; + end Is_Blocked; + + ----------------------- + -- Is_Entry_Attached -- + ----------------------- + + function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + Check_Reserved_Interrupt (Interrupt); + return User_Entry (Interrupt).T /= Null_Task; + end Is_Entry_Attached; + + ------------------------- + -- Is_Handler_Attached -- + ------------------------- + + function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is + begin + Check_Reserved_Interrupt (Interrupt); + return User_Handler (Interrupt).H /= null; + end Is_Handler_Attached; + + ---------------- + -- Is_Ignored -- + ---------------- + + function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is + begin + Unimplemented ("Is_Ignored"); + return False; + end Is_Ignored; + + ------------------- + -- Is_Registered -- + ------------------- + + function Is_Registered (Handler : Parameterless_Handler) return Boolean is + type Fat_Ptr is record + Object_Addr : System.Address; + Handler_Addr : System.Address; + end record; + + function To_Fat_Ptr is new Unchecked_Conversion + (Parameterless_Handler, Fat_Ptr); + + Ptr : R_Link; + Fat : Fat_Ptr; + + begin + if Handler = null then + return True; + end if; + + Fat := To_Fat_Ptr (Handler); + + Ptr := Registered_Handler_Head; + + while Ptr /= null loop + if Ptr.H = Fat.Handler_Addr then + return True; + end if; + + Ptr := Ptr.Next; + end loop; + + return False; + end Is_Registered; + + ----------------- + -- Is_Reserved -- + ----------------- + + function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is + use System.Interrupt_Management; + begin + return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt)); + end Is_Reserved; + + ---------------------- + -- Notify_Interrupt -- + ---------------------- + + -- Umbrella handler for vectored hardware interrupts (as opposed to + -- signals and exceptions). As opposed to the signal implementation, + -- this handler is only installed in the vector table while there is + -- an active association of an Ada handler to the interrupt. + + -- Otherwise, the handler that existed prior to program startup is + -- in the vector table. This ensures that handlers installed by + -- the BSP are active unless explicitly replaced in the program text. + + -- Each Interrupt_Server_Task has an associated binary semaphore + -- on which it pends once it's been started. This routine determines + -- The appropriate semaphore and and issues a semGive call, waking + -- the server task. When a handler is unbound, + -- System.Interrupts.Unbind_Handler issues a semFlush, and the + -- server task deletes its semaphore and terminates. + + procedure Notify_Interrupt (Param : System.Address) is + Interrupt : constant Interrupt_ID := Interrupt_ID (Param); + + Discard_Result : STATUS; + pragma Unreferenced (Discard_Result); + + begin + Discard_Result := semGive (Semaphore_ID_Map (Interrupt)); + end Notify_Interrupt; + + --------------- + -- Reference -- + --------------- + + function Reference (Interrupt : Interrupt_ID) return System.Address is + begin + Check_Reserved_Interrupt (Interrupt); + return Storage_Elements.To_Address + (Storage_Elements.Integer_Address (Interrupt)); + end Reference; + + -------------------------------- + -- Register_Interrupt_Handler -- + -------------------------------- + + procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is + New_Node_Ptr : R_Link; + begin + -- This routine registers a handler as usable for dynamic + -- interrupt handler association. Routines attaching and detaching + -- handlers dynamically should determine whether the handler is + -- registered. Program_Error should be raised if it is not registered. + + -- Pragma Interrupt_Handler can only appear in a library + -- level PO definition and instantiation. Therefore, we do not need + -- to implement an unregister operation. Nor do we need to + -- protect the queue structure with a lock. + + pragma Assert (Handler_Addr /= System.Null_Address); + + New_Node_Ptr := new Registered_Handler; + New_Node_Ptr.H := Handler_Addr; + + if Registered_Handler_Head = null then + Registered_Handler_Head := New_Node_Ptr; + Registered_Handler_Tail := New_Node_Ptr; + + else + Registered_Handler_Tail.Next := New_Node_Ptr; + Registered_Handler_Tail := New_Node_Ptr; + end if; + end Register_Interrupt_Handler; + + ----------------------- + -- Unblock_Interrupt -- + ----------------------- + + procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented ("Unblock_Interrupt"); + end Unblock_Interrupt; + + ------------------ + -- Unblocked_By -- + ------------------ + + function Unblocked_By + (Interrupt : Interrupt_ID) return System.Tasking.Task_ID is + begin + Unimplemented ("Unblocked_By"); + return Null_Task; + end Unblocked_By; + + ------------------------ + -- Unignore_Interrupt -- + ------------------------ + + procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is + begin + Unimplemented ("Unignore_Interrupt"); + end Unignore_Interrupt; + + ------------------- + -- Unimplemented -- + ------------------- + + procedure Unimplemented (Feature : String) is + begin + Raise_Exception + (Program_Error'Identity, + Feature & " not implemented on VxWorks"); + end Unimplemented; + + ----------------------- + -- Interrupt_Manager -- + ----------------------- + + task body Interrupt_Manager is + + -------------------- + -- Local Routines -- + -------------------- + + procedure Bind_Handler (Interrupt : Interrupt_ID); + -- This procedure does not do anything if a signal is blocked. + -- Otherwise, we have to interrupt Server_Task for status change through + -- a wakeup signal. + + procedure Unbind_Handler (Interrupt : Interrupt_ID); + -- This procedure does not do anything if a signal is blocked. + -- Otherwise, we have to interrupt Server_Task for status change + -- through an abort signal. + + procedure Unprotected_Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False); + + procedure Unprotected_Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean); + + ------------------ + -- Bind_Handler -- + ------------------ + + procedure Bind_Handler (Interrupt : Interrupt_ID) is + begin + Install_Umbrella_Handler + (HW_Interrupt (Interrupt), Notify_Interrupt'Access); + end Bind_Handler; + + -------------------- + -- Unbind_Handler -- + -------------------- + + procedure Unbind_Handler (Interrupt : Interrupt_ID) is + S : STATUS; + use type STATUS; + + begin + -- Hardware interrupt + + Install_Default_Action (HW_Interrupt (Interrupt)); + + -- Flush server task off semaphore, allowing it to terminate + + S := semFlush (Semaphore_ID_Map (Interrupt)); + pragma Assert (S = 0); + end Unbind_Handler; + + -------------------------------- + -- Unprotected_Detach_Handler -- + -------------------------------- + + procedure Unprotected_Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean) + is + Old_Handler : Parameterless_Handler; + begin + if User_Entry (Interrupt).T /= Null_Task then + -- If an interrupt entry is installed raise + -- Program_Error. (propagate it to the caller). + + Raise_Exception (Program_Error'Identity, + "An interrupt entry is already installed"); + end if; + + -- Note : Static = True will pass the following check. This is the + -- case when we want to detach a handler regardless of the static + -- status of the Current_Handler. + + if not Static and then User_Handler (Interrupt).Static then + -- Trying to detach a static Interrupt Handler. + -- raise Program_Error. + + Raise_Exception (Program_Error'Identity, + "Trying to detach a static Interrupt Handler"); + end if; + + Old_Handler := User_Handler (Interrupt).H; + + -- The new handler + + User_Handler (Interrupt).H := null; + User_Handler (Interrupt).Static := False; + + if Old_Handler /= null then + Unbind_Handler (Interrupt); + end if; + end Unprotected_Detach_Handler; + + ---------------------------------- + -- Unprotected_Exchange_Handler -- + ---------------------------------- + + procedure Unprotected_Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False) is + begin + if User_Entry (Interrupt).T /= Null_Task then + -- If an interrupt entry is already installed, raise + -- Program_Error. (propagate it to the caller). + + Raise_Exception + (Program_Error'Identity, + "An interrupt is already installed"); + end if; + + -- Note : A null handler with Static = True will + -- pass the following check. This is the case when we want to + -- detach a handler regardless of the Static status + -- of Current_Handler. + -- We don't check anything if Restoration is True, since we + -- may be detaching a static handler to restore a dynamic one. + + if not Restoration and then not Static + and then (User_Handler (Interrupt).Static + + -- Trying to overwrite a static Interrupt Handler with a + -- dynamic Handler + + -- The new handler is not specified as an + -- Interrupt Handler by a pragma. + + or else not Is_Registered (New_Handler)) + then + Raise_Exception + (Program_Error'Identity, + "Trying to overwrite a static Interrupt Handler with a " & + "dynamic Handler"); + end if; + + -- Save the old handler + + Old_Handler := User_Handler (Interrupt).H; + + -- The new handler + + User_Handler (Interrupt).H := New_Handler; + + if New_Handler = null then + + -- The null handler means we are detaching the handler. + + User_Handler (Interrupt).Static := False; + + else + User_Handler (Interrupt).Static := Static; + end if; + + -- Invoke a corresponding Server_Task if not yet created. + -- Place Task_ID info in Server_ID array. + + if New_Handler /= null + and then + (Server_ID (Interrupt) = Null_Task + or else + Ada.Task_Identification.Is_Terminated + (To_Ada (Server_ID (Interrupt)))) + then + Interrupt_Access_Hold := + new Interrupt_Server_Task + (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY)); + Server_ID (Interrupt) := + To_System (Interrupt_Access_Hold.all'Identity); + end if; + + if (New_Handler = null) and then Old_Handler /= null then + -- Restore default handler + + Unbind_Handler (Interrupt); + + elsif Old_Handler = null then + -- Save default handler + + Bind_Handler (Interrupt); + end if; + end Unprotected_Exchange_Handler; + + -- Start of processing for Interrupt_Manager + + begin + -- By making this task independent of any master, when the process + -- goes away, the Interrupt_Manager will terminate gracefully. + + System.Tasking.Utilities.Make_Independent; + + loop + -- A block is needed to absorb Program_Error exception + + declare + Old_Handler : Parameterless_Handler; + + begin + select + accept Attach_Handler + (New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean; + Restoration : Boolean := False) + do + Unprotected_Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static, Restoration); + end Attach_Handler; + + or + accept Exchange_Handler + (Old_Handler : out Parameterless_Handler; + New_Handler : Parameterless_Handler; + Interrupt : Interrupt_ID; + Static : Boolean) + do + Unprotected_Exchange_Handler + (Old_Handler, New_Handler, Interrupt, Static); + end Exchange_Handler; + + or + accept Detach_Handler + (Interrupt : Interrupt_ID; + Static : Boolean) + do + Unprotected_Detach_Handler (Interrupt, Static); + end Detach_Handler; + or + accept Bind_Interrupt_To_Entry + (T : Task_ID; + E : Task_Entry_Index; + Interrupt : Interrupt_ID) + do + -- If there is a binding already (either a procedure or an + -- entry), raise Program_Error (propagate it to the caller). + + if User_Handler (Interrupt).H /= null + or else User_Entry (Interrupt).T /= Null_Task + then + Raise_Exception + (Program_Error'Identity, + "A binding for this interrupt is already present"); + end if; + + User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E); + + -- Indicate the attachment of interrupt entry in the ATCB. + -- This is needed so when an interrupt entry task terminates + -- the binding can be cleaned. The call to unbinding must be + -- make by the task before it terminates. + + T.Interrupt_Entry := True; + + -- Invoke a corresponding Server_Task if not yet created. + -- Place Task_ID info in Server_ID array. + + if Server_ID (Interrupt) = Null_Task + or else + Ada.Task_Identification.Is_Terminated + (To_Ada (Server_ID (Interrupt))) + then + Interrupt_Access_Hold := new Interrupt_Server_Task + (Interrupt, semBCreate (SEM_Q_FIFO, SEM_EMPTY)); + Server_ID (Interrupt) := + To_System (Interrupt_Access_Hold.all'Identity); + end if; + + Bind_Handler (Interrupt); + end Bind_Interrupt_To_Entry; + + or + accept Detach_Interrupt_Entries (T : Task_ID) do + for Int in Interrupt_ID'Range loop + if not Is_Reserved (Int) then + if User_Entry (Int).T = T then + User_Entry (Int) := + Entry_Assoc' + (T => Null_Task, E => Null_Task_Entry); + Unbind_Handler (Int); + end if; + end if; + end loop; + + -- Indicate in ATCB that no interrupt entries are attached. + + T.Interrupt_Entry := False; + end Detach_Interrupt_Entries; + end select; + + exception + -- If there is a Program_Error we just want to propagate it to + -- the caller and do not want to stop this task. + + when Program_Error => + null; + + when others => + pragma Assert (False); + null; + end; + end loop; + + exception + when Standard'Abort_Signal => + -- Flush interrupt server semaphores, so they can terminate + Finalize_Interrupt_Servers; + raise; + end Interrupt_Manager; + + --------------------------- + -- Interrupt_Server_Task -- + --------------------------- + + -- Server task for vectored hardware interrupt handling + + task body Interrupt_Server_Task is + Self_Id : constant Task_ID := Self; + Tmp_Handler : Parameterless_Handler; + Tmp_ID : Task_ID; + Tmp_Entry_Index : Task_Entry_Index; + S : STATUS; + + use type STATUS; + + begin + System.Tasking.Utilities.Make_Independent; + Semaphore_ID_Map (Interrupt) := Int_Sema; + + loop + -- Pend on semaphore that will be triggered by the + -- umbrella handler when the associated interrupt comes in + + S := semTake (Int_Sema, WAIT_FOREVER); + pragma Assert (S = 0); + + if User_Handler (Interrupt).H /= null then + + -- Protected procedure handler + + Tmp_Handler := User_Handler (Interrupt).H; + Tmp_Handler.all; + + elsif User_Entry (Interrupt).T /= Null_Task then + + -- Interrupt entry handler + + Tmp_ID := User_Entry (Interrupt).T; + Tmp_Entry_Index := User_Entry (Interrupt).E; + System.Tasking.Rendezvous.Call_Simple + (Tmp_ID, Tmp_Entry_Index, System.Null_Address); + + else + -- Semaphore has been flushed by an unbind operation in + -- the Interrupt_Manager. Terminate the server task. + + -- Wait for the Interrupt_Manager to complete its work + + POP.Write_Lock (Self_Id); + + -- Delete the associated semaphore + + S := semDelete (Int_Sema); + + pragma Assert (S = 0); + + -- Set status for the Interrupt_Manager + + Semaphore_ID_Map (Interrupt) := 0; + Server_ID (Interrupt) := Null_Task; + POP.Unlock (Self_Id); + + exit; + end if; + end loop; + end Interrupt_Server_Task; + +begin + -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent. + + Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); +end System.Interrupts; diff --git a/gcc/ada/s-intman-dummy.adb b/gcc/ada/s-intman-dummy.adb new file mode 100644 index 00000000000..9ef33ab5a15 --- /dev/null +++ b/gcc/ada/s-intman-dummy.adb @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- 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) 1997-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 NO tasking version of this package. + +package body System.Interrupt_Management is + + --------------------------- + -- Initialize_Interrupts -- + --------------------------- + + -- Nothing needs to be done on this platform. + + procedure Initialize_Interrupts is + begin + null; + end Initialize_Interrupts; + +end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-irix-athread.adb b/gcc/ada/s-intman-irix-athread.adb new file mode 100644 index 00000000000..57771303f16 --- /dev/null +++ b/gcc/ada/s-intman-irix-athread.adb @@ -0,0 +1,184 @@ +------------------------------------------------------------------------------ +-- -- +-- 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) 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 an Irix (old pthread library) version of this package. + +-- PLEASE DO NOT add any dependences on other packages. +-- This package is designed to work with or without tasking support. + +-- Make a careful study of all signals available under the OS, +-- to see which need to be reserved, kept always unmasked, +-- or kept always unmasked. + +-- Be on the lookout for special signals that +-- may be used by the thread library. + +with System.OS_Interface; +-- used for various Constants, Signal and types + +with Interfaces.C; +-- used for "int" +package body System.Interrupt_Management is + + use System.OS_Interface; + + type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID; + + Exception_Interrupts : constant Interrupt_List := + (SIGILL, + SIGABRT, + SIGFPE, + SIGSEGV, + SIGBUS); + + Reserved_Interrupts : constant Interrupt_List := + (0, + SIGTRAP, + SIGKILL, + SIGSYS, + SIGALRM, + SIGSTOP, + SIGPTINTR, + SIGPTRESCHED); + + Abort_Signal : constant := 48; + -- + -- Serious MOJO: The SGI pthreads library only supports the + -- unnamed signal number 48 for pthread_kill! + -- + + Unreserve_All_Interrupts : Interfaces.C.int; + pragma Import + (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); + + ---------------------- + -- Notify_Exception -- + ---------------------- + + -- This function identifies the Ada exception to be raised using the + -- information when the system received a synchronous signal. + -- Since this function is machine and OS dependent, different code has to + -- be provided for different target. + -- On SGI, the signal handling is done is a-init.c, even when tasking is + -- involved. + + --------------------------- + -- Initialize_Interrupts -- + --------------------------- + + -- Nothing needs to be done on this platform. + + procedure Initialize_Interrupts is + begin + null; + end Initialize_Interrupts; + +begin + declare + 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) + + use Interfaces.C; + + begin + Abort_Task_Interrupt := Abort_Signal; + + 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; + 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's + -- not in "User" state. Check for Unreserve_All_Interrupts last + + if State (SIGINT) /= User then + Keep_Unmasked (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 target-specific reserved signals + + for J in Reserved_Interrupts'Range loop + Reserve (Interrupt_ID (Reserved_Interrupts (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 not existing 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; diff --git a/gcc/ada/s-intman-irix.adb b/gcc/ada/s-intman-irix.adb new file mode 100644 index 00000000000..2a290e105da --- /dev/null +++ b/gcc/ada/s-intman-irix.adb @@ -0,0 +1,152 @@ +------------------------------------------------------------------------------ +-- -- +-- 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) 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 SGI Pthread version of this package. + +-- PLEASE DO NOT add any dependences on other packages. +-- This package is designed to work with or without tasking support. + +-- Make a careful study of all signals available under the OS, +-- to see which need to be reserved, kept always unmasked, +-- or kept always unmasked. +-- Be on the lookout for special signals that +-- may be used by the thread library. + +with Interfaces.C; +-- used for int + +with System.OS_Interface; +-- used for various Constants, Signal and types + +package body System.Interrupt_Management is + + use System.OS_Interface; + + type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID; + Exception_Interrupts : constant Interrupt_List := + (SIGTSTP, SIGILL, SIGTRAP, SIGEMT, SIGFPE, SIGBUS, SIGSTOP, SIGKILL, + SIGSEGV, SIGSYS, SIGXCPU, SIGXFSZ, SIGPROF, SIGPTINTR, SIGPTRESCHED, + SIGABRT, SIGPIPE); + + --------------------------- + -- Initialize_Interrupts -- + --------------------------- + + -- Nothing needs to be done on this platform + + procedure Initialize_Interrupts is + begin + null; + end Initialize_Interrupts; + + Unreserve_All_Interrupts : Interfaces.C.int; + pragma Import + (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts"); + + use type Interfaces.C.int; + +begin + declare + 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 + Abort_Task_Interrupt := SIGABRT; + + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + 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; + 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's + -- not in "User" state. Check for Unreserve_All_Interrupts last + + if State (SIGINT) /= User then + Keep_Unmasked (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; + + -- 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 not existing 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; diff --git a/gcc/ada/s-intman-mingw.adb b/gcc/ada/s-intman-mingw.adb new file mode 100644 index 00000000000..362e50132ff --- /dev/null +++ b/gcc/ada/s-intman-mingw.adb @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- 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) 1991-2000 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the NT version of this package + +-- This file performs the system-dependent translation between machine +-- exceptions and the Ada exceptions, if any, that should be raised when they +-- occur. + +-- PLEASE DO NOT add any dependences on other packages. +-- 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. + +with System.OS_Interface; use System.OS_Interface; + +package body System.Interrupt_Management is + + --------------------------- + -- Initialize_Interrupts -- + --------------------------- + + -- Nothing needs to be done on this platform. + + procedure Initialize_Interrupts is + begin + null; + end Initialize_Interrupts; + +begin + -- "Reserve" all the interrupts, except those that are explicitely defined + + for J in Interrupt_ID'Range loop + Reserve (J) := True; + end loop; + + Reserve (SIGINT) := False; + Reserve (SIGILL) := False; + Reserve (SIGABRT) := False; + Reserve (SIGFPE) := False; + Reserve (SIGSEGV) := False; + Reserve (SIGTERM) := False; +end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-posix.adb b/gcc/ada/s-intman-posix.adb new file mode 100644 index 00000000000..801adac39f2 --- /dev/null +++ b/gcc/ada/s-intman-posix.adb @@ -0,0 +1,285 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-intman-solaris.adb b/gcc/ada/s-intman-solaris.adb new file mode 100644 index 00000000000..d8d5963fca2 --- /dev/null +++ b/gcc/ada/s-intman-solaris.adb @@ -0,0 +1,263 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 Solaris version of this package. + +-- PLEASE DO NOT add any dependences on other packages. +-- This package is designed to work with or without tasking support. + +-- Make a careful study of all signals available under the OS, +-- to see which need to be reserved, kept always unmasked, +-- or kept always unmasked. + +-- Be on the lookout for special signals that +-- may be used by the thread library. + +with Interfaces.C; +-- used for int + +with System.OS_Interface; +-- used for various Constants, Signal and types + +package body System.Interrupt_Management is + + use 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"); + + ---------------------- + -- Notify_Exception -- + ---------------------- + + -- This function identifies the Ada exception to be raised using + -- the information when the system received a synchronous signal. + -- Since this function is machine and OS dependent, different code + -- has to be provided for different target. + + procedure Notify_Exception + (signo : Signal; + info : access siginfo_t; + context : access ucontext_t); + + ---------------------- + -- Notify_Exception -- + ---------------------- + + procedure Notify_Exception + (signo : Signal; + info : access siginfo_t; + context : access ucontext_t) + is + pragma Warnings (Off, context); + + begin + -- 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 => + case info.si_code is + when FPE_INTDIV | + FPE_INTOVF | + FPE_FLTDIV | + FPE_FLTOVF | + FPE_FLTUND | + FPE_FLTRES | + FPE_FLTINV | + FPE_FLTSUB => + + raise Constraint_Error; + + when others => + pragma Assert (False); + null; + end case; + + when SIGILL | SIGSEGV | SIGBUS => + raise Storage_Error; + + when others => + pragma Assert (False); + 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 Initialization -- +---------------------------- + +begin + declare + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + mask : aliased sigset_t; + Result : Interfaces.C.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; + + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + Abort_Task_Interrupt := SIGABRT; + + act.sa_handler := Notify_Exception'Address; + + -- 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. + + -- In that case, this field should be changed back to 0. ??? (Dong-Ik) + + act.sa_flags := 16; + + Result := sigemptyset (mask'Access); + pragma Assert (Result = 0); + + -- ??? For the same reason explained above, we can't mask these + -- signals because otherwise we won't be able to catch more than + -- one signal. + + act.sa_mask := mask; + + pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False)); + pragma Assert (Reserve = (Interrupt_ID'Range => False)); + + 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's + -- 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 not existing 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; diff --git a/gcc/ada/s-intman-vms.adb b/gcc/ada/s-intman-vms.adb new file mode 100644 index 00000000000..1190378766f --- /dev/null +++ b/gcc/ada/s-intman-vms.adb @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 OpenVMS/Alpha version of this package. + +-- PLEASE DO NOT add any dependences on other packages. +-- 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. + +with System.OS_Interface; +-- used for various Constants, Signal and types + +package body System.Interrupt_Management is + + use System.OS_Interface; + use type unsigned_long; + + --------------------------- + -- Initialize_Interrupts -- + --------------------------- + + procedure Initialize_Interrupts is + Status : Cond_Value_Type; + + begin + Sys_Crembx + (Status => Status, + Prmflg => False, + Chan => Rcv_Interrupt_Chan, + Maxmsg => Interrupt_ID'Size, + Bufquo => Interrupt_Bufquo, + Lognam => "GNAT_Interrupt_Mailbox", + Flags => CMB_M_READONLY); + + pragma Assert ((Status and 1) = 1); + + Sys_Assign + (Status => Status, + Devnam => "GNAT_Interrupt_Mailbox", + Chan => Snd_Interrupt_Chan, + Flags => AGN_M_WRITEONLY); + + pragma Assert ((Status and 1) = 1); + end Initialize_Interrupts; + +begin + -- Unused + + Abort_Task_Interrupt := Interrupt_ID_0; + + Reserve := Reserve or Keep_Unmasked or Keep_Masked; + + Reserve (Interrupt_ID_0) := True; + + Initialize_Interrupts; +end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-vms.ads b/gcc/ada/s-intman-vms.ads new file mode 100644 index 00000000000..60f410b01d7 --- /dev/null +++ b/gcc/ada/s-intman-vms.ads @@ -0,0 +1,142 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-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 Alpha/VMS version of this package. +-- +-- This package encapsulates and centralizes information about +-- all uses of interrupts (or signals), including the +-- target-dependent mapping of interrupts (or signals) to exceptions. + +-- PLEASE DO NOT add any with-clauses to this package. +-- This is designed to work for both tasking and non-tasking systems, +-- without pulling in any of the tasking support. + +-- PLEASE DO NOT remove the Elaborate_Body pragma from this package. +-- Elaboration of this package should happen early, as most other +-- initializations depend on it. +-- Forcing immediate elaboration of the body also helps to enforce +-- the design assumption that this is a second-level +-- package, just one level above System.OS_Interface, with no +-- cross-dependences. + +-- PLEASE DO NOT put any subprogram declarations with arguments of +-- type Interrupt_ID into the visible part of this package. +-- The type Interrupt_ID is used to derive the type in Ada.Interrupts, +-- and adding more operations to that type would be illegal according +-- to the Ada Reference Manual. (This is the reason why the signals sets +-- below are implemented as visible arrays rather than functions.) + +with System.OS_Interface; +-- used for Signal +-- sigset_t + +package System.Interrupt_Management is + + pragma Elaborate_Body; + + type Interrupt_Mask is limited private; + + type Interrupt_ID is new System.OS_Interface.Signal; + + type Interrupt_Set is array (Interrupt_ID) of Boolean; + + -- The following objects serve as constants, but are initialized + -- in the body to aid portability. This permits us + -- to use more portable names for interrupts, + -- where distinct names may map to the same interrupt ID value. + -- For example, suppose SIGRARE is a signal that is not defined on + -- all systems, but is always reserved when it is defined. + -- If we have the convention that ID zero is not used for any "real" + -- signals, and SIGRARE = 0 when SIGRARE is not one of the locally + -- supported signals, we can write + -- Reserved (SIGRARE) := true; + -- and the initialization code will be portable. + + Abort_Task_Interrupt : Interrupt_ID; + -- The interrupt that is used to implement task abortion, + -- if an interrupt is used for that purpose. + -- This is one of the reserved interrupts. + + Keep_Unmasked : Interrupt_Set := (others => False); + -- Keep_Unmasked (I) is true iff the interrupt I is + -- one that must be kept unmasked at all times, + -- except (perhaps) for short critical sections. + -- This includes interrupts that are mapped to exceptions + -- (see System.Interrupt_Exceptions.Is_Exception), but may also + -- include interrupts (e.g. timer) that need to be kept unmasked + -- for other reasons. + -- Where interrupts are implemented as OS signals, and signal masking + -- is per-task, the interrupt should be unmasked in ALL TASKS. + + Reserve : Interrupt_Set := (others => False); + -- Reserve (I) is true iff the interrupt I is one that + -- cannot be permitted to be attached to a user handler. + -- The possible reasons are many. For example, + -- it may be mapped to an exception, used to implement task abortion, + -- or used to implement time delays. + + Keep_Masked : Interrupt_Set := (others => False); + -- Keep_Masked (I) is true iff the interrupt I must always be masked. + -- Where interrupts are implemented as OS signals, and signal masking + -- is per-task, the interrupt should be masked in ALL TASKS. + -- There might not be any interrupts in this class, depending on + -- the environment. For example, if interrupts are OS signals + -- and signal masking is per-task, use of the sigwait operation + -- requires the signal be masked in all tasks. + + procedure Initialize_Interrupts; + -- On systems where there is no signal inheritance between tasks (e.g + -- VxWorks, GNU/LinuxThreads), this procedure is used to initialize + -- interrupts handling in each task. Otherwise this function should + -- only be called by initialize in this package body. + +private + + use type System.OS_Interface.unsigned_long; + + type Interrupt_Mask is new System.OS_Interface.sigset_t; + + -- Interrupts on VMS are implemented with a mailbox. A QIO read is + -- registered on the Rcv channel and the interrupt occurs by registering + -- a QIO write on the Snd channel. The maximum number of pending + -- interrupts is arbitrarily set at 1000. One nice feature of using + -- a mailbox is that it is trivially extendable to cross process + -- interrupts. + + Rcv_Interrupt_Chan : System.OS_Interface.unsigned_short := 0; + Snd_Interrupt_Chan : System.OS_Interface.unsigned_short := 0; + Interrupt_Mailbox : Interrupt_ID := 0; + Interrupt_Bufquo : System.OS_Interface.unsigned_long + := 1000 * (Interrupt_ID'Size / 8); + +end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-vxworks.adb b/gcc/ada/s-intman-vxworks.adb new file mode 100644 index 00000000000..411d86d0ae0 --- /dev/null +++ b/gcc/ada/s-intman-vxworks.adb @@ -0,0 +1,194 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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. + +-- It is likely to need tailoring to fit each operating system +-- and machine architecture. + +-- PLEASE DO NOT add any dependences on other packages. +-- 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. + +with Interfaces.C; + +with System.OS_Interface; +-- used for various Constants, Signal and types + +package body System.Interrupt_Management is + + use System.OS_Interface; + use type Interfaces.C.int; + + type Signal_List is array (Signal_ID range <>) of Signal_ID; + Exception_Signals : constant Signal_List (1 .. 4) := + (SIGFPE, SIGILL, SIGSEGV, SIGBUS); + + -- Keep these variables global so that they are initialized only once + -- What are "these variables" ???, I see only one + + Exception_Action : aliased struct_sigaction; + + procedure Map_And_Raise_Exception (signo : Signal); + pragma Import (C, Map_And_Raise_Exception, "__gnat_map_signal"); + -- Map signal to Ada exception and raise it. Different versions + -- of VxWorks need different mappings. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Notify_Exception (signo : Signal); + -- Identify the Ada exception to be raised using + -- the information when the system received a synchronous signal. + + ---------------------- + -- Notify_Exception -- + ---------------------- + + procedure Notify_Exception (signo : Signal) is + Mask : aliased sigset_t; + My_Id : t_id; + + Result : int; + pragma Unreferenced (Result); + + begin + Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access); + Result := sigdelset (Mask'Access, signo); + Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null); + + -- VxWorks will suspend the task when it gets a hardware + -- exception. We take the liberty of resuming the task + -- for the application. + + My_Id := taskIdSelf; + + if taskIsSuspended (My_Id) /= 0 then + Result := taskResume (My_Id); + end if; + + Map_And_Raise_Exception (signo); + end Notify_Exception; + + --------------------------- + -- Initialize_Interrupts -- + --------------------------- + + -- Since there is no signal inheritance between VxWorks tasks, we need + -- to initialize signal handling in each task. + + procedure Initialize_Interrupts is + Result : int; + old_act : aliased struct_sigaction; + + begin + for J in Exception_Signals'Range loop + Result := + sigaction + (Signal (Exception_Signals (J)), Exception_Action'Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + end loop; + end Initialize_Interrupts; + +begin + declare + mask : aliased sigset_t; + Result : 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: + + 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 + -- Initialize signal handling + + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + Abort_Task_Signal := SIGABRT; + + Exception_Action.sa_handler := Notify_Exception'Address; + Exception_Action.sa_flags := SA_ONSTACK; + Result := sigemptyset (mask'Access); + pragma Assert (Result = 0); + + for J in Exception_Signals'Range loop + Result := sigaddset (mask'Access, Signal (Exception_Signals (J))); + pragma Assert (Result = 0); + end loop; + + Exception_Action.sa_mask := mask; + + -- Initialize hardware interrupt handling + + pragma Assert (Reserve = (Interrupt_ID'Range => False)); + + -- Check all interrupts for state that requires keeping them reserved + + for J in Interrupt_ID'Range loop + if State (J) = Default or else State (J) = Runtime then + Reserve (J) := True; + end if; + end loop; + + -- Add exception signals to the set of unmasked signals + + for J in Exception_Signals'Range loop + Keep_Unmasked (Exception_Signals (J)) := True; + end loop; + + -- The abort signal must also be unmasked + + Keep_Unmasked (Abort_Task_Signal) := True; + end; +end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-vxworks.ads b/gcc/ada/s-intman-vxworks.ads new file mode 100644 index 00000000000..b0a4c3c5bda --- /dev/null +++ b/gcc/ada/s-intman-vxworks.ads @@ -0,0 +1,123 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- -- +-- S p e c -- +-- -- +-- 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 VxWorks version of this package. + +-- This package encapsulates and centralizes information about all +-- uses of interrupts (or signals), including the target-dependent +-- mapping of interrupts (or signals) to exceptions. + +-- Unlike the original design, System.Interrupt_Management can only +-- be used for tasking systems. + +-- PLEASE DO NOT remove the Elaborate_Body pragma from this package. +-- Elaboration of this package should happen early, as most other +-- initializations depend on it. Forcing immediate elaboration of +-- the body also helps to enforce the design assumption that this +-- is a second-level package, just one level above System.OS_Interface +-- with no cross-dependencies. + +-- PLEASE DO NOT put any subprogram declarations with arguments of +-- type Interrupt_ID into the visible part of this package. The type +-- Interrupt_ID is used to derive the type in Ada.Interrupts, and +-- adding more operations to that type would be illegal according +-- to the Ada Reference Manual. This is the reason why the signals +-- sets are implemeneted using visible arrays rather than functions. + +with System.OS_Interface; +-- used for sigset_t + +with Interfaces.C; +-- used for int + +package System.Interrupt_Management is + + pragma Elaborate_Body; + + type Interrupt_Mask is limited private; + + type Interrupt_ID is new Interfaces.C.int + range 0 .. System.OS_Interface.Max_Interrupt; + + type Interrupt_Set is array (Interrupt_ID) of Boolean; + + subtype Signal_ID is Interrupt_ID + range 0 .. Interfaces.C."-" (System.OS_Interface.NSIG, 1); + + type Signal_Set is array (Signal_ID) of Boolean; + + -- The following objects serve as constants, but are initialized + -- in the body to aid portability. This permits us to use more + -- portable names for interrupts, where distinct names may map to + -- the same interrupt ID value. + -- + -- For example, suppose SIGRARE is a signal that is not defined on + -- all systems, but is always reserved when it is defined. If we + -- have the convention that ID zero is not used for any "real" + -- signals, and SIGRARE = 0 when SIGRARE is not one of the locally + -- supported signals, we can write + -- Reserved (SIGRARE) := true; + -- and the initialization code will be portable. + + Abort_Task_Signal : Signal_ID; + -- The signal that is used to implement task abortion if + -- an interrupt is used for that purpose. This is one of the + -- reserved signals. + + Keep_Unmasked : Signal_Set := (others => False); + -- Keep_Unmasked (I) is true iff the signal I is one that must + -- that must be kept unmasked at all times, except (perhaps) for + -- short critical sections. This includes signals that are + -- mapped to exceptions, but may also include interrupts + -- (e.g. timer) that need to be kept unmasked for other + -- reasons. Where signal masking is per-task, the signal should be + -- unmasked in ALL TASKS. + + Reserve : Interrupt_Set := (others => False); + -- Reserve (I) is true iff the interrupt I is one that cannot be + -- permitted to be attached to a user handler. The possible reasons + -- are many. For example, it may be mapped to an exception used to + -- implement task abortion, or used to implement time delays. + + procedure Initialize_Interrupts; + -- On systems where there is no signal inheritance between tasks (e.g + -- VxWorks, GNU/LinuxThreads), this procedure is used to initialize + -- interrupts handling in each task. Otherwise this function should + -- only be called by initialize in this package body. + +private + type Interrupt_Mask is new System.OS_Interface.sigset_t; + -- In some implementation Interrupt_Mask can be represented + -- as a linked list. + +end System.Interrupt_Management; diff --git a/gcc/ada/s-mastop-irix.adb b/gcc/ada/s-mastop-irix.adb new file mode 100644 index 00000000000..6c85ce54f1a --- /dev/null +++ b/gcc/ada/s-mastop-irix.adb @@ -0,0 +1,444 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- SYSTEM.MACHINE_STATE_OPERATIONS -- +-- -- +-- B o d y -- +-- (Version for IRIX/MIPS) -- +-- -- +-- Copyright (C) 1999-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 version of Ada.Exceptions.Machine_State_Operations is for use on +-- SGI Irix systems. By means of compile time conditional calculations, it +-- can handle both n32/n64 and o32 modes. + +with System.Machine_Code; use System.Machine_Code; +with System.Memory; +with System.Soft_Links; use System.Soft_Links; +with Unchecked_Conversion; + +package body System.Machine_State_Operations is + + use System.Storage_Elements; + use System.Exceptions; + + -- The exc_unwind function in libexc operats on a Sigcontext + + -- Type sigcontext_t is defined in /usr/include/sys/signal.h. + -- We define an equivalent Ada type here. From the comments in + -- signal.h: + + -- sigcontext is not part of the ABI - so this version is used to + -- handle 32 and 64 bit applications - it is a constant size regardless + -- of compilation mode, and always returns 64 bit register values + + type Uns32 is mod 2 ** 32; + type Uns64 is mod 2 ** 64; + + type Uns32_Ptr is access all Uns32; + type Uns64_Array is array (Integer range <>) of Uns64; + + type Reg_Array is array (0 .. 31) of Uns64; + + type Sigcontext is record + SC_Regmask : Uns32; -- 0 + SC_Status : Uns32; -- 4 + SC_PC : Uns64; -- 8 + SC_Regs : Reg_Array; -- 16 + SC_Fpregs : Reg_Array; -- 272 + SC_Ownedfp : Uns32; -- 528 + SC_Fpc_Csr : Uns32; -- 532 + SC_Fpc_Eir : Uns32; -- 536 + SC_Ssflags : Uns32; -- 540 + SC_Mdhi : Uns64; -- 544 + SC_Mdlo : Uns64; -- 552 + SC_Cause : Uns64; -- 560 + SC_Badvaddr : Uns64; -- 568 + SC_Triggersave : Uns64; -- 576 + SC_Sigset : Uns64; -- 584 + SC_Fp_Rounded_Result : Uns64; -- 592 + SC_Pancake : Uns64_Array (0 .. 5); + SC_Pad : Uns64_Array (0 .. 26); + end record; + + type Sigcontext_Ptr is access all Sigcontext; + + SC_Regs_Pos : constant String := "16"; + SC_Fpregs_Pos : constant String := "272"; + -- Byte offset of the Integer and Floating Point register save areas + -- within the Sigcontext. + + function To_Sigcontext_Ptr is + new Unchecked_Conversion (Machine_State, Sigcontext_Ptr); + + type Addr_Int is mod 2 ** Long_Integer'Size; + -- An unsigned integer type whose size is the same as System.Address. + -- We rely on the fact that Long_Integer'Size = System.Address'Size in + -- all ABIs. Type Addr_Int can be converted to Uns64. + + function To_Code_Loc is new Unchecked_Conversion (Addr_Int, Code_Loc); + function To_Addr_Int is new Unchecked_Conversion (System.Address, Addr_Int); + function To_Uns32_Ptr is new Unchecked_Conversion (Addr_Int, Uns32_Ptr); + + -------------------------------- + -- ABI-Dependent Declarations -- + -------------------------------- + + o32 : constant Boolean := System.Word_Size = 32; + n32 : constant Boolean := System.Word_Size = 64; + o32n : constant Natural := Boolean'Pos (o32); + n32n : constant Natural := Boolean'Pos (n32); + -- Flags to indicate which ABI is in effect for this compilation. For the + -- purposes of this unit, the n32 and n64 ABI's are identical. + + LSC : constant Character := Character'Val (o32n * Character'Pos ('w') + + n32n * Character'Pos ('d')); + -- This is 'w' for o32, and 'd' for n32/n64, used for constructing the + -- load/store instructions used to save/restore machine instructions. + + Roff : constant Character := Character'Val (o32n * Character'Pos ('4') + + n32n * Character'Pos ('0')); + -- Offset from first byte of a __uint64 register save location where + -- the register value is stored. For n32/64 we store the entire 64 + -- bit register into the uint64. For o32, only 32 bits are stored + -- at an offset of 4 bytes. + + procedure Update_GP (Scp : Sigcontext_Ptr); + + --------------- + -- Update_GP -- + --------------- + + procedure Update_GP (Scp : Sigcontext_Ptr) is + + type F_op is mod 2 ** 6; + type F_reg is mod 2 ** 5; + type F_imm is new Short_Integer; + + type I_Type is record + op : F_op; + rs : F_reg; + rt : F_reg; + imm : F_imm; + end record; + + pragma Pack (I_Type); + for I_Type'Size use 32; + + type I_Type_Ptr is access all I_Type; + + LW : constant F_op := 2#100011#; + Reg_GP : constant := 28; + + type Address_Int is mod 2 ** Standard'Address_Size; + function To_I_Type_Ptr is new + Unchecked_Conversion (Address_Int, I_Type_Ptr); + + Ret_Ins : constant I_Type_Ptr := To_I_Type_Ptr (Address_Int (Scp.SC_PC)); + GP_Ptr : Uns32_Ptr; + + begin + if Ret_Ins.op = LW and then Ret_Ins.rt = Reg_GP then + GP_Ptr := To_Uns32_Ptr + (Addr_Int (Scp.SC_Regs (Integer (Ret_Ins.rs))) + + Addr_Int (Ret_Ins.imm)); + Scp.SC_Regs (Reg_GP) := Uns64 (GP_Ptr.all); + end if; + end Update_GP; + + ---------------------------- + -- Allocate_Machine_State -- + ---------------------------- + + function Allocate_Machine_State return Machine_State is + begin + return Machine_State + (Memory.Alloc (Sigcontext'Max_Size_In_Storage_Elements)); + end Allocate_Machine_State; + + ------------------- + -- Enter_Handler -- + ------------------- + + procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is + pragma Warnings (Off, M); + pragma Warnings (Off, Handler); + + LOADI : constant String (1 .. 2) := 'l' & LSC; + -- This is "lw" in o32 mode, and "ld" in n32/n64 mode + + LOADF : constant String (1 .. 4) := 'l' & LSC & "c1"; + -- This is "lwc1" in o32 mode and "ldc1" in n32/n64 mode + + begin + -- Restore integer registers from machine state. Note that we know + -- that $4 points to M, and $5 points to Handler, since this is + -- the standard calling sequence + + Asm (LOADI & " $16, 16*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (LOADI & " $17, 17*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (LOADI & " $18, 18*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (LOADI & " $19, 19*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (LOADI & " $20, 20*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (LOADI & " $21, 21*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (LOADI & " $22, 22*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (LOADI & " $23, 23*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (LOADI & " $24, 24*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (LOADI & " $25, 25*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (LOADI & " $26, 26*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (LOADI & " $27, 27*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (LOADI & " $28, 28*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (LOADI & " $29, 29*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (LOADI & " $30, 30*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (LOADI & " $31, 31*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + + -- Restore floating-point registers from machine state + + Asm (LOADF & " $f16, 16*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (LOADF & " $f17, 17*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (LOADF & " $f18, 18*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (LOADF & " $f19, 19*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (LOADF & " $f20, 20*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (LOADF & " $f21, 21*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (LOADF & " $f22, 22*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (LOADF & " $f23, 23*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (LOADF & " $f24, 24*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (LOADF & " $f25, 25*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (LOADF & " $f26, 26*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (LOADF & " $f27, 27*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (LOADF & " $f28, 28*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (LOADF & " $f29, 29*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (LOADF & " $f30, 30*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (LOADF & " $f31, 31*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + + -- Jump directly to the handler + + Asm ("jr $5"); + end Enter_Handler; + + ---------------- + -- Fetch_Code -- + ---------------- + + function Fetch_Code (Loc : Code_Loc) return Code_Loc is + begin + return Loc; + end Fetch_Code; + + ------------------------ + -- Free_Machine_State -- + ------------------------ + + procedure Free_Machine_State (M : in out Machine_State) is + begin + Memory.Free (Address (M)); + M := Machine_State (Null_Address); + end Free_Machine_State; + + ------------------ + -- Get_Code_Loc -- + ------------------ + + function Get_Code_Loc (M : Machine_State) return Code_Loc is + SC : constant Sigcontext_Ptr := To_Sigcontext_Ptr (M); + begin + return To_Code_Loc (Addr_Int (SC.SC_PC)); + end Get_Code_Loc; + + -------------------------- + -- Machine_State_Length -- + -------------------------- + + function Machine_State_Length return Storage_Offset is + begin + return Sigcontext'Max_Size_In_Storage_Elements; + end Machine_State_Length; + + --------------- + -- Pop_Frame -- + --------------- + + procedure Pop_Frame + (M : Machine_State; + Info : Subprogram_Info_Type) + is + pragma Warnings (Off, Info); + + Scp : constant Sigcontext_Ptr := To_Sigcontext_Ptr (M); + + procedure Exc_Unwind (Scp : Sigcontext_Ptr; Fde : Long_Integer := 0); + pragma Import (C, Exc_Unwind, "exc_unwind"); + + -- ??? Calling exc_unwind in the current setup does not work and + -- triggers the emission of system warning messages. Why it does + -- not work remains to be investigated. Part of the problem is + -- probably a section naming issue (e.g. .eh_frame/.debug_frame). + + -- Instead of letting the call take place for nothing and emit + -- messages we don't expect, we just arrange things to pretend it + -- occurred and failed. + + -- ??? Until this is fixed, we shall document that the backtrace + -- computation facility does not work, and we inhibit the pragma below + -- because we arrange for the call not to be emitted and the linker + -- complains when a library is linked in but resolves nothing. + + -- pragma Linker_Options ("-lexc"); + + begin + -- exc_unwind is apparently not thread-safe under IRIX, so protect it + -- against race conditions within the GNAT run time. + -- ??? Note that we might want to use a fine grained lock here since + -- Lock_Task is used in many other places. + + Lock_Task.all; + + if False then + Exc_Unwind (Scp); + else + Scp.SC_PC := 0; + end if; + + Unlock_Task.all; + + if Scp.SC_PC = 0 or else Scp.SC_PC = 1 then + + -- A return value of 0 or 1 means exc_unwind couldn't find a parent + -- frame. Propagate_Exception expects a zero return address to + -- indicate TOS. + + Scp.SC_PC := 0; + + else + -- Set the GP to restore to the caller value (not callee value) + -- This is done only in o32 mode. In n32/n64 mode, GP is a normal + -- callee save register + + if o32 then + Update_GP (Scp); + end if; + + -- Adjust the return address to the call site, not the + -- instruction following the branch delay slot. This may + -- be necessary if the last instruction of a pragma No_Return + -- subprogram is a call. The first instruction following the + -- delay slot may be the start of another subprogram. We back + -- off the address by 8, which points safely into the middle + -- of the generated subprogram code, avoiding end effects. + + Scp.SC_PC := Scp.SC_PC - 8; + end if; + end Pop_Frame; + + ----------------------- + -- Set_Machine_State -- + ----------------------- + + procedure Set_Machine_State (M : Machine_State) is + + STOREI : constant String (1 .. 2) := 's' & LSC; + -- This is "sw" in o32 mode, and "sd" in n32 mode + + STOREF : constant String (1 .. 4) := 's' & LSC & "c1"; + -- This is "swc1" in o32 mode and "sdc1" in n32 mode + + Scp : Sigcontext_Ptr; + + begin + -- Save the integer registers. Note that we know that $4 points + -- to M, since that is where the first parameter is passed. + -- Restore integer registers from machine state. Note that we know + -- that $4 points to M since this is the standard calling sequence + + <> + + Asm (STOREI & " $16, 16*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (STOREI & " $17, 17*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (STOREI & " $18, 18*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (STOREI & " $19, 19*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (STOREI & " $20, 20*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (STOREI & " $21, 21*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (STOREI & " $22, 22*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (STOREI & " $23, 23*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (STOREI & " $24, 24*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (STOREI & " $25, 25*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (STOREI & " $26, 26*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (STOREI & " $27, 27*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (STOREI & " $28, 28*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (STOREI & " $29, 29*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (STOREI & " $30, 30*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + Asm (STOREI & " $31, 31*8+" & Roff & "+" & SC_Regs_Pos & "($4)"); + + -- Restore floating-point registers from machine state + + Asm (STOREF & " $f16, 16*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (STOREF & " $f17, 17*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (STOREF & " $f18, 18*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (STOREF & " $f19, 19*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (STOREF & " $f20, 20*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (STOREF & " $f21, 21*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (STOREF & " $f22, 22*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (STOREF & " $f23, 23*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (STOREF & " $f24, 24*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (STOREF & " $f25, 25*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (STOREF & " $f26, 26*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (STOREF & " $f27, 27*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (STOREF & " $f28, 28*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (STOREF & " $f29, 29*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (STOREF & " $f30, 30*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + Asm (STOREF & " $f31, 31*8+" & Roff & "+" & SC_Fpregs_Pos & "($4)"); + + -- Set the PC value for the context to a location after the + -- prolog has been executed. + + Scp := To_Sigcontext_Ptr (M); + Scp.SC_PC := Uns64 (To_Addr_Int (Past_Prolog'Address)); + + -- We saved the state *inside* this routine, but what we want is + -- the state at the call site. So we need to do one pop operation. + -- This pop operation will properly set the PC value in the machine + -- state, so there is no need to save PC in the above code. + + Pop_Frame (M, Set_Machine_State'Address); + end Set_Machine_State; + + ------------------------------ + -- Set_Signal_Machine_State -- + ------------------------------ + + procedure Set_Signal_Machine_State + (M : Machine_State; + Context : System.Address) + is + pragma Warnings (Off, M); + pragma Warnings (Off, Context); + + begin + null; + end Set_Signal_Machine_State; + +end System.Machine_State_Operations; diff --git a/gcc/ada/s-mastop-tru64.adb b/gcc/ada/s-mastop-tru64.adb new file mode 100644 index 00000000000..956efa4e553 --- /dev/null +++ b/gcc/ada/s-mastop-tru64.adb @@ -0,0 +1,181 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- SYSTEM.MACHINE_STATE_OPERATIONS -- +-- -- +-- B o d y -- +-- (Version for Alpha/Dec Unix) -- +-- -- +-- 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 of System.Machine_State_Operations is for use on +-- Alpha systems running DEC Unix. + +with System.Memory; + +package body System.Machine_State_Operations is + + use System.Exceptions; + + pragma Linker_Options ("-lexc"); + -- Needed for definitions of exc_capture_context and exc_virtual_unwind + + ---------------------------- + -- Allocate_Machine_State -- + ---------------------------- + + function Allocate_Machine_State return Machine_State is + use System.Storage_Elements; + + function c_machine_state_length return Storage_Offset; + pragma Import (C, c_machine_state_length, "__gnat_machine_state_length"); + + begin + return Machine_State + (Memory.Alloc (Memory.size_t (c_machine_state_length))); + end Allocate_Machine_State; + + ------------------- + -- Enter_Handler -- + ------------------- + + procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is + procedure c_enter_handler (M : Machine_State; Handler : Handler_Loc); + pragma Import (C, c_enter_handler, "__gnat_enter_handler"); + + begin + c_enter_handler (M, Handler); + end Enter_Handler; + + ---------------- + -- Fetch_Code -- + ---------------- + + function Fetch_Code (Loc : Code_Loc) return Code_Loc is + begin + return Loc; + end Fetch_Code; + + ------------------------ + -- Free_Machine_State -- + ------------------------ + + procedure Free_Machine_State (M : in out Machine_State) is + begin + Memory.Free (Address (M)); + M := Machine_State (Null_Address); + end Free_Machine_State; + + ------------------ + -- Get_Code_Loc -- + ------------------ + + function Get_Code_Loc (M : Machine_State) return Code_Loc is + Asm_Call_Size : constant := 4; + + function c_get_code_loc (M : Machine_State) return Code_Loc; + pragma Import (C, c_get_code_loc, "__gnat_get_code_loc"); + + -- Code_Loc returned by c_get_code_loc is the return point but here we + -- want Get_Code_Loc to return the call point. Under DEC Unix a call + -- asm instruction takes 4 bytes. So we must remove this value from + -- c_get_code_loc to have the call point. + + Loc : constant Code_Loc := c_get_code_loc (M); + + begin + if Loc = 0 then + return 0; + else + return Loc - Asm_Call_Size; + end if; + end Get_Code_Loc; + + -------------------------- + -- Machine_State_Length -- + -------------------------- + + function Machine_State_Length + return System.Storage_Elements.Storage_Offset + is + use System.Storage_Elements; + + function c_machine_state_length return Storage_Offset; + pragma Import (C, c_machine_state_length, "__gnat_machine_state_length"); + + begin + return c_machine_state_length; + end Machine_State_Length; + + --------------- + -- Pop_Frame -- + --------------- + + procedure Pop_Frame + (M : Machine_State; + Info : Subprogram_Info_Type) + is + pragma Warnings (Off, Info); + + procedure exc_virtual_unwind + (Fcn : System.Address; + M : Machine_State); + pragma Import (C, exc_virtual_unwind, "exc_virtual_unwind"); + + begin + exc_virtual_unwind (System.Null_Address, M); + end Pop_Frame; + + ----------------------- + -- Set_Machine_State -- + ----------------------- + + procedure Set_Machine_State (M : Machine_State) is + procedure c_capture_context (M : Machine_State); + pragma Import (C, c_capture_context, "exc_capture_context"); + + begin + c_capture_context (M); + Pop_Frame (M, System.Null_Address); + end Set_Machine_State; + + ------------------------------ + -- Set_Signal_Machine_State -- + ------------------------------ + + procedure Set_Signal_Machine_State + (M : Machine_State; + Context : System.Address) + is + pragma Warnings (Off, M); + pragma Warnings (Off, Context); + + begin + null; + end Set_Signal_Machine_State; + +end System.Machine_State_Operations; diff --git a/gcc/ada/s-mastop-vms.adb b/gcc/ada/s-mastop-vms.adb new file mode 100644 index 00000000000..5bb3f8a1eff --- /dev/null +++ b/gcc/ada/s-mastop-vms.adb @@ -0,0 +1,339 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- SYSTEM.MACHINE_STATE_OPERATIONS -- +-- -- +-- B o d y -- +-- (Version for Alpha/VMS) -- +-- -- +-- Copyright (C) 2001-2002 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 of System.Machine_State_Operations is for use on +-- Alpha systems running VMS. + +with System.Memory; +with System.Aux_DEC; use System.Aux_DEC; +with Unchecked_Conversion; + +package body System.Machine_State_Operations is + + use System.Exceptions; + subtype Cond_Value_Type is Unsigned_Longword; + + -- Record layouts copied from Starlet. + + type ICB_Fflags_Bits_Type is record + Exception_Frame : Boolean; + Ast_Frame : Boolean; + Bottom_Of_Stack : Boolean; + Base_Frame : Boolean; + Filler_1 : Unsigned_20; + end record; + + for ICB_Fflags_Bits_Type use record + Exception_Frame at 0 range 0 .. 0; + Ast_Frame at 0 range 1 .. 1; + Bottom_Of_Stack at 0 range 2 .. 2; + Base_Frame at 0 range 3 .. 3; + Filler_1 at 0 range 4 .. 23; + end record; + for ICB_Fflags_Bits_Type'Size use 24; + + type ICB_Hdr_Quad_Type is record + Context_Length : Unsigned_Longword; + Fflags_Bits : ICB_Fflags_Bits_Type; + Block_Version : Unsigned_Byte; + end record; + + for ICB_Hdr_Quad_Type use record + Context_Length at 0 range 0 .. 31; + Fflags_Bits at 4 range 0 .. 23; + Block_Version at 7 range 0 .. 7; + end record; + for ICB_Hdr_Quad_Type'Size use 64; + + type Invo_Context_Blk_Type is record + + Hdr_Quad : ICB_Hdr_Quad_Type; + -- The first quadword contains: + -- o The length of the structure in bytes (a longword field) + -- o The frame flags (a 3 byte field of bits) + -- o The version number (a 1 byte field) + + Procedure_Descriptor : Unsigned_Quadword; + -- The address of the procedure descriptor for the procedure + + Program_Counter : Integer_64; + -- The current PC of a given procedure invocation + + Processor_Status : Integer_64; + -- The current PS of a given procedure invocation + + Ireg : Unsigned_Quadword_Array (0 .. 30); + Freg : Unsigned_Quadword_Array (0 .. 30); + -- The register contents areas. 31 for scalars, 31 for float. + + System_Defined : Unsigned_Quadword_Array (0 .. 1); + -- The following is an "internal" area that's reserved for use by + -- the operating system. It's size may vary over time. + + -- Chfctx_Addr : Unsigned_Quadword; + -- Defined as a comment since it overlaps other fields + + Filler_1 : String (1 .. 0); + -- Align to octaword + end record; + + for Invo_Context_Blk_Type use record + Hdr_Quad at 0 range 0 .. 63; + Procedure_Descriptor at 8 range 0 .. 63; + Program_Counter at 16 range 0 .. 63; + Processor_Status at 24 range 0 .. 63; + Ireg at 32 range 0 .. 1983; + Freg at 280 range 0 .. 1983; + System_Defined at 528 range 0 .. 127; + + -- Component representation spec(s) below are defined as + -- comments since they overlap other fields + + -- Chfctx_Addr at 528 range 0 .. 63; + + Filler_1 at 544 range 0 .. -1; + end record; + for Invo_Context_Blk_Type'Size use 4352; + + subtype Invo_Handle_Type is Unsigned_Longword; + + type Invo_Handle_Access_Type is access all Invo_Handle_Type; + + function Fetch is new Fetch_From_Address (Code_Loc); + + function To_Invo_Handle_Access is new Unchecked_Conversion + (Machine_State, Invo_Handle_Access_Type); + + function To_Machine_State is new Unchecked_Conversion + (System.Address, Machine_State); + + ---------------------------- + -- Allocate_Machine_State -- + ---------------------------- + + function Allocate_Machine_State return Machine_State is + begin + return To_Machine_State + (Memory.Alloc (Invo_Handle_Type'Max_Size_In_Storage_Elements)); + end Allocate_Machine_State; + + ------------------- + -- Enter_Handler -- + ------------------- + + procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is + procedure Get_Invo_Context ( + Result : out Unsigned_Longword; -- return value + Invo_Handle : Invo_Handle_Type; + Invo_Context : out Invo_Context_Blk_Type); + + pragma Interface (External, Get_Invo_Context); + + pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT", + (Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type), + (Value, Value, Reference)); + + ICB : Invo_Context_Blk_Type; + + procedure Goto_Unwind ( + Status : out Cond_Value_Type; -- return value + Target_Invo : Address := Address_Zero; + Target_PC : Address := Address_Zero; + New_R0 : Unsigned_Quadword := Unsigned_Quadword'Null_Parameter; + New_R1 : Unsigned_Quadword := Unsigned_Quadword'Null_Parameter); + + pragma Interface (External, Goto_Unwind); + + pragma Import_Valued_Procedure + (Goto_Unwind, "SYS$GOTO_UNWIND", + (Cond_Value_Type, Address, Address, + Unsigned_Quadword, Unsigned_Quadword), + (Value, Reference, Reference, + Reference, Reference)); + + Status : Cond_Value_Type; + + begin + Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB); + Goto_Unwind + (Status, System.Address (To_Invo_Handle_Access (M).all), Handler); + end Enter_Handler; + + ---------------- + -- Fetch_Code -- + ---------------- + + function Fetch_Code (Loc : Code_Loc) return Code_Loc is + begin + -- The starting address is in the second longword pointed to by Loc. + + return Fetch (System.Aux_DEC."+" (Loc, 8)); + end Fetch_Code; + + ------------------------ + -- Free_Machine_State -- + ------------------------ + + procedure Free_Machine_State (M : in out Machine_State) is + begin + Memory.Free (Address (M)); + M := Machine_State (Null_Address); + end Free_Machine_State; + + ------------------ + -- Get_Code_Loc -- + ------------------ + + function Get_Code_Loc (M : Machine_State) return Code_Loc is + procedure Get_Invo_Context ( + Result : out Unsigned_Longword; -- return value + Invo_Handle : in Invo_Handle_Type; + Invo_Context : out Invo_Context_Blk_Type); + + pragma Interface (External, Get_Invo_Context); + + pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT", + (Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type), + (Value, Value, Reference)); + + Asm_Call_Size : constant := 4; + -- Under VMS a call + -- asm instruction takes 4 bytes. So we must remove this amount. + + ICB : Invo_Context_Blk_Type; + Status : Cond_Value_Type; + + begin + Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB); + + if (Status and 1) /= 1 then + return Code_Loc (System.Null_Address); + end if; + + return Code_Loc (ICB.Program_Counter - Asm_Call_Size); + end Get_Code_Loc; + + -------------------------- + -- Machine_State_Length -- + -------------------------- + + function Machine_State_Length + return System.Storage_Elements.Storage_Offset + is + use System.Storage_Elements; + + begin + return Invo_Handle_Type'Size / 8; + end Machine_State_Length; + + --------------- + -- Pop_Frame -- + --------------- + + procedure Pop_Frame + (M : Machine_State; + Info : Subprogram_Info_Type) + is + pragma Warnings (Off, Info); + + procedure Get_Prev_Invo_Handle ( + Result : out Invo_Handle_Type; -- return value + ICB : in Invo_Handle_Type); + + pragma Interface (External, Get_Prev_Invo_Handle); + + pragma Import_Valued_Procedure + (Get_Prev_Invo_Handle, "LIB$GET_PREV_INVO_HANDLE", + (Invo_Handle_Type, Invo_Handle_Type), + (Value, Value)); + + Prev_Handle : aliased Invo_Handle_Type; + + begin + Get_Prev_Invo_Handle (Prev_Handle, To_Invo_Handle_Access (M).all); + To_Invo_Handle_Access (M).all := Prev_Handle; + end Pop_Frame; + + ----------------------- + -- Set_Machine_State -- + ----------------------- + + procedure Set_Machine_State (M : Machine_State) is + + procedure Get_Curr_Invo_Context + (Invo_Context : out Invo_Context_Blk_Type); + + pragma Interface (External, Get_Curr_Invo_Context); + + pragma Import_Valued_Procedure + (Get_Curr_Invo_Context, "LIB$GET_CURR_INVO_CONTEXT", + (Invo_Context_Blk_Type), + (Reference)); + + procedure Get_Invo_Handle ( + Result : out Invo_Handle_Type; -- return value + Invo_Context : in Invo_Context_Blk_Type); + + pragma Interface (External, Get_Invo_Handle); + + pragma Import_Valued_Procedure (Get_Invo_Handle, "LIB$GET_INVO_HANDLE", + (Invo_Handle_Type, Invo_Context_Blk_Type), + (Value, Reference)); + + ICB : Invo_Context_Blk_Type; + Invo_Handle : aliased Invo_Handle_Type; + + begin + Get_Curr_Invo_Context (ICB); + Get_Invo_Handle (Invo_Handle, ICB); + To_Invo_Handle_Access (M).all := Invo_Handle; + Pop_Frame (M, System.Null_Address); + end Set_Machine_State; + + ------------------------------ + -- Set_Signal_Machine_State -- + ------------------------------ + + procedure Set_Signal_Machine_State + (M : Machine_State; + Context : System.Address) + is + pragma Warnings (Off, M); + pragma Warnings (Off, Context); + + begin + null; + end Set_Signal_Machine_State; + +end System.Machine_State_Operations; diff --git a/gcc/ada/s-mastop-x86.adb b/gcc/ada/s-mastop-x86.adb new file mode 100644 index 00000000000..96ac1138d7e --- /dev/null +++ b/gcc/ada/s-mastop-x86.adb @@ -0,0 +1,594 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- SYSTEM.MACHINE_STATE_OPERATIONS -- +-- -- +-- B o d y -- +-- (Version for x86) -- +-- -- +-- Copyright (C) 1999-2004 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. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: it is very important that this unit not generate any exception +-- tables of any kind. Otherwise we get a nasty rtsfind recursion problem. +-- This means no subprograms, including implicitly generated ones. + +with Unchecked_Conversion; +with System.Storage_Elements; +with System.Machine_Code; use System.Machine_Code; +with System.Memory; + +package body System.Machine_State_Operations is + + function "+" (Left, Right : Address) return Address; + pragma Import (Intrinsic, "+"); + -- Provide addition operation on type Address (this may not be directly + -- available if type System.Address is non-private and the operations on + -- the type are made abstract to hide them from public users of System). + + use System.Exceptions; + + type Uns8 is mod 2 ** 8; + type Uns32 is mod 2 ** 32; + + type Bits5 is mod 2 ** 5; + type Bits6 is mod 2 ** 6; + + function To_Address is new Unchecked_Conversion (Uns32, Address); + + type Uns32_Ptr is access all Uns32; + function To_Uns32_Ptr is new Unchecked_Conversion (Uns32, Uns32_Ptr); + + -- Note: the type Uns32 has an alignment of 4. However, in some cases + -- values of type Uns32_Ptr will not be aligned (notably in the case + -- where we get the immediate field from an instruction). However this + -- does not matter in practice, since the x86 does not require that + -- operands be aligned. + + ---------------------- + -- General Approach -- + ---------------------- + + -- For the x86 version of this unit, the Subprogram_Info_Type values + -- are simply the starting code address for the subprogram. Popping + -- of stack frames works by analyzing the code in the prolog, and + -- deriving from this analysis the necessary information for restoring + -- the registers, including the return point. + + --------------------------- + -- Description of Prolog -- + --------------------------- + + -- If a frame pointer is present, the prolog looks like + + -- pushl %ebp + -- movl %esp,%ebp + -- subl $nnn,%esp omitted if nnn = 0 + -- pushl %edi omitted if edi not used + -- pushl %esi omitted if esi not used + -- pushl %ebx omitted if ebx not used + + -- If a frame pointer is not present, the prolog looks like + + -- subl $nnn,%esp omitted if nnn = 0 + -- pushl %ebp omitted if ebp not used + -- pushl %edi omitted if edi not used + -- pushl %esi omitted if esi not used + -- pushl %ebx omitted if ebx not used + + -- Note: any or all of the save over call registers may be used and + -- if so, will be saved using pushl as shown above. The order of the + -- pushl instructions will be as shown above for gcc generated code, + -- but the code in this unit does not assume this. + + ------------------------- + -- Description of Call -- + ------------------------- + + -- A call looks like: + + -- pushl ... push parameters + -- pushl ... + -- call ... perform the call + -- addl $nnn,%esp omitted if no parameters + + -- Note that we are not absolutely guaranteed that the call is always + -- followed by an addl operation that readjusts %esp for this particular + -- call. There are two reasons for this: + + -- 1) The addl can be delayed and combined in the case where more than + -- one call appears in sequence. This can be suppressed by using the + -- switch -fno-defer-pop and for Ada code, we automatically use + -- this switch, but we could still be dealing with C code that was + -- compiled without using this switch. + + -- 2) Scheduling may result in moving the addl instruction away from + -- the call. It is not clear if this actually can happen at the + -- current time, but it is certainly conceptually possible. + + -- The addl after the call is important, since we need to be able to + -- restore the proper %esp value when we pop the stack. However, we do + -- not try to compensate for either of the above effects. As noted above, + -- case 1 does not occur for Ada code, and it does not appear in practice + -- that case 2 occurs with any significant frequency (we have never seen + -- an example so far for gcc generated code). + + -- Furthermore, it is only in the case of -fomit-frame-pointer that we + -- really get into trouble from not properly restoring %esp. If we have + -- a frame pointer, then the worst that happens is that %esp is slightly + -- more depressed than it should be. This could waste a bit of space on + -- the stack, and even in some cases cause a storage leak on the stack, + -- but it will not affect the functional correctness of the processing. + + ---------------------------------------- + -- Definitions of Instruction Formats -- + ---------------------------------------- + + type Rcode is (eax, ecx, edx, ebx, esp, ebp, esi, edi); + pragma Warnings (Off, Rcode); + -- Code indicating which register is referenced in an instruction + + -- The following define the format of a pushl instruction + + Op_pushl : constant Bits5 := 2#01010#; + + type Ins_pushl is record + Op : Bits5 := Op_pushl; + Reg : Rcode; + end record; + + for Ins_pushl use record + Op at 0 range 3 .. 7; + Reg at 0 range 0 .. 2; + end record; + + Ins_pushl_ebp : constant Ins_pushl := (Op_pushl, Reg => ebp); + + type Ins_pushl_Ptr is access all Ins_pushl; + + -- For the movl %esp,%ebp instruction, we only need to know the length + -- because we simply skip past it when we analyze the prolog. + + Ins_movl_length : constant := 2; + + -- The following define the format of addl/subl esp instructions + + Op_Immed : constant Bits6 := 2#100000#; + + Op2_addl_Immed : constant Bits5 := 2#11100#; + pragma Unreferenced (Op2_addl_Immed); + + Op2_subl_Immed : constant Bits5 := 2#11101#; + + type Word_Byte is (Word, Byte); + pragma Unreferenced (Byte); + + type Ins_addl_subl_byte is record + Op : Bits6; -- Set to Op_Immed + w : Word_Byte; -- Word/Byte flag (set to 1 = byte) + s : Boolean; -- Sign extension bit (1 = extend) + Op2 : Bits5; -- Secondary opcode + Reg : Rcode; -- Register + Imm8 : Uns8; -- Immediate operand + end record; + + for Ins_addl_subl_byte use record + Op at 0 range 2 .. 7; + w at 0 range 1 .. 1; + s at 0 range 0 .. 0; + Op2 at 1 range 3 .. 7; + Reg at 1 range 0 .. 2; + Imm8 at 2 range 0 .. 7; + end record; + + type Ins_addl_subl_word is record + Op : Bits6; -- Set to Op_Immed + w : Word_Byte; -- Word/Byte flag (set to 0 = word) + s : Boolean; -- Sign extension bit (1 = extend) + Op2 : Bits5; -- Secondary opcode + Reg : Rcode; -- Register + Imm32 : Uns32; -- Immediate operand + end record; + + for Ins_addl_subl_word use record + Op at 0 range 2 .. 7; + w at 0 range 1 .. 1; + s at 0 range 0 .. 0; + Op2 at 1 range 3 .. 7; + Reg at 1 range 0 .. 2; + Imm32 at 2 range 0 .. 31; + end record; + + type Ins_addl_subl_byte_Ptr is access all Ins_addl_subl_byte; + type Ins_addl_subl_word_Ptr is access all Ins_addl_subl_word; + + --------------------- + -- Prolog Analysis -- + --------------------- + + -- The analysis of the prolog answers the following questions: + + -- 1. Is %ebp used as a frame pointer? + -- 2. How far is SP depressed (i.e. what is the stack frame size) + -- 3. Which registers are saved in the prolog, and in what order + + -- The following data structure stores the answers to these questions + + subtype SOC is Rcode range ebx .. edi; + -- Possible save over call registers + + SOC_Max : constant := 4; + -- Max number of SOC registers that can be pushed + + type SOC_Push_Regs_Type is array (1 .. 4) of Rcode; + -- Used to hold the register codes of pushed SOC registers + + type Prolog_Type is record + + Frame_Reg : Boolean; + -- This is set to True if %ebp is used as a frame register, and + -- False otherwise (in the False case, %ebp may be saved in the + -- usual manner along with the other SOC registers). + + Frame_Length : Uns32; + -- Amount by which ESP is decremented on entry, includes the effects + -- of push's of save over call registers as indicated above, e.g. if + -- the prolog of a routine is: + -- + -- pushl %ebp + -- movl %esp,%ebp + -- subl $424,%esp + -- pushl %edi + -- pushl %esi + -- pushl %ebx + -- + -- Then the value of Frame_Length would be 436 (424 + 3 * 4). A + -- precise definition is that it is: + -- + -- %esp on entry minus %esp after last SOC push + -- + -- That definition applies both in the frame pointer present and + -- the frame pointer absent cases. + + Num_SOC_Push : Integer range 0 .. SOC_Max; + -- Number of save over call registers actually saved by pushl + -- instructions (other than the initial pushl to save the frame + -- pointer if a frame pointer is in use). + + SOC_Push_Regs : SOC_Push_Regs_Type; + -- The First Num_SOC_Push entries of this array are used to contain + -- the codes for the SOC registers, in the order in which they were + -- pushed. Note that this array excludes %ebp if it is used as a frame + -- register, since although %ebp is still considered an SOC register + -- in this case, it is saved and restored by a separate mechanism. + -- Also we will never see %esp represented in this list. Again, it is + -- true that %esp is saved over call, but it is restored by a separate + -- mechanism. + + end record; + + procedure Analyze_Prolog (A : Address; Prolog : out Prolog_Type); + -- Given the address of the start of the prolog for a procedure, + -- analyze the instructions of the prolog, and set Prolog to contain + -- the information obtained from this analysis. + + ---------------------------------- + -- Machine_State_Representation -- + ---------------------------------- + + -- The type Machine_State is defined in the body of Ada.Exceptions as + -- a Storage_Array of length 1 .. Machine_State_Length. But really it + -- has structure as defined here. We use the structureless declaration + -- in Ada.Exceptions to avoid this unit from being implementation + -- dependent. The actual definition of Machine_State is as follows: + + type SOC_Regs_Type is array (SOC) of Uns32; + + type MState is record + eip : Uns32; + -- The instruction pointer location (which is the return point + -- value from the next level down in all cases). + + Regs : SOC_Regs_Type; + -- Values of the save over call registers + end record; + + for MState use record + eip at 0 range 0 .. 31; + Regs at 4 range 0 .. 5 * 32 - 1; + end record; + -- Note: the routines Enter_Handler, and Set_Machine_State reference + -- the fields in this structure non-symbolically. + + type MState_Ptr is access all MState; + + function To_MState_Ptr is + new Unchecked_Conversion (Machine_State, MState_Ptr); + + ---------------------------- + -- Allocate_Machine_State -- + ---------------------------- + + function Allocate_Machine_State return Machine_State is + use System.Storage_Elements; + + begin + return Machine_State + (Memory.Alloc (MState'Max_Size_In_Storage_Elements)); + end Allocate_Machine_State; + + -------------------- + -- Analyze_Prolog -- + -------------------- + + procedure Analyze_Prolog (A : Address; Prolog : out Prolog_Type) is + Ptr : Address; + Ppl : Ins_pushl_Ptr; + Pas : Ins_addl_subl_byte_Ptr; + + function To_Ins_pushl_Ptr is + new Unchecked_Conversion (Address, Ins_pushl_Ptr); + + function To_Ins_addl_subl_byte_Ptr is + new Unchecked_Conversion (Address, Ins_addl_subl_byte_Ptr); + + function To_Ins_addl_subl_word_Ptr is + new Unchecked_Conversion (Address, Ins_addl_subl_word_Ptr); + + begin + Ptr := A; + Prolog.Frame_Length := 0; + + if Ptr = Null_Address then + Prolog.Num_SOC_Push := 0; + Prolog.Frame_Reg := True; + return; + end if; + + if To_Ins_pushl_Ptr (Ptr).all = Ins_pushl_ebp then + Ptr := Ptr + 1 + Ins_movl_length; + Prolog.Frame_Reg := True; + else + Prolog.Frame_Reg := False; + end if; + + Pas := To_Ins_addl_subl_byte_Ptr (Ptr); + + if Pas.Op = Op_Immed + and then Pas.Op2 = Op2_subl_Immed + and then Pas.Reg = esp + then + if Pas.w = Word then + Prolog.Frame_Length := Prolog.Frame_Length + + To_Ins_addl_subl_word_Ptr (Ptr).Imm32; + Ptr := Ptr + 6; + + else + Prolog.Frame_Length := Prolog.Frame_Length + Uns32 (Pas.Imm8); + Ptr := Ptr + 3; + + -- Note: we ignore sign extension, since a sign extended + -- value that was negative would imply a ludicrous frame size. + end if; + end if; + + -- Now scan push instructions for SOC registers + + Prolog.Num_SOC_Push := 0; + + loop + Ppl := To_Ins_pushl_Ptr (Ptr); + + if Ppl.Op = Op_pushl and then Ppl.Reg in SOC then + Prolog.Num_SOC_Push := Prolog.Num_SOC_Push + 1; + Prolog.SOC_Push_Regs (Prolog.Num_SOC_Push) := Ppl.Reg; + Prolog.Frame_Length := Prolog.Frame_Length + 4; + Ptr := Ptr + 1; + + else + exit; + end if; + end loop; + + end Analyze_Prolog; + + ------------------- + -- Enter_Handler -- + ------------------- + + procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is + begin + Asm ("mov %0,%%edx", Inputs => Machine_State'Asm_Input ("r", M)); + Asm ("mov %0,%%eax", Inputs => Handler_Loc'Asm_Input ("r", Handler)); + + Asm ("mov 4(%%edx),%%ebx"); -- M.Regs (ebx) + Asm ("mov 12(%%edx),%%ebp"); -- M.Regs (ebp) + Asm ("mov 16(%%edx),%%esi"); -- M.Regs (esi) + Asm ("mov 20(%%edx),%%edi"); -- M.Regs (edi) + Asm ("mov 8(%%edx),%%esp"); -- M.Regs (esp) + Asm ("jmp %*%%eax"); + end Enter_Handler; + + ---------------- + -- Fetch_Code -- + ---------------- + + function Fetch_Code (Loc : Code_Loc) return Code_Loc is + begin + return Loc; + end Fetch_Code; + + ------------------------ + -- Free_Machine_State -- + ------------------------ + + procedure Free_Machine_State (M : in out Machine_State) is + begin + Memory.Free (Address (M)); + M := Machine_State (Null_Address); + end Free_Machine_State; + + ------------------ + -- Get_Code_Loc -- + ------------------ + + function Get_Code_Loc (M : Machine_State) return Code_Loc is + + Asm_Call_Size : constant := 2; + -- Minimum size for a call instruction under ix86. Using the minimum + -- size is safe here as the call point computed from the return point + -- will always be inside the call instruction. + + MS : constant MState_Ptr := To_MState_Ptr (M); + + begin + if MS.eip = 0 then + return To_Address (MS.eip); + else + -- When doing a call the return address is pushed to the stack. + -- We want to return the call point address, so we substract + -- Asm_Call_Size from the return address. This value is set + -- to 5 as an asm call takes 5 bytes on x86 architectures. + + return To_Address (MS.eip - Asm_Call_Size); + end if; + end Get_Code_Loc; + + -------------------------- + -- Machine_State_Length -- + -------------------------- + + function Machine_State_Length + return System.Storage_Elements.Storage_Offset + is + begin + return MState'Max_Size_In_Storage_Elements; + end Machine_State_Length; + + --------------- + -- Pop_Frame -- + --------------- + + procedure Pop_Frame + (M : Machine_State; + Info : Subprogram_Info_Type) + is + MS : constant MState_Ptr := To_MState_Ptr (M); + PL : Prolog_Type; + + SOC_Ptr : Uns32; + -- Pointer to stack location after last SOC push + + Rtn_Ptr : Uns32; + -- Pointer to stack location containing return address + + begin + Analyze_Prolog (Info, PL); + + -- Case of frame register, use EBP, safer than ESP + + if PL.Frame_Reg then + SOC_Ptr := MS.Regs (ebp) - PL.Frame_Length; + Rtn_Ptr := MS.Regs (ebp) + 4; + MS.Regs (ebp) := To_Uns32_Ptr (MS.Regs (ebp)).all; + + -- No frame pointer, use ESP, and hope we have it exactly right! + + else + SOC_Ptr := MS.Regs (esp); + Rtn_Ptr := SOC_Ptr + PL.Frame_Length; + end if; + + -- Get saved values of SOC registers + + for J in reverse 1 .. PL.Num_SOC_Push loop + MS.Regs (PL.SOC_Push_Regs (J)) := To_Uns32_Ptr (SOC_Ptr).all; + SOC_Ptr := SOC_Ptr + 4; + end loop; + + MS.eip := To_Uns32_Ptr (Rtn_Ptr).all; + MS.Regs (esp) := Rtn_Ptr + 4; + end Pop_Frame; + + ----------------------- + -- Set_Machine_State -- + ----------------------- + + procedure Set_Machine_State (M : Machine_State) is + N : constant Asm_Output_Operand := No_Output_Operands; + + begin + Asm ("mov %0,%%edx", N, Machine_State'Asm_Input ("r", M)); + + -- At this stage, we have the following situation (note that we + -- are assuming that the -fomit-frame-pointer switch has not been + -- used in compiling this procedure. + + -- (value of M) + -- return point + -- old ebp <------ current ebp/esp value + + -- The values of registers ebx/esi/edi are unchanged from entry + -- so they have the values we want, and %edx points to the parameter + -- value M, so we can store these values directly. + + Asm ("mov %%ebx,4(%%edx)"); -- M.Regs (ebx) + Asm ("mov %%esi,16(%%edx)"); -- M.Regs (esi) + Asm ("mov %%edi,20(%%edx)"); -- M.Regs (edi) + + -- The desired value of ebp is the old value + + Asm ("mov 0(%%ebp),%%eax"); + Asm ("mov %%eax,12(%%edx)"); -- M.Regs (ebp) + + -- The return point is the desired eip value + + Asm ("mov 4(%%ebp),%%eax"); + Asm ("mov %%eax,(%%edx)"); -- M.eip + + -- Finally, the desired %esp value is the value at the point of + -- call to this routine *before* pushing the parameter value. + + Asm ("lea 12(%%ebp),%%eax"); + Asm ("mov %%eax,8(%%edx)"); -- M.Regs (esp) + end Set_Machine_State; + + ------------------------------ + -- Set_Signal_Machine_State -- + ------------------------------ + + procedure Set_Signal_Machine_State + (M : Machine_State; + Context : System.Address) + is + pragma Warnings (Off, M); + pragma Warnings (Off, Context); + + begin + null; + end Set_Signal_Machine_State; + +end System.Machine_State_Operations; diff --git a/gcc/ada/s-memory-mingw.adb b/gcc/ada/s-memory-mingw.adb new file mode 100644 index 00000000000..a81665a0a59 --- /dev/null +++ b/gcc/ada/s-memory-mingw.adb @@ -0,0 +1,223 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M E M O R Y -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2003 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 version provides ways to limit the amount of used memory for systems +-- that do not have OS support for that. + +-- The amount of available memory available for dynamic allocation is limited +-- by setting the environment variable GNAT_MEMORY_LIMIT to the number of +-- kilobytes that can be used. +-- +-- Windows is currently using this version. + +with Ada.Exceptions; +with System.Soft_Links; + +package body System.Memory is + + use Ada.Exceptions; + use System.Soft_Links; + + function c_malloc (Size : size_t) return System.Address; + pragma Import (C, c_malloc, "malloc"); + + procedure c_free (Ptr : System.Address); + pragma Import (C, c_free, "free"); + + function c_realloc + (Ptr : System.Address; Size : size_t) return System.Address; + pragma Import (C, c_realloc, "realloc"); + + function msize (Ptr : System.Address) return size_t; + pragma Import (C, msize, "_msize"); + + function getenv (Str : String) return System.Address; + pragma Import (C, getenv); + + function atoi (Str : System.Address) return Integer; + pragma Import (C, atoi); + + Available_Memory : size_t := 0; + -- Amount of memory that is available for heap allocations. + -- A value of 0 means that the amount is not yet initialized. + + Msize_Accuracy : constant := 4096; + -- Defines the amount of memory to add to requested allocation sizes, + -- because malloc may return a bigger block than requested. As msize + -- is used when by Free, it must be used on allocation as well. To + -- prevent underflow of available_memory we need to use a reserve. + + procedure Check_Available_Memory (Size : size_t); + -- This routine must be called while holding the task lock. When the + -- memory limit is not yet initialized, it will be set to the value of + -- the GNAT_MEMORY_LIMIT environment variable or to unlimited if that + -- does not exist. If the size is larger than the amount of available + -- memory, the task lock will be freed and a storage_error exception + -- will be raised. + + ----------- + -- Alloc -- + ----------- + + function Alloc (Size : size_t) return System.Address is + Result : System.Address; + Actual_Size : size_t := Size; + + begin + if Size = size_t'Last then + Raise_Exception (Storage_Error'Identity, "object too large"); + end if; + + -- Change size from zero to non-zero. We still want a proper pointer + -- for the zero case because pointers to zero length objects have to + -- be distinct, but we can't just go ahead and allocate zero bytes, + -- since some malloc's return zero for a zero argument. + + if Size = 0 then + Actual_Size := 1; + end if; + + Lock_Task.all; + + if Actual_Size + Msize_Accuracy >= Available_Memory then + Check_Available_Memory (Size + Msize_Accuracy); + end if; + + Result := c_malloc (Actual_Size); + + if Result /= System.Null_Address then + Available_Memory := Available_Memory - msize (Result); + end if; + + Unlock_Task.all; + + if Result = System.Null_Address then + Raise_Exception (Storage_Error'Identity, "heap exhausted"); + end if; + + return Result; + end Alloc; + + ---------------------------- + -- Check_Available_Memory -- + ---------------------------- + + procedure Check_Available_Memory (Size : size_t) is + Gnat_Memory_Limit : System.Address; + + begin + if Available_Memory = 0 then + + -- The amount of available memory hasn't been initialized yet + + Gnat_Memory_Limit := getenv ("GNAT_MEMORY_LIMIT" & ASCII.NUL); + + if Gnat_Memory_Limit /= System.Null_Address then + Available_Memory := + size_t (atoi (Gnat_Memory_Limit)) * 1024 + Msize_Accuracy; + else + Available_Memory := size_t'Last; + end if; + end if; + + if Size >= Available_Memory then + + -- There is a memory overflow + + Unlock_Task.all; + Raise_Exception + (Storage_Error'Identity, "heap memory limit exceeded"); + end if; + end Check_Available_Memory; + + ---------- + -- Free -- + ---------- + + procedure Free (Ptr : System.Address) is + begin + Lock_Task.all; + + if Ptr /= System.Null_Address then + Available_Memory := Available_Memory + msize (Ptr); + end if; + + c_free (Ptr); + + Unlock_Task.all; + end Free; + + ------------- + -- Realloc -- + ------------- + + function Realloc + (Ptr : System.Address; + Size : size_t) + return System.Address + is + Result : System.Address; + Actual_Size : constant size_t := Size; + Old_Size : size_t; + + begin + if Size = size_t'Last then + Raise_Exception (Storage_Error'Identity, "object too large"); + end if; + + Lock_Task.all; + + Old_Size := msize (Ptr); + + -- Conservative check - no need to try to be precise here + + if Size + Msize_Accuracy >= Available_Memory then + Check_Available_Memory (Size + Msize_Accuracy); + end if; + + Result := c_realloc (Ptr, Actual_Size); + + if Result /= System.Null_Address then + Available_Memory := Available_Memory + Old_Size - msize (Result); + end if; + + Unlock_Task.all; + + if Result = System.Null_Address then + Raise_Exception (Storage_Error'Identity, "heap exhausted"); + end if; + + return Result; + end Realloc; + +end System.Memory; diff --git a/gcc/ada/s-osinte-aix-fsu.ads b/gcc/ada/s-osinte-aix-fsu.ads new file mode 100644 index 00000000000..7ea96a83299 --- /dev/null +++ b/gcc/ada/s-osinte-aix-fsu.ads @@ -0,0 +1,589 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 a AIX (FSU THREADS) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + -- pragma Elaborate_Body; + + pragma Linker_Options ("-lgthreads"); + pragma Linker_Options ("-lmalloc"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 78; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 63; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + SIGCLD : constant := 20; -- alias for SIGCHLD + SIGCHLD : constant := 20; -- child status change + SIGPWR : constant := 29; -- power-fail restart + SIGWINCH : constant := 28; -- window size change + SIGURG : constant := 16; -- urgent condition on IO channel + SIGPOLL : constant := 23; -- pollable event occurred + SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGVTALRM : constant := 34; -- virtual timer expired + SIGPROF : constant := 32; -- profiling timer expired + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGWAITING : constant := 39; -- m:n scheduling + + -- the following signals are AIX specific + SIGMSG : constant := 27; -- input data is in the ring buffer + SIGDANGER : constant := 33; -- system crash imminent + SIGMIGRATE : constant := 35; -- migrate process + SIGPRE : constant := 36; -- programming exception + SIGVIRT : constant := 37; -- AIX virtual time alarm + SIGALRM1 : constant := 38; -- m:n condition variables + SIGKAP : constant := 60; -- keep alive poll from native keyboard + SIGGRANT : constant := SIGKAP; -- monitor mode granted + SIGRETRACT : constant := 61; -- monitor mode should be relinguished + SIGSOUND : constant := 62; -- sound control has completed + SIGSAK : constant := 63; -- secure attention key + + SIGADAABORT : constant := SIGABRT; + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := + (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); + Reserved : constant Signal_Set := + (SIGKILL, SIGSTOP, SIGALRM, SIGWAITING); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SA_SIGINFO : constant := 16#0100#; + + SIG_BLOCK : constant := 0; + SIG_UNBLOCK : constant := 1; + SIG_SETMASK : constant := 2; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "_internal_sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates wether time slicing is supported (i.e FSU threads have been + -- compiled with DEF_RR) + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timeval is private; + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 0; + SCHED_RR : constant := 1; + SCHED_OTHER : constant := 2; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + -- lwp_self does not exist on this thread library, revert to pthread_self + -- which is the closest approximation (with getpid). This function is + -- needed to share 7staprop.adb across POSIX-like targets. + pragma Import (C, lwp_self, "pthread_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + + ----------- + -- Stack -- + ----------- + + Stack_Base_Available : constant Boolean := True; + -- Indicates wether the stack base is available on this target. + -- This allows us to share s-osinte.adb between all the FSU run time. + -- Note that this value can only be true if pthread_t has a complete + -- definition that corresponds exactly to the C header files. + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- returns the stack base of the specified thread. + -- Only call this function when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- returns the size of a page, or 0 if this is not relevant on this + -- target + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + + PROT_ON : constant := PROT_READ; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + -- FSU_THREADS requires pthread_init, which is nonstandard + -- and this should be invoked during the elaboration of s-taprop.adb + pragma Import (C, pthread_init, "pthread_init"); + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + -- FSU_THREADS has a nonstandard sigwait + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + -- FSU threads does not have pthread_sigmask. Instead, it redefines + -- sigprocmask and then uses a special syscall API to call the system + -- version. Doing syscalls on AiX is very difficult, so we rename the + -- pthread version instead. + + type sigset_t_ptr is access all sigset_t; + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask, "_internal_sigprocmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + -- FSU_THREADS has nonstandard pthread_mutex_lock + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + -- FSU_THREADS has nonstandard pthread_mutex_lock + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + -- FSU_THREADS has a nonstandard pthread_cond_wait + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + -- FSU_THREADS has a nonstandard pthread_cond_timedwait + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_PROTECT : constant := 2; + PTHREAD_PRIO_INHERIT : constant := 1; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import + (C, pthread_mutexattr_setprioceiling, + "pthread_mutexattr_setprio_ceiling"); + + type struct_sched_param is record + sched_priority : int; -- scheduling priority + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + -- FSU_THREADS does not have pthread_setschedparam + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched"); + + function sched_yield return int; + -- FSU_THREADS does not have sched_yield; + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + -- FSU_THREADS has a nonstandard pthread_attr_setdetachstate + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + -- FSU_THREADS has a nonstandard pthread_getspecific + + type destructor_pointer is access procedure (arg : System.Address); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + +private + + type sigset_t is record + losigs : unsigned_long; + hisigs : unsigned_long; + end record; + pragma Convention (C_Pass_By_Copy, sigset_t); + + type pid_t is new int; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + + type struct_timeval is record + tv_sec : long; + tv_usec : long; + end record; + pragma Convention (C, struct_timeval); + + type pthread_attr_t is record + flags : int; + stacksize : int; + contentionscope : int; + inheritsched : int; + detachstate : int; + sched : int; + prio : int; + starttime : timespec; + deadline : timespec; + period : timespec; + end record; + pragma Convention (C_Pass_By_Copy, pthread_attr_t); + + type pthread_condattr_t is record + flags : int; + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_mutexattr_t is record + flags : int; + prio_ceiling : int; + protocol : int; + end record; + pragma Convention (C, pthread_mutexattr_t); + + type sigjmp_buf is array (Integer range 0 .. 63) of int; + + type pthread_t_struct is record + context : sigjmp_buf; + pbody : sigjmp_buf; + errno : int; + ret : int; + stack_base : System.Address; + end record; + pragma Convention (C, pthread_t_struct); + + type pthread_t is access all pthread_t_struct; + + type queue_t is record + head : System.Address; + tail : System.Address; + end record; + pragma Convention (C, queue_t); + + type pthread_mutex_t is record + queue : queue_t; + lock : plain_char; + owner : System.Address; + flags : int; + prio_ceiling : int; + protocol : int; + prev_max_ceiling_prio : int; + end record; + pragma Convention (C, pthread_mutex_t); + + type pthread_cond_t is record + queue : queue_t; + flags : int; + waiters : int; + mutex : System.Address; + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new int; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-aix.adb b/gcc/ada/s-osinte-aix.adb new file mode 100644 index 00000000000..5fe86b1d606 --- /dev/null +++ b/gcc/ada/s-osinte-aix.adb @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- 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) 1997-2002, 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 AIX (Native) version of this package + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Interfaces.C; + +package body System.OS_Interface is + + use Interfaces.C; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + function To_Duration (TV : struct_timeval) return Duration is + begin + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end To_Duration; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ---------------- + -- To_Timeval -- + ---------------- + + function To_Timeval (D : Duration) return struct_timeval is + S : long; + F : Duration; + + begin + S := long (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return + struct_timeval' + (tv_sec => S, + tv_usec => long (Long_Long_Integer (F * 10#1#E6))); + end To_Timeval; + + ------------------- + -- clock_gettime -- + ------------------- + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) + return int + is + pragma Warnings (Off, clock_id); + + Result : int; + tv : aliased struct_timeval; + + function gettimeofday + (tv : access struct_timeval; + tz : System.Address := System.Null_Address) + return int; + pragma Import (C, gettimeofday, "gettimeofday"); + + begin + Result := gettimeofday (tv'Unchecked_Access); + tp.all := To_Timespec (To_Duration (tv)); + return Result; + end clock_gettime; + + ----------------- + -- sched_yield -- + ----------------- + + -- AIX Thread does not have sched_yield; + + function sched_yield return int is + + procedure pthread_yield; + pragma Import (C, pthread_yield, "sched_yield"); + + begin + pthread_yield; + return 0; + end sched_yield; + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + + begin + return Null_Address; + end Get_Stack_Base; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-aix.ads b/gcc/ada/s-osinte-aix.ads new file mode 100644 index 00000000000..c761eb8a048 --- /dev/null +++ b/gcc/ada/s-osinte-aix.ads @@ -0,0 +1,586 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 a AIX (Native THREADS) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lpthreads"); + pragma Linker_Options ("-lc_r"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 78; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 63; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + SIGCLD : constant := 20; -- alias for SIGCHLD + SIGCHLD : constant := 20; -- child status change + SIGPWR : constant := 29; -- power-fail restart + SIGWINCH : constant := 28; -- window size change + SIGURG : constant := 16; -- urgent condition on IO channel + SIGPOLL : constant := 23; -- pollable event occurred + SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGVTALRM : constant := 34; -- virtual timer expired + SIGPROF : constant := 32; -- profiling timer expired + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGWAITING : constant := 39; -- m:n scheduling + + -- the following signals are AIX specific + SIGMSG : constant := 27; -- input data is in the ring buffer + SIGDANGER : constant := 33; -- system crash imminent + SIGMIGRATE : constant := 35; -- migrate process + SIGPRE : constant := 36; -- programming exception + SIGVIRT : constant := 37; -- AIX virtual time alarm + SIGALRM1 : constant := 38; -- m:n condition variables + SIGKAP : constant := 60; -- keep alive poll from native keyboard + SIGGRANT : constant := SIGKAP; -- monitor mode granted + SIGRETRACT : constant := 61; -- monitor mode should be relinguished + SIGSOUND : constant := 62; -- sound control has completed + SIGSAK : constant := 63; -- secure attention key + + SIGADAABORT : constant := SIGTERM; + -- Note: on other targets, we usually use SIGABRT, but on AiX, it + -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM. + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := + (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); + Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SA_SIGINFO : constant := 16#0100#; + + SIG_BLOCK : constant := 0; + SIG_UNBLOCK : constant := 1; + SIG_SETMASK : constant := 2; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := False; + -- Indicates wether time slicing is supported + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + -- AiX threads don't have clock_gettime + -- We instead use gettimeofday() + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timezone is record + tz_minuteswest : int; + tz_dsttime : int; + end record; + pragma Convention (C, struct_timezone); + type struct_timezone_ptr is access all struct_timezone; + + type struct_timeval is private; + -- This is needed on systems that do not have clock_gettime() + -- but do have gettimeofday(). + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 1; + SCHED_RR : constant := 2; + SCHED_OTHER : constant := 0; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + pragma Import (C, lwp_self, "thread_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + + ----------- + -- Stack -- + ----------- + + Stack_Base_Available : constant Boolean := False; + -- Indicates wether the stack base is available on this target. + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- returns the stack base of the specified thread. + -- Only call this function when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- returns the size of a page, or 0 if this is not relevant on this + -- target + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + + PROT_ON : constant := PROT_READ; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + -- Though not documented, pthread_init *must* be called before any other + -- pthread call + + procedure pthread_init; + pragma Import (C, pthread_init, "pthread_init"); + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Import (C, sigwait, "sigwait"); + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + type sigset_t_ptr is access all sigset_t; + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask, "sigthreadmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + ---------------------------- + -- POSIX.1c Section 13 -- + ---------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_PROTECT : constant := 0; + PTHREAD_PRIO_INHERIT : constant := 0; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import (C, pthread_mutexattr_setprioceiling); + + type Array_5_Int is array (0 .. 5) of int; + type struct_sched_param is record + sched_priority : int; + sched_policy : int; + sched_reserved : Array_5_Int; + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy); + + function pthread_attr_setschedparam + (attr : access pthread_attr_t; + sched_param : int) return int; + pragma Import (C, pthread_attr_setschedparam); + + function sched_yield return int; + -- AiX have a nonstandard sched_yield. + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) + return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access + procedure (arg : System.Address); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + +private + + type sigset_t is record + losigs : unsigned_long; + hisigs : unsigned_long; + end record; + pragma Convention (C_Pass_By_Copy, sigset_t); + + type pid_t is new int; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + + type struct_timeval is record + tv_sec : long; + tv_usec : long; + end record; + pragma Convention (C, struct_timeval); + + type pthread_attr_t is new System.Address; + pragma Convention (C, pthread_attr_t); + -- typedef struct __pt_attr *pthread_attr_t; + + type pthread_condattr_t is new System.Address; + pragma Convention (C, pthread_condattr_t); + -- typedef struct __pt_attr *pthread_condattr_t; + + type pthread_mutexattr_t is new System.Address; + pragma Convention (C, pthread_mutexattr_t); + -- typedef struct __pt_attr *pthread_mutexattr_t; + + type pthread_t is new System.Address; + pragma Convention (C, pthread_t); + -- typedef void *pthread_t; + + type ptq_queue; + type ptq_queue_ptr is access all ptq_queue; + + type ptq_queue is record + ptq_next : ptq_queue_ptr; + ptq_prev : ptq_queue_ptr; + end record; + + type Array_3_Int is array (0 .. 3) of int; + type pthread_mutex_t is record + link : ptq_queue; + ptmtx_lock : int; + ptmtx_flags : long; + protocol : int; + prioceiling : int; + ptmtx_owner : pthread_t; + mtx_id : int; + attr : pthread_attr_t; + mtx_kind : int; + lock_cpt : int; + reserved : Array_3_Int; + end record; + pragma Convention (C, pthread_mutex_t); + type pthread_mutex_t_ptr is access pthread_mutex_t; + + type pthread_cond_t is record + link : ptq_queue; + ptcv_lock : int; + ptcv_flags : long; + ptcv_waiters : ptq_queue; + cv_id : int; + attr : pthread_attr_t; + mutex : pthread_mutex_t_ptr; + cptwait : int; + reserved : int; + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new unsigned; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-dummy.ads b/gcc/ada/s-osinte-dummy.ads new file mode 100644 index 00000000000..f33370dd43d --- /dev/null +++ b/gcc/ada/s-osinte-dummy.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 no tasking version + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +package System.OS_Interface is + pragma Preelaborate; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 2; + type Signal is new Integer range 0 .. Max_Interrupt; + + type sigset_t is new Integer; + type Thread_Id is new Integer; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-freebsd.adb b/gcc/ada/s-osinte-freebsd.adb new file mode 100644 index 00000000000..466a15d2b33 --- /dev/null +++ b/gcc/ada/s-osinte-freebsd.adb @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUNTIME 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-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. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is the FreeBSD THREADS version of this package + +with Interfaces.C; use Interfaces.C; + +package body System.OS_Interface is + + function Errno return int is + type int_ptr is access all int; + + function internal_errno return int_ptr; + pragma Import (C, internal_errno, "__error"); + begin + return (internal_errno.all); + end Errno; + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Unreferenced (thread); + begin + return (0); + end Get_Stack_Base; + + procedure pthread_init is + begin + null; + end pthread_init; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; + 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'(ts_sec => S, + ts_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + + 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; + + 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; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-freebsd.ads b/gcc/ada/s-osinte-freebsd.ads new file mode 100644 index 00000000000..13e545871c1 --- /dev/null +++ b/gcc/ada/s-osinte-freebsd.ads @@ -0,0 +1,644 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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. It is -- +-- now maintained by Ada Core Technologies Inc. in cooperation with Florida -- +-- State University (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +-- This is the FreeBSD PTHREADS version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-pthread"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function Errno return int; + pragma Inline (Errno); + + EAGAIN : constant := 35; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 60; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 31; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGURG : constant := 16; -- urgent condition on IO channel + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGCLD : constant := 20; -- alias for SIGCHLD + SIGCHLD : constant := 20; -- child status change + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGWINCH : constant := 28; -- window size change + SIGINFO : constant := 29; -- information request (NetBSD/FreeBSD) + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + + SIGADAABORT : constant := SIGABRT; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + type Signal_Set is array (Natural range <>) of Signal; + + -- Interrupts that must be unmasked at all times. FreeBSD + -- pthreads will not allow an application to mask out any + -- interrupt needed by the threads library. + Unmasked : constant Signal_Set := + (SIGTRAP, SIGBUS, SIGTTIN, SIGTTOU, SIGTSTP); + + -- FreeBSD will uses SIGPROF for timing. Do not allow a + -- handler to attach to this signal. + Reserved : constant Signal_Set := (0 .. 0 => SIGPROF); + + type sigset_t is private; + + function sigaddset + (set : access sigset_t; + sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset + (set : access sigset_t; + sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember + (set : access sigset_t; + sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + -- sigcontext is architecture dependent, so define it private + type struct_sigcontext is private; + + type old_struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, old_struct_sigaction); + + type new_struct_sigaction is record + sa_handler : System.Address; + sa_flags : int; + sa_mask : sigset_t; + end record; + pragma Convention (C, new_struct_sigaction); + + subtype struct_sigaction is new_struct_sigaction; + type struct_sigaction_ptr is access all struct_sigaction; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + SA_SIGINFO : constant := 16#0040#; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates wether time slicing is supported (i.e SCHED_RR is supported) + + type timespec is private; + + function nanosleep (rqtp, rmtp : access timespec) return int; + pragma Import (C, nanosleep, "nanosleep"); + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) + return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timezone is record + tz_minuteswest : int; + tz_dsttime : int; + end record; + pragma Convention (C, struct_timezone); + type struct_timeval is private; + -- This is needed on systems that do not have clock_gettime() + -- but do have gettimeofday(). + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + function gettimeofday + (tv : access struct_timeval; + tz : System.Address) return int; + pragma Import (C, gettimeofday, "gettimeofday"); + + procedure usleep (useconds : unsigned_long); + pragma Import (C, usleep, "usleep"); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 1; + SCHED_OTHER : constant := 2; + SCHED_RR : constant := 3; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + Self_PID : constant pid_t; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + -- lwp_self does not exist on this thread library, revert to pthread_self + -- which is the closest approximation (with getpid). This function is + -- needed to share 7staprop.adb across POSIX-like targets. + pragma Import (C, lwp_self, "pthread_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + PTHREAD_CREATE_JOINABLE : constant := 0; + + ----------- + -- Stack -- + ----------- + + Stack_Base_Available : constant Boolean := False; + -- Indicates wether the stack base is available on this target. + -- This allows us to share s-osinte.adb between all the FSU run time. + -- Note that this value can only be true if pthread_t has a complete + -- definition that corresponds exactly to the C header files. + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- returns the stack base of the specified thread. + -- Only call this function when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- returns the size of a page, or 0 if this is not relevant on this + -- target + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + + PROT_ON : constant := PROT_NONE; + PROT_OFF : constant := PROT_ALL; + + function mprotect + (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + ----------------------------------------- + -- Nonstandard Thread Initialization -- + ----------------------------------------- + -- FSU_THREADS requires pthread_init, which is nonstandard + -- and this should be invoked during the elaboration of s-taprop.adb + -- + -- FreeBSD does not require this so we provide an empty Ada body. + procedure pthread_init; + + --------------------------- + -- POSIX.1c Section 3 -- + --------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Import (C, sigwait, "sigwait"); + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + type sigset_t_ptr is access all sigset_t; + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + + ---------------------------- + -- POSIX.1c Section 11 -- + ---------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + ---------------------------- + -- POSIX.1c Section 13 -- + ---------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_PROTECT : constant := 2; + PTHREAD_PRIO_INHERIT : constant := 1; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import + (C, pthread_mutexattr_setprotocol, "pthread_mutexattr_setprotocol"); + + function pthread_mutexattr_getprotocol + (attr : access pthread_mutexattr_t; + protocol : access int) return int; + pragma Import + (C, pthread_mutexattr_getprotocol, "pthread_mutexattr_getprotocol"); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import + (C, pthread_mutexattr_setprioceiling, + "pthread_mutexattr_setprioceiling"); + + function pthread_mutexattr_getprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : access int) return int; + pragma Import + (C, pthread_mutexattr_getprioceiling, + "pthread_mutexattr_getprioceiling"); + + type struct_sched_param is record + sched_priority : int; + end record; + pragma Convention (C, struct_sched_param); + + function pthread_getschedparam + (thread : pthread_t; + policy : access int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_getschedparam, "pthread_getschedparam"); + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_getscope + (attr : access pthread_attr_t; + contentionscope : access int) return int; + pragma Import (C, pthread_attr_getscope, "pthread_attr_getscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import + (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched"); + + function pthread_attr_getinheritsched + (attr : access pthread_attr_t; + inheritsched : access int) return int; + pragma Import + (C, pthread_attr_getinheritsched, "pthread_attr_getinheritsched"); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy, + "pthread_attr_setschedpolicy"); + + function pthread_attr_getschedpolicy + (attr : access pthread_attr_t; + policy : access int) return int; + pragma Import (C, pthread_attr_getschedpolicy, + "pthread_attr_getschedpolicy"); + + function pthread_attr_setschedparam + (attr : access pthread_attr_t; + sched_param : int) return int; + pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam"); + + function pthread_attr_getschedparam + (attr : access pthread_attr_t; + sched_param : access int) return int; + pragma Import (C, pthread_attr_getschedparam, "pthread_attr_getschedparam"); + + function sched_yield return int; + pragma Import (C, sched_yield, "pthread_yield"); + + ----------------------------- + -- P1003.1c - Section 16 -- + ----------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import + (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate"); + + function pthread_attr_getdetachstate + (attr : access pthread_attr_t; + detachstate : access int) return int; + pragma Import + (C, pthread_attr_getdetachstate, "pthread_attr_getdetachstate"); + + function pthread_attr_getstacksize + (attr : access pthread_attr_t; + stacksize : access size_t) return int; + pragma Import + (C, pthread_attr_getstacksize, "pthread_attr_getstacksize"); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import + (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + function pthread_detach (thread : pthread_t) return int; + pragma Import (C, pthread_detach, "pthread_detach"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + ---------------------------- + -- POSIX.1c Section 17 -- + ---------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access + procedure (arg : System.Address); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + + -------------------------------------- + -- Non-portable pthread functions -- + -------------------------------------- + + function pthread_set_name_np + (thread : pthread_t; + name : System.Address) return int; + pragma Import (C, pthread_set_name_np, "pthread_set_name_np"); + +private + + type sigset_t is array (1 .. 4) of unsigned; + + -- In FreeBSD the component sa_handler turns out to + -- be one a union type, and the selector is a macro: + -- #define sa_handler __sigaction_u._handler + -- #define sa_sigaction __sigaction_u._sigaction + + -- Should we add a signal_context type here ? + -- How could it be done independent of the CPU architecture ? + -- sigcontext type is opaque, so it is architecturally neutral. + -- It is always passed as an access type, so define it as an empty record + -- since the contents are not used anywhere. + type struct_sigcontext is null record; + pragma Convention (C, struct_sigcontext); + + type pid_t is new int; + Self_PID : constant pid_t := 0; + + type time_t is new long; + + type timespec is record + ts_sec : time_t; + ts_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + + type struct_timeval is record + tv_sec : long; + tv_usec : long; + end record; + pragma Convention (C, struct_timeval); + + type pthread_t is new System.Address; + type pthread_attr_t is new System.Address; + type pthread_mutex_t is new System.Address; + type pthread_mutexattr_t is new System.Address; + type pthread_cond_t is new System.Address; + type pthread_condattr_t is new System.Address; + type pthread_key_t is new int; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-fsu.adb b/gcc/ada/s-osinte-fsu.adb new file mode 100644 index 00000000000..b646a789b50 --- /dev/null +++ b/gcc/ada/s-osinte-fsu.adb @@ -0,0 +1,366 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-osinte-hpux-dce.adb b/gcc/ada/s-osinte-hpux-dce.adb new file mode 100644 index 00000000000..dcd169ccf62 --- /dev/null +++ b/gcc/ada/s-osinte-hpux-dce.adb @@ -0,0 +1,564 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 DCE version of this package. +-- Currently HP-UX and SNI use this file + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +with Interfaces.C; use Interfaces.C; + +package body System.OS_Interface is + + ----------------- + -- 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; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + function To_Duration (TV : struct_timeval) return Duration is + begin + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end To_Duration; + + function To_Timeval (D : Duration) return struct_timeval is + S : time_t; + F : Duration; + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return + struct_timeval' + (tv_sec => S, + tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); + end To_Timeval; + + --------------------------- + -- POSIX.1c Section 3 -- + --------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) + return int + is + Result : int; + + begin + Result := sigwait (set); + + if Result = -1 then + sig.all := 0; + return errno; + end if; + + sig.all := Signal (Result); + return 0; + end sigwait; + + -- DCE_THREADS does not have pthread_kill. Instead, we just ignore it. + + function pthread_kill (thread : pthread_t; sig : Signal) return int is + pragma Unreferenced (thread, sig); + begin + return 0; + end pthread_kill; + + ---------------------------- + -- POSIX.1c Section 11 -- + ---------------------------- + + -- For all the following functions, DCE Threads has a non standard + -- behavior: it sets errno but the standard Posix requires it to be + -- returned. + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) + return int + is + function pthread_mutexattr_create + (attr : access pthread_mutexattr_t) + return int; + pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create"); + + begin + if pthread_mutexattr_create (attr) /= 0 then + return errno; + else + return 0; + end if; + end pthread_mutexattr_init; + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) + return int + is + function pthread_mutexattr_delete + (attr : access pthread_mutexattr_t) + return int; + pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete"); + + begin + if pthread_mutexattr_delete (attr) /= 0 then + return errno; + else + return 0; + end if; + end pthread_mutexattr_destroy; + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) + return int + is + function pthread_mutex_init_base + (mutex : access pthread_mutex_t; + attr : pthread_mutexattr_t) + return int; + pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init"); + + begin + if pthread_mutex_init_base (mutex, attr.all) /= 0 then + return errno; + else + return 0; + end if; + end pthread_mutex_init; + + function pthread_mutex_destroy + (mutex : access pthread_mutex_t) + return int + is + function pthread_mutex_destroy_base + (mutex : access pthread_mutex_t) + return int; + pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy"); + + begin + if pthread_mutex_destroy_base (mutex) /= 0 then + return errno; + else + return 0; + end if; + end pthread_mutex_destroy; + + 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"); + + begin + if pthread_mutex_lock_base (mutex) /= 0 then + return errno; + else + return 0; + end if; + end pthread_mutex_lock; + + 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"); + + begin + if pthread_mutex_unlock_base (mutex) /= 0 then + return errno; + else + return 0; + end if; + end pthread_mutex_unlock; + + function pthread_condattr_init + (attr : access pthread_condattr_t) + return int + is + function pthread_condattr_create + (attr : access pthread_condattr_t) + return int; + pragma Import (C, pthread_condattr_create, "pthread_condattr_create"); + + begin + if pthread_condattr_create (attr) /= 0 then + return errno; + else + return 0; + end if; + end pthread_condattr_init; + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) + return int + is + function pthread_condattr_delete + (attr : access pthread_condattr_t) + return int; + pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete"); + + begin + if pthread_condattr_delete (attr) /= 0 then + return errno; + else + return 0; + end if; + end pthread_condattr_destroy; + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) + return int + is + function pthread_cond_init_base + (cond : access pthread_cond_t; + attr : pthread_condattr_t) + return int; + pragma Import (C, pthread_cond_init_base, "pthread_cond_init"); + + begin + if pthread_cond_init_base (cond, attr.all) /= 0 then + return errno; + else + return 0; + end if; + end pthread_cond_init; + + function pthread_cond_destroy + (cond : access pthread_cond_t) + return int + is + function pthread_cond_destroy_base + (cond : access pthread_cond_t) + return int; + pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy"); + + begin + if pthread_cond_destroy_base (cond) /= 0 then + return errno; + else + return 0; + end if; + end pthread_cond_destroy; + + function pthread_cond_signal + (cond : access pthread_cond_t) + return int + is + function pthread_cond_signal_base + (cond : access pthread_cond_t) + return int; + pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal"); + + begin + if pthread_cond_signal_base (cond) /= 0 then + return errno; + else + return 0; + end if; + end pthread_cond_signal; + + 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"); + + begin + if pthread_cond_wait_base (cond, mutex) /= 0 then + return errno; + else + return 0; + end if; + end pthread_cond_wait; + + 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"); + + begin + if pthread_cond_timedwait_base (cond, mutex, abstime) /= 0 then + if errno = EAGAIN then + return ETIMEDOUT; + else + return errno; + end if; + else + return 0; + end if; + end pthread_cond_timedwait; + + ---------------------------- + -- POSIX.1c Section 13 -- + ---------------------------- + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int + is + function pthread_setscheduler + (thread : pthread_t; + policy : int; + priority : int) + return int; + pragma Import (C, pthread_setscheduler, "pthread_setscheduler"); + + begin + if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then + return errno; + else + return 0; + end if; + end pthread_setschedparam; + + function sched_yield return int is + procedure pthread_yield; + pragma Import (C, pthread_yield, "pthread_yield"); + begin + pthread_yield; + return 0; + end sched_yield; + + ----------------------------- + -- P1003.1c - Section 16 -- + ----------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int + is + function pthread_attr_create + (attributes : access pthread_attr_t) + return int; + pragma Import (C, pthread_attr_create, "pthread_attr_create"); + + begin + if pthread_attr_create (attributes) /= 0 then + return errno; + else + return 0; + end if; + end pthread_attr_init; + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int + is + function pthread_attr_delete + (attributes : access pthread_attr_t) + return int; + pragma Import (C, pthread_attr_delete, "pthread_attr_delete"); + + begin + if pthread_attr_delete (attributes) /= 0 then + return errno; + else + return 0; + end if; + end pthread_attr_destroy; + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int + is + function pthread_attr_setstacksize_base + (attr : access pthread_attr_t; + stacksize : size_t) + return int; + pragma Import (C, pthread_attr_setstacksize_base, + "pthread_attr_setstacksize"); + + begin + if pthread_attr_setstacksize_base (attr, stacksize) /= 0 then + return errno; + else + return 0; + end if; + end pthread_attr_setstacksize; + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int + is + function pthread_create_base + (thread : access pthread_t; + attributes : pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) + return int; + pragma Import (C, pthread_create_base, "pthread_create"); + + begin + if pthread_create_base + (thread, attributes.all, start_routine, arg) /= 0 + then + return errno; + else + return 0; + end if; + end pthread_create; + + ---------------------------- + -- POSIX.1c Section 17 -- + ---------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int + is + function pthread_setspecific_base + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific_base, "pthread_setspecific"); + + begin + if pthread_setspecific_base (key, value) /= 0 then + return errno; + else + return 0; + end if; + end pthread_setspecific; + + 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"); + Addr : aliased System.Address; + + begin + if pthread_getspecific_base (key, Addr'Access) /= 0 then + return System.Null_Address; + else + return Addr; + end if; + end pthread_getspecific; + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int + is + function pthread_keycreate + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_keycreate, "pthread_keycreate"); + + begin + if pthread_keycreate (key, destructor) /= 0 then + return errno; + else + return 0; + end if; + end pthread_key_create; + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + + begin + return Null_Address; + end Get_Stack_Base; + + procedure pthread_init is + begin + null; + end pthread_init; + + function intr_attach (sig : int; handler : isr_address) return long is + function c_signal (sig : int; handler : isr_address) return long; + pragma Import (C, c_signal, "signal"); + + begin + return c_signal (sig, handler); + end intr_attach; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-hpux-dce.ads b/gcc/ada/s-osinte-hpux-dce.ads new file mode 100644 index 00000000000..18de527be15 --- /dev/null +++ b/gcc/ada/s-osinte-hpux-dce.ads @@ -0,0 +1,495 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 HP-UX version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lcma"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIME : constant := 52; + ETIMEDOUT : constant := 238; + + FUNC_ERR : constant := -1; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 44; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + SIGCLD : constant := 18; -- alias for SIGCHLD + SIGCHLD : constant := 18; -- child status change + SIGPWR : constant := 19; -- power-fail restart + SIGVTALRM : constant := 20; -- virtual timer alarm + SIGPROF : constant := 21; -- profiling timer alarm + SIGIO : constant := 22; -- asynchronous I/O + SIGPOLL : constant := 22; -- pollable event occurred + SIGWINCH : constant := 23; -- window size change + SIGSTOP : constant := 24; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 25; -- user stop requested from tty + SIGCONT : constant := 26; -- stopped process has been continued + SIGTTIN : constant := 27; -- background tty read attempted + SIGTTOU : constant := 28; -- background tty write attempted + SIGURG : constant := 29; -- urgent condition on IO channel + SIGLOST : constant := 30; -- remote lock lost (NFS) + SIGDIL : constant := 32; -- DIL signal + SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit) + SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit) + + SIGADAABORT : constant := SIGABRT; + -- Note: on other targets, we usually use SIGABRT, but on HP/UX, it + -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM. + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := + (SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP); + + Reserved : constant Signal_Set := (SIGKILL, SIGSTOP); + + type sigset_t is private; + + type isr_address is access procedure (sig : int); + + function intr_attach (sig : int; handler : isr_address) return long; + + Intr_Attach_Reset : constant Boolean := True; + -- True if intr_attach is reset after an interrupt handler is called + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type Signal_Handler is access procedure (signo : Signal); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SA_RESTART : constant := 16#40#; + SA_SIGINFO : constant := 16#10#; + + SIG_BLOCK : constant := 0; + SIG_UNBLOCK : constant := 1; + SIG_SETMASK : constant := 2; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + SIG_ERR : constant := -1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + type timespec is private; + + function nanosleep (rqtp, rmtp : access timespec) return int; + pragma Import (C, nanosleep); + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function Clock_Gettime + (Clock_Id : clockid_t; Tp : access timespec) return int; + pragma Import (C, Clock_Gettime); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timeval is private; + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 0; + SCHED_RR : constant := 1; + SCHED_OTHER : constant := 2; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + ----------- + -- Stack -- + ----------- + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- This is a dummy procedure to share some GNULLI files + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + pragma Inline (pthread_init); + -- This is a dummy procedure to share some GNULLI files + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait (set : access sigset_t) return int; + pragma Import (C, sigwait, "cma_sigwait"); + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Inline (sigwait); + -- DCE_THREADS has a nonstandard sigwait + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Inline (pthread_kill); + -- DCE_THREADS doesn't have pthread_kill + + type sigset_t_ptr is access all sigset_t; + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + -- DCE THREADS does not have pthread_sigmask. Instead, it uses + -- sigprocmask to do the signal handling when the thread library is + -- sucked in. + pragma Import (C, pthread_sigmask, "sigprocmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + -- DCE_THREADS has a nonstandard pthread_mutexattr_init. + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + -- DCE_THREADS has a nonstandard pthread_mutexattr_destroy + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + -- DCE_THREADS has a nonstandard pthread_mutex_init + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + -- DCE_THREADS has a nonstandard pthread_mutex_destroy + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Inline (pthread_mutex_lock); + -- DCE_THREADS has nonstandard pthread_mutex_lock + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Inline (pthread_mutex_unlock); + -- DCE_THREADS has nonstandard pthread_mutex_lock + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + -- DCE_THREADS has nonstandard pthread_condattr_init + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + -- DCE_THREADS has nonstandard pthread_condattr_destroy + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + -- DCE_THREADS has nonstandard pthread_cond_init + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + -- DCE_THREADS has nonstandard pthread_cond_destroy + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Inline (pthread_cond_signal); + -- DCE_THREADS has nonstandard pthread_cond_signal + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Inline (pthread_cond_wait); + -- DCE_THREADS has a nonstandard pthread_cond_wait + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Inline (pthread_cond_timedwait); + -- DCE_THREADS has a nonstandard pthread_cond_timedwait + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + type struct_sched_param is record + sched_priority : int; -- scheduling priority + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Inline (pthread_setschedparam); + -- DCE_THREADS has a nonstandard pthread_setschedparam + + function sched_yield return int; + pragma Inline (sched_yield); + -- DCE_THREADS has a nonstandard sched_yield + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Inline (pthread_attr_init); + -- DCE_THREADS has a nonstandard pthread_attr_init + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Inline (pthread_attr_destroy); + -- DCE_THREADS has a nonstandard pthread_attr_destroy + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Inline (pthread_attr_setstacksize); + -- DCE_THREADS has a nonstandard pthread_attr_setstacksize + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Inline (pthread_create); + -- DCE_THREADS has a nonstandard pthread_create + + procedure pthread_detach (thread : access pthread_t); + pragma Import (C, pthread_detach); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Inline (pthread_setspecific); + -- DCE_THREADS has a nonstandard pthread_setspecific + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Inline (pthread_getspecific); + -- DCE_THREADS has a nonstandard pthread_getspecific + + type destructor_pointer is access procedure (arg : System.Address); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Inline (pthread_key_create); + -- DCE_THREADS has a nonstandard pthread_key_create + +private + + type array_type_1 is array (Integer range 0 .. 7) of unsigned_long; + type sigset_t is record + X_X_sigbits : array_type_1; + end record; + pragma Convention (C, sigset_t); + + type pid_t is new int; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 1; + + type struct_timeval is record + tv_sec : time_t; + tv_usec : time_t; + end record; + pragma Convention (C, struct_timeval); + + type cma_t_address is new System.Address; + + type cma_t_handle is record + field1 : cma_t_address; + field2 : Short_Integer; + field3 : Short_Integer; + end record; + for cma_t_handle'Size use 64; + + type pthread_attr_t is new cma_t_handle; + pragma Convention (C_Pass_By_Copy, pthread_attr_t); + + type pthread_condattr_t is new cma_t_handle; + pragma Convention (C_Pass_By_Copy, pthread_condattr_t); + + type pthread_mutexattr_t is new cma_t_handle; + pragma Convention (C_Pass_By_Copy, pthread_mutexattr_t); + + type pthread_t is new cma_t_handle; + pragma Convention (C_Pass_By_Copy, pthread_t); + + type pthread_mutex_t is new cma_t_handle; + pragma Convention (C_Pass_By_Copy, pthread_mutex_t); + + type pthread_cond_t is new cma_t_handle; + pragma Convention (C_Pass_By_Copy, pthread_cond_t); + + type pthread_key_t is new int; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-hpux.ads b/gcc/ada/s-osinte-hpux.ads new file mode 100644 index 00000000000..95b093ae7fa --- /dev/null +++ b/gcc/ada/s-osinte-hpux.ads @@ -0,0 +1,556 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 a HPUX 11.0 (Native THREADS) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lpthread"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 238; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 44; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + SIGCLD : constant := 18; -- alias for SIGCHLD + SIGCHLD : constant := 18; -- child status change + SIGPWR : constant := 19; -- power-fail restart + SIGVTALRM : constant := 20; -- virtual timer alarm + SIGPROF : constant := 21; -- profiling timer alarm + SIGIO : constant := 22; -- asynchronous I/O + SIGPOLL : constant := 22; -- pollable event occurred + SIGWINCH : constant := 23; -- window size change + SIGSTOP : constant := 24; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 25; -- user stop requested from tty + SIGCONT : constant := 26; -- stopped process has been continued + SIGTTIN : constant := 27; -- background tty read attempted + SIGTTOU : constant := 28; -- background tty write attempted + SIGURG : constant := 29; -- urgent condition on IO channel + SIGLOST : constant := 30; -- remote lock lost (NFS) + SIGDIL : constant := 32; -- DIL signal + SIGXCPU : constant := 33; -- CPU time limit exceeded (setrlimit) + SIGXFSZ : constant := 34; -- file size limit exceeded (setrlimit) + SIGCANCEL : constant := 35; -- used for pthread cancellation. + SIGGFAULT : constant := 36; -- Graphics framebuffer fault + + SIGADAABORT : constant := SIGABRT; + -- Note: on other targets, we usually use SIGABRT, but on HPUX, it + -- appears that SIGABRT can't be used in sigwait(), so we use SIGTERM. + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := + (SIGABRT, SIGPIPE, SIGBUS, SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, + SIGALRM, SIGVTALRM, SIGIO, SIGCHLD); + + Reserved : constant Signal_Set := (SIGKILL, SIGSTOP); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SA_SIGINFO : constant := 16#10#; + + SIG_BLOCK : constant := 0; + SIG_UNBLOCK : constant := 1; + SIG_SETMASK : constant := 2; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates wether time slicing is supported + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function clock_getres + (clock_id : clockid_t; + res : access timespec) return int; + pragma Import (C, clock_getres, "clock_getres"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timezone is record + tz_minuteswest : int; + tz_dsttime : int; + end record; + pragma Convention (C, struct_timezone); + type struct_timezone_ptr is access all struct_timezone; + + type struct_timeval is private; + -- This is needed on systems that do not have clock_gettime() + -- but do have gettimeofday(). + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 0; + SCHED_RR : constant := 1; + SCHED_OTHER : constant := 2; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + pragma Import (C, lwp_self, "_lwp_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 16#de#; + + ----------- + -- Stack -- + ----------- + + Stack_Base_Available : constant Boolean := False; + -- Indicates wether the stack base is available on this target. + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- returns the stack base of the specified thread. + -- Only call this function when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- returns the size of a page, or 0 if this is not relevant on this + -- target + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + + PROT_ON : constant := PROT_READ; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + pragma Inline (pthread_init); + -- This is a dummy procedure to share some GNULLI files + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Import (C, sigwait, "sigwait"); + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + type sigset_t_ptr is access all sigset_t; + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + ---------------------------- + -- POSIX.1c Section 13 -- + ---------------------------- + + PTHREAD_PRIO_NONE : constant := 16#100#; + PTHREAD_PRIO_PROTECT : constant := 16#200#; + PTHREAD_PRIO_INHERIT : constant := 16#400#; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import (C, pthread_mutexattr_setprioceiling); + + type Array_7_Int is array (0 .. 6) of int; + type struct_sched_param is record + sched_priority : int; + sched_reserved : Array_7_Int; + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) + return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy); + + function sched_yield return int; + pragma Import (C, sched_yield, "sched_yield"); + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "__pthread_attr_init_system"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "__pthread_create_system"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + +private + + type unsigned_int_array_8 is array (0 .. 7) of unsigned; + type sigset_t is record + sigset : unsigned_int_array_8; + end record; + pragma Convention (C_Pass_By_Copy, sigset_t); + + type pid_t is new int; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 1; + + type struct_timeval is record + tv_sec : time_t; + tv_usec : time_t; + end record; + pragma Convention (C, struct_timeval); + + type pthread_attr_t is new int; + type pthread_condattr_t is new int; + type pthread_mutexattr_t is new int; + type pthread_t is new int; + + type short_array is array (Natural range <>) of short; + type int_array is array (Natural range <>) of int; + + type pthread_mutex_t is record + m_short : short_array (0 .. 1); + m_int : int; + m_int1 : int_array (0 .. 3); + m_pad : int; -- needed for 32 bit ABI, but *not* for 64 bit + m_ptr : System.Address; + m_int2 : int_array (0 .. 1); + m_int3 : int_array (0 .. 3); + m_short2 : short_array (0 .. 1); + m_int4 : int_array (0 .. 4); + m_int5 : int_array (0 .. 1); + end record; + pragma Convention (C, pthread_mutex_t); + + type pthread_cond_t is record + c_short : short_array (0 .. 1); + c_int : int; + c_int1 : int_array (0 .. 3); + m_pad : int; -- needed for 32 bit ABI, but *not* for 64 bit + m_ptr : System.Address; + c_int2 : int_array (0 .. 1); + c_int3 : int_array (0 .. 1); + c_int4 : int_array (0 .. 1); + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new int; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-interix.ads b/gcc/ada/s-osinte-interix.ads new file mode 100644 index 00000000000..4e5d9567df3 --- /dev/null +++ b/gcc/ada/s-osinte-interix.ads @@ -0,0 +1,574 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 a OpenNT/Interix (FSU THREADS) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lgthreads"); + pragma Linker_Options ("-lmalloc"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 60; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 31; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 0; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + SIGCLD : constant := 18; -- alias for SIGCHLD + SIGCHLD : constant := 18; -- child status change + SIGPWR : constant := 0; -- power-fail restart + SIGWINCH : constant := 20; -- window size change + SIGURG : constant := 21; -- urgent condition on IO channel + SIGPOLL : constant := 22; -- pollable event occurred + SIGIO : constant := 19; -- I/O possible (Solaris SIGPOLL alias) + SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 24; -- user stop requested from tty + SIGCONT : constant := 25; -- stopped process has been continued + SIGTTIN : constant := 26; -- background tty read attempted + SIGTTOU : constant := 27; -- background tty write attempted + SIGVTALRM : constant := 28; -- virtual timer expired + SIGPROF : constant := 29; -- profiling timer expired + SIGXCPU : constant := 30; -- CPU time limit exceeded + SIGXFSZ : constant := 31; -- filesize limit exceeded + + SIGADAABORT : constant := SIGABRT; + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := + (SIGTRAP, SIGALRM, SIGVTALRM, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); + + Reserved : constant Signal_Set := (SIGKILL, SIGSTOP); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + sa_restorer : System.Address; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + SA_SIGINFO : constant := 0; + -- Dummy constant for a sa_flags bit. A proper definition is needed only + -- for the GCC/ZCX EH scheme (see System.Interrupt_Management). + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + -- FSU pthreads redefines sigaction and then uses a special syscall + -- API to call the system version. Doing syscalls on OpenNT is very + -- difficult, so we rename the pthread version instead. + pragma Import (C, sigaction, "pthread_wrapper_sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := False; + -- Indicates wether time slicing is supported (i.e FSU threads have been + -- compiled with DEF_RR) + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timeval is private; + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 0; + SCHED_RR : constant := 1; + SCHED_OTHER : constant := 2; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + -- lwp_self does not exist on this thread library, revert to pthread_self + -- which is the closest approximation (with getpid). This function is + -- needed to share 7staprop.adb across POSIX-like targets. + pragma Import (C, lwp_self, "pthread_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + PTHREAD_CREATE_JOINABLE : constant := 0; + + ----------- + -- Stack -- + ----------- + + Stack_Base_Available : constant Boolean := False; + -- Indicates wether the stack base is available on this target. + -- This allows us to share s-osinte.adb between all the FSU run time. + -- Note that this value can only be true if pthread_t has a complete + -- definition that corresponds exactly to the C header files. + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- returns the stack base of the specified thread. + -- Only call this function when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- returns the size of a page, or 0 if this is not relevant on this + -- target + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + + PROT_ON : constant := PROT_NONE; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + -- FSU_THREADS requires pthread_init, which is nonstandard + -- and this should be invoked during the elaboration of s-taprop.adb + pragma Import (C, pthread_init, "pthread_init"); + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + -- FSU_THREADS has a nonstandard sigwait + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + type sigset_t_ptr is access all sigset_t; + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask, "pthread_wrapper_sigprocmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + -- FSU_THREADS has nonstandard pthread_mutex_lock + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + -- FSU_THREADS has nonstandard pthread_mutex_lock + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + -- FSU_THREADS has a nonstandard pthread_cond_wait + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + -- FSU_THREADS has a nonstandard pthread_cond_timedwait + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_PROTECT : constant := 2; + PTHREAD_PRIO_INHERIT : constant := 1; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import + (C, pthread_mutexattr_setprioceiling, + "pthread_mutexattr_setprio_ceiling"); + + type struct_sched_param is record + sched_priority : int; -- scheduling priority + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + -- FSU_THREADS does not have pthread_setschedparam + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import + (C, pthread_attr_setschedpolicy, "pthread_attr_setsched"); + + function sched_yield return int; + -- FSU_THREADS does not have sched_yield; + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + -- FSU_THREADS has a nonstandard pthread_attr_setdetachstate + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + -- FSU_THREADS has a nonstandard pthread_getspecific + + type destructor_pointer is access procedure (arg : System.Address); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + +private + + type sigset_t is new unsigned_long; + pragma Convention (C, sigset_t); + + type pid_t is new int; + + subtype time_t is long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + + type struct_timeval is record + tv_sec : time_t; + tv_usec : long; + end record; + pragma Convention (C, struct_timeval); + + type pthread_attr_t is record + flags : int; + stacksize : int; + contentionscope : int; + inheritsched : int; + detachstate : int; + sched : int; + prio : int; + starttime : timespec; + deadline : timespec; + period : timespec; + end record; + pragma Convention (C_Pass_By_Copy, pthread_attr_t); + + type pthread_condattr_t is record + flags : int; + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_mutexattr_t is record + flags : int; + prio_ceiling : int; + protocol : int; + end record; + pragma Convention (C, pthread_mutexattr_t); + + type sigjmp_buf is array (Integer range 0 .. 17) of int; + + type pthread_t_struct is record + context : sigjmp_buf; + pbody : sigjmp_buf; + errno : int; + ret : int; + stack_base : System.Address; + end record; + pragma Convention (C, pthread_t_struct); + + type pthread_t is access all pthread_t_struct; + + type queue_t is record + head : System.Address; + tail : System.Address; + end record; + pragma Convention (C, queue_t); + + type pthread_mutex_t is record + queue : queue_t; + lock : plain_char; + owner : System.Address; + flags : int; + prio_ceiling : int; + protocol : int; + prev_max_ceiling_prio : int; + end record; + pragma Convention (C, pthread_mutex_t); + + type pthread_cond_t is record + queue : queue_t; + flags : int; + waiters : int; + mutex : System.Address; + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new int; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-irix-athread.ads b/gcc/ada/s-osinte-irix-athread.ads new file mode 100644 index 00000000000..e6df06813d7 --- /dev/null +++ b/gcc/ada/s-osinte-irix-athread.ads @@ -0,0 +1,699 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 an Irix (old pthread library) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces; +with Interfaces.C; +with Interfaces.C.Strings; +with Unchecked_Conversion; + +package System.OS_Interface is + + pragma Preelaborate; + + pragma Linker_Options ("-lathread"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + subtype chars_ptr is Interfaces.C.Strings.chars_ptr; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EINTR : constant := 4; -- interrupted system call + EAGAIN : constant := 11; -- No more processes + ENOMEM : constant := 12; -- Not enough core + EINVAL : constant := 22; -- Invalid argument + ETIMEDOUT : constant := 145; -- Connection timed out + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 64; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the + -- future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + SIGCLD : constant := 18; -- alias for SIGCHLD + SIGCHLD : constant := 18; -- child status change + SIGPWR : constant := 19; -- power-fail restart + SIGWINCH : constant := 20; -- window size change + SIGURG : constant := 21; -- urgent condition on IO channel + SIGPOLL : constant := 22; -- pollable event occurred + SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias) + SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 24; -- user stop requested from tty + SIGCONT : constant := 25; -- stopped process has been continued + SIGTTIN : constant := 26; -- background tty read attempted + SIGTTOU : constant := 27; -- background tty write attempted + SIGVTALRM : constant := 28; -- virtual timer expired + SIGPROF : constant := 29; -- profiling timer expired + SIGXCPU : constant := 30; -- CPU time limit exceeded + SIGXFSZ : constant := 31; -- filesize limit exceeded + SIGK32 : constant := 32; -- reserved for kernel (IRIX) + SIGCKPT : constant := 33; -- Checkpoint warning + SIGRESTART : constant := 34; -- Restart warning + SIGUME : constant := 35; -- Uncorrectable memory error + -- Signals defined for Posix 1003.1c. + SIGPTINTR : constant := 47; + SIGPTRESCHED : constant := 48; + -- Posix 1003.1b signals + SIGRTMIN : constant := 49; -- Posix 1003.1b signals + SIGRTMAX : constant := 64; -- Posix 1003.1b signals + + type sigset_t is private; + type sigset_t_ptr is access all sigset_t; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type siginfo_t is record + si_signo : int; + si_code : int; + si_errno : int; + bit_field_substitute_1 : String (1 .. 116); + end record; + pragma Convention (C, siginfo_t); + + type array_type_2 is array (Integer range 0 .. 1) of int; + type struct_sigaction is record + sa_flags : int; + sa_handler : System.Address; + sa_mask : sigset_t; + sa_resv : array_type_2; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr := null) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + type time_t is new int; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + type timespec_ptr is access all timespec; + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type timer_t is new Integer; + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + CLOCK_SGI_FAST : constant clockid_t; + CLOCK_SGI_CYCLE : constant clockid_t; + + SGI_CYCLECNTR_SIZE : constant := 165; + function syssgi (request : Interfaces.C.int) return Interfaces.C.ptrdiff_t; + + pragma Import (C, syssgi, "syssgi"); + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function clock_getres + (clock_id : clockid_t; tp : access timespec) return int; + pragma Import (C, clock_getres, "clock_getres"); + + type struct_timeval is record + tv_sec : time_t; + tv_usec : time_t; + end record; + pragma Convention (C, struct_timeval); + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + function gettimeofday + (tv : access struct_timeval; + tz : System.Address := System.Null_Address) return int; + pragma Import (C, gettimeofday, "gettimeofday"); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 0; + SCHED_RR : constant := 0; + SCHED_OTHER : constant := 0; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + pragma Inline (pthread_init); + -- This is a dummy procedure to share some GNULLI files + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; -- thread identifier + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is private; -- mutex identifier + type pthread_cond_t is private; -- cond identifier + type pthread_attr_t is private; -- pthread attributes + type pthread_mutexattr_t is private; -- mutex attributes + type pthread_condattr_t is private; -- mutex attributes + type sem_t is private; -- semaphore identifier + type pthread_key_t is private; -- per thread key + + subtype pthread_once_t is int; -- dynamic package initialization + subtype resource_t is long; -- sproc. resource info. + type start_addr is access function (arg : Address) return Address; + type sproc_start_addr is access function (arg : Address) return int; + type callout_addr is + access function (arg : Address; arg1 : Address) return Address; + + -- SGI specific types + + subtype sproc_t is Address; -- sproc identifier + subtype sproc_attr_t is Address; -- sproc attributes + + subtype spcb_p is Address; + subtype ptcb_p is Address; + + -- Pthread Error Types + + FUNC_OK : constant := 0; + FUNC_ERR : constant := -1; + + -- pthread run-time initialization data structure + + type pthread_init_struct is record + conf_initsize : int; -- shared area size + max_sproc_count : int; -- maximum number of sprocs + sproc_stack_size : size_t; -- sproc stack size + os_default_priority : int; -- default IRIX pri for main process + os_sched_signal : int; -- default OS scheduling signal + guard_pages : int; -- number of guard pages per stack + init_sproc_count : int; -- initial number of sprocs + end record; + + -- + -- Pthread Attribute Initialize / Destroy + -- + + function pthread_attr_init (attr : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy (attr : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + -- + -- Thread Attributes + -- + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate); + + function pthread_attr_setname + (attr : access pthread_attr_t; name : chars_ptr) return int; + pragma Import (C, pthread_attr_setname, "pthread_attr_setname"); + + -- + -- Thread Scheduling Attributes + -- + + function pthread_attr_setscope + (attr : access pthread_attr_t; contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; inherit : int) return int; + pragma Import + (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched"); + + function pthread_attr_setsched + (attr : access pthread_attr_t; scheduler : int) return int; + pragma Import (C, pthread_attr_setsched, "pthread_attr_setsched"); + + function pthread_attr_setprio + (attr : access pthread_attr_t; priority : int) return int; + pragma Import (C, pthread_attr_setprio, "pthread_attr_setprio"); + + -- + -- SGI Extensions to Thread Attributes + -- + + -- Bound to sproc attribute values + + PTHREAD_BOUND : constant := 1; + PTHREAD_NOT_BOUND : constant := 0; + + function pthread_attr_setresources + (attr : access pthread_attr_t; resources : resource_t) return int; + pragma Import (C, pthread_attr_setresources, "pthread_attr_setresources"); + + function pthread_attr_set_boundtosproc + (attr : access pthread_attr_t; bound_to_sproc : int) return int; + pragma Import + (C, pthread_attr_set_boundtosproc, "pthread_attr_set_boundtosproc"); + + function pthread_attr_set_bsproc + (attr : access pthread_attr_t; bsproc : spcb_p) return int; + pragma Import (C, pthread_attr_set_bsproc, "pthread_attr_set_bsproc"); + + function pthread_attr_set_tslice + (attr : access pthread_attr_t; + ts_interval : access struct_timeval) return int; + pragma Import (C, pthread_attr_set_tslice, "pthread_attr_set_tslice"); + + -- + -- Thread Creation & Management + -- + + function pthread_create + (thread : access pthread_t; + attr : access pthread_attr_t; + start_routine : start_addr; + arg : Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + procedure pthread_yield (arg : Address := System.Null_Address); + pragma Import (C, pthread_yield, "pthread_yield"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + function pthread_kill (thread : pthread_t; sig : int) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + -- + -- SGI Extensions to POSIX thread operations + -- + + function pthread_setprio (thread : pthread_t; priority : int) return int; + pragma Import (C, pthread_setprio, "pthread_setprio"); + + function pthread_suspend (thread : pthread_t) return int; + pragma Import (C, pthread_suspend, "pthread_suspend"); + + function pthread_resume (thread : pthread_t) return int; + pragma Import (C, pthread_resume, "pthread_resume"); + + function pthread_get_current_ada_tcb return Address; + pragma Import (C, pthread_get_current_ada_tcb); + + function pthread_set_ada_tcb + (thread : pthread_t; data : Address) return int; + pragma Import (C, pthread_set_ada_tcb, "pthread_set_ada_tcb"); + + -- Mutex Initialization / Destruction + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutexattr_setqueueorder + (attr : access pthread_mutexattr_t; order : int) return int; + pragma Import (C, pthread_mutexattr_setqueueorder); + + function pthread_mutexattr_setceilingprio + (attr : access pthread_mutexattr_t; priority : int) return int; + pragma Import (C, pthread_mutexattr_setceilingprio); + + -- Mutex Attributes + + -- Threads queueing order + + MUTEX_PRIORITY : constant := 0; -- wait in priority order + MUTEX_FIFO : constant := 1; -- first-in-first-out + MUTEX_PRIORITY_INHERIT : constant := 2; -- priority inhertance mutex + MUTEX_PRIORITY_CEILING : constant := 3; -- priority ceiling mutex + + -- Mutex debugging options + + MUTEX_NO_DEBUG : constant := 0; -- no debugging on mutex + MUTEX_DEBUG : constant := 1; -- debugging is on + + -- Mutex spin on lock operations + + MUTEX_NO_SPIN : constant := 0; -- no spin, try once only + MUTEX_SPIN_ONLY : constant := -1; -- spin forever + -- cnt > 0, limited spin + -- Mutex sharing attributes + + MUTEX_SHARED : constant := 0; -- shared between processes + MUTEX_NOTSHARED : constant := 1; -- not shared between processes + + -- Mutex Operations + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy + (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock + (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock + (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + -- Condition Initialization / Destruction + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + -- Condition Attributes + + COND_PRIORITY : constant := 0; -- wait in priority order + COND_FIFO : constant := 1; -- first-in-first-out + + -- Condition debugging options + + COND_NO_DEBUG : constant := 0; -- no debugging on mutex + COND_DEBUG : constant := 1; -- debugging is on + + -- Condition sharing attributes + + COND_SHARED : constant := 0; -- shared between processes + COND_NOTSHARED : constant := 1; -- not shared between processes + + -- Condition Operations + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy + (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access struct_timeval) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + -- Thread-Specific Data + + type foo_h_proc_1 is access procedure (value : Address); + + function pthread_key_create + (key : access pthread_key_t; destructor : foo_h_proc_1) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + + function pthread_setspecific + (key : pthread_key_t; value : Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific + (key : pthread_key_t; value : access Address) return int; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type foo_h_proc_2 is access procedure; + + function pthread_exec_begin (init : access pthread_init_struct) return int; + pragma Import (C, pthread_exec_begin, "pthread_exec_begin"); + + function sproc_create + (sproc_id : access sproc_t; + attr : access sproc_attr_t; + start_routine : sproc_start_addr; + arg : Address) return int; + pragma Import (C, sproc_create, "sproc_create"); + + function sproc_self return sproc_t; + pragma Import (C, sproc_self, "sproc_self"); + + -- if equal fast TRUE is returned - common case + -- if not equal thread resource must NOT be null in order to compare bits + + -- + -- Sproc attribute initialize / destroy + -- + + function sproc_attr_init (attr : access sproc_attr_t) return int; + pragma Import (C, sproc_attr_init, "sproc_attr_init"); + + function sproc_attr_destroy (attr : access sproc_attr_t) return int; + pragma Import (C, sproc_attr_destroy, "sproc_attr_destroy"); + + function sproc_attr_setresources + (attr : access sproc_attr_t; resources : resource_t) return int; + pragma Import (C, sproc_attr_setresources, "sproc_attr_setresources"); + + function sproc_attr_getresources + (attr : access sproc_attr_t; + resources : access resource_t) return int; + pragma Import (C, sproc_attr_getresources, "sproc_attr_getresources"); + + function sproc_attr_setcpu + (attr : access sproc_attr_t; cpu_num : int) return int; + pragma Import (C, sproc_attr_setcpu, "sproc_attr_setcpu"); + + function sproc_attr_getcpu + (attr : access sproc_attr_t; cpu_num : access int) return int; + pragma Import (C, sproc_attr_getcpu, "sproc_attr_getcpu"); + + function sproc_attr_setresident + (attr : access sproc_attr_t; resident : int) return int; + pragma Import (C, sproc_attr_setresident, "sproc_attr_setresident"); + + function sproc_attr_getresident + (attr : access sproc_attr_t; resident : access int) return int; + pragma Import (C, sproc_attr_getresident, "sproc_attr_getresident"); + + function sproc_attr_setname + (attr : access sproc_attr_t; name : chars_ptr) return int; + pragma Import (C, sproc_attr_setname, "sproc_attr_setname"); + + function sproc_attr_getname + (attr : access sproc_attr_t; name : chars_ptr) return int; + pragma Import (C, sproc_attr_getname, "sproc_attr_getname"); + + function sproc_attr_setstacksize + (attr : access sproc_attr_t; stacksize : size_t) return int; + pragma Import (C, sproc_attr_setstacksize, "sproc_attr_setstacksize"); + + function sproc_attr_getstacksize + (attr : access sproc_attr_t; stacksize : access size_t) return int; + pragma Import (C, sproc_attr_getstacksize, "sproc_attr_getstacksize"); + + function sproc_attr_setprio + (attr : access sproc_attr_t; priority : int) return int; + pragma Import (C, sproc_attr_setprio, "sproc_attr_setprio"); + + function sproc_attr_getprio + (attr : access sproc_attr_t; priority : access int) return int; + pragma Import (C, sproc_attr_getprio, "sproc_attr_getprio"); + + function sproc_attr_setbthread + (attr : access sproc_attr_t; bthread : ptcb_p) return int; + pragma Import (C, sproc_attr_setbthread, "sproc_attr_setbthread"); + + function sproc_attr_getbthread + (attr : access sproc_attr_t; bthread : access ptcb_p) return int; + pragma Import (C, sproc_attr_getbthread, "sproc_attr_getbthread"); + + SPROC_NO_RESOURCES : constant := 0; + SPROC_ANY_CPU : constant := -1; + SPROC_MY_PRIORITY : constant := -1; + SPROC_SWAPPED : constant := 0; + SPROC_RESIDENT : constant := 1; + + type isr_address is access procedure; + + function intr_attach (sig : int; isr : isr_address) return int; + pragma Import (C, intr_attach, "intr_attach"); + + Intr_Attach_Reset : constant Boolean := False; + -- True if intr_attach is reset after an interrupt handler is called + + function intr_exchange + (sig : int; + isr : isr_address; + oisr : access isr_address) return int; + pragma Import (C, intr_exchange, "intr_exchange"); + + function intr_current_isr + (sig : int; + oisr : access isr_address) + return int; + pragma Import (C, intr_current_isr, "intr_current_isr"); + +private + + type clockid_t is new int; + + CLOCK_REALTIME : constant clockid_t := 1; + CLOCK_SGI_CYCLE : constant clockid_t := 2; + CLOCK_SGI_FAST : constant clockid_t := 3; + + type pthread_t is new Address; -- thread identifier + type pthread_mutex_t is new Address; -- mutex identifier + type pthread_cond_t is new Address; -- cond identifier + type pthread_attr_t is new Address; -- pthread attributes + type pthread_mutexattr_t is new Address; -- mutex attributes + type pthread_condattr_t is new Address; -- mutex attributes + type sem_t is new Address; -- semaphore identifier + type pthread_key_t is new Address; -- per thread key + + type sigbits_t is array (Integer range 0 .. 3) of unsigned; + type sigset_t is record + sigbits : sigbits_t; + end record; + pragma Convention (C, sigset_t); + + type pid_t is new long; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-irix.adb b/gcc/ada/s-osinte-irix.adb new file mode 100644 index 00000000000..9c4c616dfa2 --- /dev/null +++ b/gcc/ada/s-osinte-irix.adb @@ -0,0 +1,120 @@ +------------------------------------------------------------------------------ +-- -- +-- 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) 1992-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 the IRIX version of this package. + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Interfaces.C; use Interfaces.C; + +package body System.OS_Interface is + + ------------------ + -- pthread_init -- + ------------------ + + procedure pthread_init is + begin + null; + end pthread_init; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + function To_Duration (TV : struct_timeval) return Duration is + begin + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end To_Duration; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ---------------- + -- To_Timeval -- + ---------------- + + function To_Timeval (D : Duration) return struct_timeval is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return + struct_timeval' + (tv_sec => S, + tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); + end To_Timeval; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-irix.ads b/gcc/ada/s-osinte-irix.ads new file mode 100644 index 00000000000..92c11070dad --- /dev/null +++ b/gcc/ada/s-osinte-irix.ads @@ -0,0 +1,527 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 SGI Pthreads version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + + pragma Preelaborate; + + pragma Linker_Options ("-lpthread"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EINTR : constant := 4; -- interrupted system call + EAGAIN : constant := 11; -- No more processes + ENOMEM : constant := 12; -- Not enough core + EINVAL : constant := 22; -- Invalid argument + ETIMEDOUT : constant := 145; -- Connection timed out + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 64; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the + -- future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + SIGCLD : constant := 18; -- alias for SIGCHLD + SIGCHLD : constant := 18; -- child status change + SIGPWR : constant := 19; -- power-fail restart + SIGWINCH : constant := 20; -- window size change + SIGURG : constant := 21; -- urgent condition on IO channel + SIGPOLL : constant := 22; -- pollable event occurred + SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias) + SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 24; -- user stop requested from tty + SIGCONT : constant := 25; -- stopped process has been continued + SIGTTIN : constant := 26; -- background tty read attempted + SIGTTOU : constant := 27; -- background tty write attempted + SIGVTALRM : constant := 28; -- virtual timer expired + SIGPROF : constant := 29; -- profiling timer expired + SIGXCPU : constant := 30; -- CPU time limit exceeded + SIGXFSZ : constant := 31; -- filesize limit exceeded + SIGK32 : constant := 32; -- reserved for kernel (IRIX) + SIGCKPT : constant := 33; -- Checkpoint warning + SIGRESTART : constant := 34; -- Restart warning + SIGUME : constant := 35; -- Uncorrectable memory error + -- Signals defined for Posix 1003.1c. + SIGPTINTR : constant := 47; + SIGPTRESCHED : constant := 48; + -- Posix 1003.1b signals + SIGRTMIN : constant := 49; -- Posix 1003.1b signals + SIGRTMAX : constant := 64; -- Posix 1003.1b signals + + type sigset_t is private; + type sigset_t_ptr is access all sigset_t; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type array_type_2 is array (Integer range 0 .. 1) of int; + type struct_sigaction is record + sa_flags : int; + sa_handler : System.Address; + sa_mask : sigset_t; + sa_resv : array_type_2; + end record; + pragma Convention (C, struct_sigaction); + + type struct_sigaction_ptr is access all struct_sigaction; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr := null) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + type timespec is private; + type timespec_ptr is access all timespec; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + CLOCK_SGI_FAST : constant clockid_t; + CLOCK_SGI_CYCLE : constant clockid_t; + + SGI_CYCLECNTR_SIZE : constant := 165; + + function syssgi (request : Interfaces.C.int) return Interfaces.C.ptrdiff_t; + pragma Import (C, syssgi, "syssgi"); + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function clock_getres + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_getres, "clock_getres"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timeval is private; + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 1; + SCHED_RR : constant := 2; + SCHED_TS : constant := 3; + SCHED_OTHER : constant := 3; + SCHED_NP : constant := 4; + + function sched_get_priority_min (Policy : int) return int; + pragma Import (C, sched_get_priority_min, "sched_get_priority_min"); + + function sched_get_priority_max (Policy : int) return int; + pragma Import (C, sched_get_priority_max, "sched_get_priority_max"); + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + pragma Inline (pthread_init); + -- This is a dummy procedure to share some GNULLI files + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Import (C, sigwait, "sigwait"); + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_PROTECT : constant := 2; + PTHREAD_PRIO_INHERIT : constant := 1; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import (C, pthread_mutexattr_setprioceiling); + + type struct_sched_param is record + sched_priority : int; + end record; + pragma Convention (C, struct_sched_param); + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) + return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import + (C, pthread_attr_setinheritsched, "pthread_attr_setinheritsched"); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy); + + function pthread_attr_setschedparam + (attr : access pthread_attr_t; + sched_param : access struct_sched_param) + return int; + pragma Import (C, pthread_attr_setschedparam, "pthread_attr_setschedparam"); + + function sched_yield return int; + pragma Import (C, sched_yield, "sched_yield"); + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + + --------------------------------------------------------------- + -- Non portable SGI 6.5 additions to the pthread interface -- + -- must be executed from within the context of a system -- + -- scope task -- + --------------------------------------------------------------- + + function pthread_setrunon_np (cpu : int) return int; + pragma Import (C, pthread_setrunon_np, "pthread_setrunon_np"); + +private + + type array_type_1 is array (Integer range 0 .. 3) of unsigned; + type sigset_t is record + X_X_sigbits : array_type_1; + end record; + pragma Convention (C, sigset_t); + + type pid_t is new long; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 1; + CLOCK_SGI_CYCLE : constant clockid_t := 2; + CLOCK_SGI_FAST : constant clockid_t := 3; + + type struct_timeval is record + tv_sec : time_t; + tv_usec : time_t; + end record; + pragma Convention (C, struct_timeval); + + type array_type_9 is array (Integer range 0 .. 4) of long; + type pthread_attr_t is record + X_X_D : array_type_9; + end record; + pragma Convention (C, pthread_attr_t); + + type array_type_8 is array (Integer range 0 .. 1) of long; + type pthread_condattr_t is record + X_X_D : array_type_8; + end record; + pragma Convention (C, pthread_condattr_t); + + type array_type_7 is array (Integer range 0 .. 1) of long; + type pthread_mutexattr_t is record + X_X_D : array_type_7; + end record; + pragma Convention (C, pthread_mutexattr_t); + + type pthread_t is new unsigned; + + type array_type_10 is array (Integer range 0 .. 7) of long; + type pthread_mutex_t is record + X_X_D : array_type_10; + end record; + pragma Convention (C, pthread_mutex_t); + + type array_type_11 is array (Integer range 0 .. 7) of long; + type pthread_cond_t is record + X_X_D : array_type_11; + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new int; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-linux-fsu.ads b/gcc/ada/s-osinte-linux-fsu.ads new file mode 100644 index 00000000000..df7a4322bf5 --- /dev/null +++ b/gcc/ada/s-osinte-linux-fsu.ads @@ -0,0 +1,599 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 a GNU/Linux (FSU THREADS) version of this package. + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lgthreads"); + pragma Linker_Options ("-lmalloc"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 110; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 31; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 7; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 10; -- user defined signal 1 + SIGUSR2 : constant := 12; -- user defined signal 2 + SIGCLD : constant := 17; -- alias for SIGCHLD + SIGCHLD : constant := 17; -- child status change + SIGPWR : constant := 30; -- power-fail restart + SIGWINCH : constant := 28; -- window size change + SIGURG : constant := 23; -- urgent condition on IO channel + SIGPOLL : constant := 29; -- pollable event occurred + SIGIO : constant := 29; -- I/O now possible (4.2 BSD) + SIGLOST : constant := 29; -- File lock lost + SIGSTOP : constant := 19; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 20; -- user stop requested from tty + SIGCONT : constant := 18; -- stopped process has been continued + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGUNUSED : constant := 31; -- unused signal (GNU/Linux) + SIGSTKFLT : constant := 16; -- coprocessor stack fault (GNU/Linux) + + SIGADAABORT : constant := SIGABRT; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := + (SIGTRAP, SIGBUS, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); + + Reserved : constant Signal_Set := + (SIGKILL, SIGSTOP, SIGALRM, SIGVTALRM, SIGUNUSED); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : unsigned_long; + sa_restorer : System.Address; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + type Machine_State is record + eip : unsigned_long; + ebx : unsigned_long; + esp : unsigned_long; + ebp : unsigned_long; + esi : unsigned_long; + edi : unsigned_long; + end record; + type Machine_State_Ptr is access all Machine_State; + + SA_SIGINFO : constant := 16#04#; + + SIG_BLOCK : constant := 0; + SIG_UNBLOCK : constant := 1; + SIG_SETMASK : constant := 2; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := False; + -- Indicates wether time slicing is supported (i.e FSU threads have been + -- compiled with DEF_RR) + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timeval is private; + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 0; + SCHED_RR : constant := 1; + SCHED_OTHER : constant := 2; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + -- lwp_self does not exist on this thread library, revert to pthread_self + -- which is the closest approximation (with getpid). This function is + -- needed to share 7staprop.adb across POSIX-like targets. + pragma Import (C, lwp_self, "pthread_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + + ----------- + -- Stack -- + ----------- + + Stack_Base_Available : constant Boolean := False; + -- Indicates wether the stack base is available on this target. + -- This allows us to share s-osinte.adb between all the FSU run time. + -- Note that this value can only be true if pthread_t has a complete + -- definition that corresponds exactly to the C header files. + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- returns the stack base of the specified thread. + -- Only call this function when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- returns the size of a page, or 0 if this is not relevant on this + -- target + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + + PROT_ON : constant := PROT_NONE; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + -- FSU_THREADS requires pthread_init, which is nonstandard + -- and this should be invoked during the elaboration of s-taprop.adb + pragma Import (C, pthread_init, "pthread_init"); + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Inline (sigwait); + -- FSU_THREADS has a nonstandard sigwait + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + -- FSU threads does not have pthread_sigmask. Instead, it uses + -- sigprocmask to do the signal handling when the thread library is + -- sucked in. + + type sigset_t_ptr is access all sigset_t; + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask, "sigprocmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy + (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock + (mutex : access pthread_mutex_t) return int; + pragma Inline (pthread_mutex_lock); + -- FSU_THREADS has nonstandard pthread_mutex_lock + + function pthread_mutex_unlock + (mutex : access pthread_mutex_t) return int; + pragma Inline (pthread_mutex_unlock); + -- FSU_THREADS has nonstandard pthread_mutex_lock + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Inline (pthread_cond_wait); + -- FSU_THREADS has a nonstandard pthread_cond_wait + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Inline (pthread_cond_timedwait); + -- FSU_THREADS has a nonstandard pthread_cond_timedwait + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_PROTECT : constant := 2; + PTHREAD_PRIO_INHERIT : constant := 1; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import + (C, pthread_mutexattr_setprioceiling, + "pthread_mutexattr_setprio_ceiling"); + + type struct_sched_param is record + sched_priority : int; -- scheduling priority + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Inline (pthread_setschedparam); + -- FSU_THREADS does not have pthread_setschedparam + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched"); + + function sched_yield return int; + pragma Inline (sched_yield); + -- FSU_THREADS does not have sched_yield; + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Inline (pthread_attr_setdetachstate); + -- FSU_THREADS has a nonstandard pthread_attr_setdetachstate + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Inline (pthread_getspecific); + -- FSU_THREADS has a nonstandard pthread_getspecific + + type destructor_pointer is access procedure (arg : System.Address); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + +private + + type sigset_t is array (0 .. 31) of unsigned_long; + pragma Convention (C, sigset_t); + -- This is for GNU libc version 2 but should be backward compatible with + -- other libc where sigset_t is smaller. + + type pid_t is new int; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + + type struct_timeval is record + tv_sec : long; + tv_usec : long; + end record; + pragma Convention (C, struct_timeval); + + type pthread_attr_t is record + flags : int; + stacksize : int; + contentionscope : int; + inheritsched : int; + detachstate : int; + sched : int; + prio : int; + starttime : timespec; + deadline : timespec; + period : timespec; + end record; + pragma Convention (C_Pass_By_Copy, pthread_attr_t); + + type pthread_condattr_t is record + flags : int; + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_mutexattr_t is record + flags : int; + prio_ceiling : int; + protocol : int; + end record; + pragma Convention (C, pthread_mutexattr_t); + + type sigjmp_buf is array (Integer range 0 .. 38) of int; + + type pthread_t_struct is record + context : sigjmp_buf; + pbody : sigjmp_buf; + errno : int; + ret : int; + stack_base : System.Address; + end record; + pragma Convention (C, pthread_t_struct); + + type pthread_t is access all pthread_t_struct; + + type queue_t is record + head : System.Address; + tail : System.Address; + end record; + pragma Convention (C, queue_t); + + type pthread_mutex_t is record + queue : queue_t; + lock : plain_char; + owner : System.Address; + flags : int; + prio_ceiling : int; + protocol : int; + prev_max_ceiling_prio : int; + end record; + pragma Convention (C, pthread_mutex_t); + + type pthread_cond_t is record + queue : queue_t; + flags : int; + waiters : int; + mutex : System.Address; + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new int; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-linux-ia64.ads b/gcc/ada/s-osinte-linux-ia64.ads new file mode 100644 index 00000000000..72c51b0df52 --- /dev/null +++ b/gcc/ada/s-osinte-linux-ia64.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/ia64 Version) -- +-- -- +-- 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 := 0.01; + + -- 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) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +private + + 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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + 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 := True; + +end System; diff --git a/gcc/ada/s-osinte-linux.ads b/gcc/ada/s-osinte-linux.ads new file mode 100644 index 00000000000..c8f06916f13 --- /dev/null +++ b/gcc/ada/s-osinte-linux.ads @@ -0,0 +1,524 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 a GNU/Linux (GNU/LinuxThreads) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lpthread"); + + subtype int is Interfaces.C.int; + subtype char is Interfaces.C.char; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + EPERM : constant := 1; + ETIMEDOUT : constant := 110; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 63; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 7; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 10; -- user defined signal 1 + SIGUSR2 : constant := 12; -- user defined signal 2 + SIGCLD : constant := 17; -- alias for SIGCHLD + SIGCHLD : constant := 17; -- child status change + SIGPWR : constant := 30; -- power-fail restart + SIGWINCH : constant := 28; -- window size change + SIGURG : constant := 23; -- urgent condition on IO channel + SIGPOLL : constant := 29; -- pollable event occurred + SIGIO : constant := 29; -- I/O now possible (4.2 BSD) + SIGLOST : constant := 29; -- File lock lost + SIGSTOP : constant := 19; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 20; -- user stop requested from tty + SIGCONT : constant := 18; -- stopped process has been continued + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGUNUSED : constant := 31; -- unused signal (GNU/Linux) + SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux) + SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal + SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal + SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal + + SIGADAABORT : constant := SIGABRT; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := ( + SIGTRAP, + -- To enable debugging on multithreaded applications, mark SIGTRAP to + -- be kept unmasked. + + SIGBUS, + + SIGTTIN, SIGTTOU, SIGTSTP, + -- Keep these three signals unmasked so that background processes + -- and IO behaves as normal "C" applications + + SIGPROF, + -- To avoid confusing the profiler + + SIGKILL, SIGSTOP, + -- These two signals actually cannot be masked; + -- POSIX simply won't allow it. + + SIGLTHRRES, SIGLTHRCAN, SIGLTHRDBG); + -- These three signals are used by GNU/LinuxThreads starting from + -- glibc 2.1 (future 2.2). + + Reserved : constant Signal_Set := + -- I am not sure why the following two signals are reserved. + -- I guess they are not supported by this version of GNU/Linux. + (SIGVTALRM, SIGUNUSED); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type union_type_3 is new String (1 .. 116); + type siginfo_t is record + si_signo : int; + si_code : int; + si_errno : int; + X_data : union_type_3; + end record; + pragma Convention (C, siginfo_t); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : unsigned_long; + sa_restorer : System.Address; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + type Machine_State is record + eip : unsigned_long; + ebx : unsigned_long; + esp : unsigned_long; + ebp : unsigned_long; + esi : unsigned_long; + edi : unsigned_long; + end record; + type Machine_State_Ptr is access all Machine_State; + + SA_SIGINFO : constant := 16#04#; + + SIG_BLOCK : constant := 0; + SIG_UNBLOCK : constant := 1; + SIG_SETMASK : constant := 2; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + type timespec is private; + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timeval is private; + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + function gettimeofday + (tv : access struct_timeval; + tz : System.Address := System.Null_Address) return int; + pragma Import (C, gettimeofday, "gettimeofday"); + + function sysconf (name : int) return long; + pragma Import (C, sysconf); + + SC_CLK_TCK : constant := 2; + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_OTHER : constant := 0; + SCHED_FIFO : constant := 1; + SCHED_RR : constant := 2; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is new unsigned_long; + subtype Thread_Id is pthread_t; + + function To_pthread_t is new Unchecked_Conversion + (unsigned_long, pthread_t); + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + + ----------- + -- Stack -- + ----------- + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- This is a dummy procedure to share some GNULLI files + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + pragma Inline (pthread_init); + -- This is a dummy procedure to share some GNULLI files + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait (set : access sigset_t; sig : access Signal) return int; + pragma Import (C, sigwait, "sigwait"); + + function pthread_kill (thread : pthread_t; sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + type sigset_t_ptr is access all sigset_t; + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + type struct_sched_param is record + sched_priority : int; -- scheduling priority + end record; + pragma Convention (C, struct_sched_param); + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import + (C, pthread_attr_setschedpolicy, "pthread_attr_setschedpolicy"); + + function sched_yield return int; + pragma Import (C, sched_yield, "sched_yield"); + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import + (C, pthread_attr_setdetachstate, "pthread_attr_setdetachstate"); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + +private + + type sigset_t is array (0 .. 127) of unsigned_char; + pragma Convention (C, sigset_t); + + type pid_t is new int; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type struct_timeval is record + tv_sec : time_t; + tv_usec : time_t; + end record; + pragma Convention (C, struct_timeval); + + type pthread_attr_t is record + detachstate : int; + schedpolicy : int; + schedparam : struct_sched_param; + inheritsched : int; + scope : int; + guardsize : size_t; + stackaddr_set : int; + stackaddr : System.Address; + stacksize : size_t; + end record; + pragma Convention (C, pthread_attr_t); + + type pthread_condattr_t is record + dummy : int; + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_mutexattr_t is record + mutexkind : int; + end record; + pragma Convention (C, pthread_mutexattr_t); + + type struct_pthread_fast_lock is record + status : long; + spinlock : int; + end record; + pragma Convention (C, struct_pthread_fast_lock); + + type pthread_mutex_t is record + m_reserved : int; + m_count : int; + m_owner : System.Address; + m_kind : int; + m_lock : struct_pthread_fast_lock; + end record; + pragma Convention (C, pthread_mutex_t); + + type pthread_cond_t is array (0 .. 47) of unsigned_char; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new unsigned; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-lynxos-3.adb b/gcc/ada/s-osinte-lynxos-3.adb new file mode 100644 index 00000000000..156601442b3 --- /dev/null +++ b/gcc/ada/s-osinte-lynxos-3.adb @@ -0,0 +1,597 @@ +------------------------------------------------------------------------------ +-- -- +-- 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) 1999-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 a LynxOS (Native) version of this package + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Interfaces.C; + +package body System.OS_Interface is + + use Interfaces.C; + + ------------------- + -- clock_gettime -- + ------------------- + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) + return int + is + function clock_gettime_base + (clock_id : clockid_t; + tp : access timespec) + return int; + pragma Import (C, clock_gettime_base, "clock_gettime"); + + begin + if clock_gettime_base (clock_id, tp) /= 0 then + return errno; + end if; + + return 0; + end clock_gettime; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + function To_Duration (TV : struct_timeval) return Duration is + begin + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end To_Duration; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ---------------- + -- To_Timeval -- + ---------------- + + function To_Timeval (D : Duration) return struct_timeval is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return struct_timeval'(tv_sec => S, + tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); + end To_Timeval; + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) + return int + is + function sigwait_base + (set : access sigset_t; + value : System.Address) + return Signal; + pragma Import (C, sigwait_base, "sigwait"); + + begin + sig.all := sigwait_base (set, Null_Address); + + if sig.all = -1 then + return errno; + end if; + + return 0; + end sigwait; + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + -- For all the following functions, LynxOS threads has the POSIX Draft 4 + -- begavior; it sets errno but the standard Posix requires it to be + -- returned. + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) + return int + is + function pthread_mutexattr_create + (attr : access pthread_mutexattr_t) + return int; + pragma Import (C, pthread_mutexattr_create, "pthread_mutexattr_create"); + + begin + if pthread_mutexattr_create (attr) /= 0 then + return errno; + end if; + + return 0; + end pthread_mutexattr_init; + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) + return int + is + function pthread_mutexattr_delete + (attr : access pthread_mutexattr_t) + return int; + pragma Import (C, pthread_mutexattr_delete, "pthread_mutexattr_delete"); + + begin + if pthread_mutexattr_delete (attr) /= 0 then + return errno; + end if; + + return 0; + end pthread_mutexattr_destroy; + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) + return int + is + function pthread_mutex_init_base + (mutex : access pthread_mutex_t; + attr : pthread_mutexattr_t) + return int; + pragma Import (C, pthread_mutex_init_base, "pthread_mutex_init"); + + begin + if pthread_mutex_init_base (mutex, attr.all) /= 0 then + return errno; + end if; + + return 0; + end pthread_mutex_init; + + function pthread_mutex_destroy + (mutex : access pthread_mutex_t) + return int + is + function pthread_mutex_destroy_base + (mutex : access pthread_mutex_t) + return int; + pragma Import (C, pthread_mutex_destroy_base, "pthread_mutex_destroy"); + + begin + if pthread_mutex_destroy_base (mutex) /= 0 then + return errno; + end if; + + return 0; + end pthread_mutex_destroy; + + 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"); + + begin + if pthread_mutex_lock_base (mutex) /= 0 then + return errno; + end if; + + return 0; + end pthread_mutex_lock; + + 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"); + + begin + if pthread_mutex_unlock_base (mutex) /= 0 then + return errno; + end if; + + return 0; + end pthread_mutex_unlock; + + function pthread_condattr_init + (attr : access pthread_condattr_t) + return int + is + function pthread_condattr_create + (attr : access pthread_condattr_t) + return int; + pragma Import (C, pthread_condattr_create, "pthread_condattr_create"); + + begin + if pthread_condattr_create (attr) /= 0 then + return errno; + end if; + + return 0; + end pthread_condattr_init; + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) + return int + is + function pthread_condattr_delete + (attr : access pthread_condattr_t) + return int; + pragma Import (C, pthread_condattr_delete, "pthread_condattr_delete"); + + begin + if pthread_condattr_delete (attr) /= 0 then + return errno; + end if; + + return 0; + end pthread_condattr_destroy; + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) + return int + is + function pthread_cond_init_base + (cond : access pthread_cond_t; + attr : pthread_condattr_t) + return int; + pragma Import (C, pthread_cond_init_base, "pthread_cond_init"); + + begin + if pthread_cond_init_base (cond, attr.all) /= 0 then + return errno; + end if; + + return 0; + end pthread_cond_init; + + function pthread_cond_destroy + (cond : access pthread_cond_t) + return int + is + function pthread_cond_destroy_base + (cond : access pthread_cond_t) + return int; + pragma Import (C, pthread_cond_destroy_base, "pthread_cond_destroy"); + + begin + if pthread_cond_destroy_base (cond) /= 0 then + return errno; + end if; + + return 0; + end pthread_cond_destroy; + + function pthread_cond_signal + (cond : access pthread_cond_t) + return int + is + function pthread_cond_signal_base + (cond : access pthread_cond_t) + return int; + pragma Import (C, pthread_cond_signal_base, "pthread_cond_signal"); + + begin + if pthread_cond_signal_base (cond) /= 0 then + return errno; + end if; + + return 0; + end pthread_cond_signal; + + 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"); + + begin + if pthread_cond_wait_base (cond, mutex) /= 0 then + return errno; + end if; + + return 0; + end pthread_cond_wait; + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + reltime : access timespec) return int + is + function pthread_cond_timedwait_base + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + reltime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait_base, "pthread_cond_timedwait"); + + begin + if pthread_cond_timedwait_base (cond, mutex, reltime) /= 0 then + if errno = EAGAIN then + return ETIMEDOUT; + end if; + + return errno; + end if; + + return 0; + end pthread_cond_timedwait; + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) + return int + is + function pthread_setscheduler + (thread : pthread_t; + policy : int; + prio : int) + return int; + pragma Import (C, pthread_setscheduler, "pthread_setscheduler"); + + begin + if pthread_setscheduler (thread, policy, param.sched_priority) = -1 then + return errno; + end if; + + return 0; + end pthread_setschedparam; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) + return int + is + pragma Unreferenced (attr, protocol); + begin + return 0; + end pthread_mutexattr_setprotocol; + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) + return int + is + pragma Unreferenced (attr, prioceiling); + begin + return 0; + end pthread_mutexattr_setprioceiling; + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) + return int + is + pragma Unreferenced (attr, contentionscope); + begin + return 0; + end pthread_attr_setscope; + + function sched_yield return int is + procedure pthread_yield; + pragma Import (C, pthread_yield, "pthread_yield"); + + begin + pthread_yield; + return 0; + end sched_yield; + + ----------------------------- + -- P1003.1c - Section 16 -- + ----------------------------- + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) + return int + is + pragma Unreferenced (attr, detachstate); + begin + return 0; + end pthread_attr_setdetachstate; + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) + return int + is + -- The LynxOS pthread_create doesn't seems to work. + -- Workaround : We're using st_new instead. + -- + -- function pthread_create_base + -- (thread : access pthread_t; + -- attributes : pthread_attr_t; + -- start_routine : Thread_Body; + -- arg : System.Address) + -- return int; + -- pragma Import (C, pthread_create_base, "pthread_create"); + + St : aliased st_t := attributes.st; + + function st_new + (start_routine : Thread_Body; + arg : System.Address; + attributes : access st_t; + thread : access pthread_t) + return int; + pragma Import (C, st_new, "st_new"); + + begin + -- Following code would be used if above commented function worked + + -- if pthread_create_base + -- (thread, attributes.all, start_routine, arg) /= 0 then + + if st_new (start_routine, arg, St'Access, thread) /= 0 then + return errno; + end if; + + return 0; + end pthread_create; + + function pthread_detach (thread : pthread_t) return int is + aliased_thread : aliased pthread_t := thread; + + function pthread_detach_base (thread : access pthread_t) return int; + pragma Import (C, pthread_detach_base, "pthread_detach"); + + begin + if pthread_detach_base (aliased_thread'Access) /= 0 then + return errno; + end if; + + return 0; + end pthread_detach; + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) + return int + is + function pthread_setspecific_base + (key : pthread_key_t; + value : System.Address) + return int; + pragma Import (C, pthread_setspecific_base, "pthread_setspecific"); + + begin + if pthread_setspecific_base (key, value) /= 0 then + return errno; + end if; + + return 0; + end pthread_setspecific; + + function pthread_getspecific (key : pthread_key_t) return System.Address is + procedure pthread_getspecific_base + (key : pthread_key_t; + value : access System.Address); + pragma Import (C, pthread_getspecific_base, "pthread_getspecific"); + + value : aliased System.Address := System.Null_Address; + + begin + pthread_getspecific_base (key, value'Unchecked_Access); + return value; + end pthread_getspecific; + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + + begin + return Null_Address; + end Get_Stack_Base; + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) + return int + is + function pthread_keycreate + (key : access pthread_key_t; + destructor : destructor_pointer) + return int; + pragma Import (C, pthread_keycreate, "pthread_keycreate"); + + begin + if pthread_keycreate (key, destructor) /= 0 then + return errno; + end if; + + return 0; + end pthread_key_create; + + procedure pthread_init is + begin + null; + end pthread_init; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-lynxos-3.ads b/gcc/ada/s-osinte-lynxos-3.ads new file mode 100644 index 00000000000..71607a408a6 --- /dev/null +++ b/gcc/ada/s-osinte-lynxos-3.ads @@ -0,0 +1,564 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 a LynxOS (Native) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-mthreads"); + + subtype int is Interfaces.C.int; + subtype char is Interfaces.C.char; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 60; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 63; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGBRK : constant := 6; -- break + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGCORE : constant := 7; -- kill with core dump + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGURG : constant := 16; -- urgent condition on IO channel + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGCLD : constant := 20; -- alias for SIGCHLD + SIGCHLD : constant := 20; -- child status change + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) + SIGPOLL : constant := 23; -- pollable event occurred + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGWINCH : constant := 28; -- window size change + SIGLOST : constant := 29; -- SUN 4.1 compatibility + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + SIGPRIO : constant := 32; -- sent to a process with its priority or + -- group is changed + + SIGADAABORT : constant := SIGABRT; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := + (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); + Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP, SIGPRIO); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SA_SIGINFO : constant := 16#80#; + + SIG_BLOCK : constant := 0; + SIG_UNBLOCK : constant := 1; + SIG_SETMASK : constant := 2; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates wether time slicing is supported + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Inline (clock_gettime); + -- LynxOS has non standard clock_gettime + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timezone is record + tz_minuteswest : int; + tz_dsttime : int; + end record; + pragma Convention (C, struct_timezone); + type struct_timezone_ptr is access all struct_timezone; + + type struct_timeval is private; + -- This is needed on systems that do not have clock_gettime() + -- but do have gettimeofday(). + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 16#00200000#; + SCHED_RR : constant := 16#00100000#; + SCHED_OTHER : constant := 16#00400000#; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + -- lwp_self does not exist on this thread library, revert to pthread_self + -- which is the closest approximation (with getpid). This function is + -- needed to share 7staprop.adb across POSIX-like targets. + pragma Import (C, lwp_self, "pthread_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type st_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 0; + + ----------- + -- Stack -- + ----------- + + Stack_Base_Available : constant Boolean := False; + -- Indicates wether the stack base is available on this target. + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- returns the stack base of the specified thread. + -- Only call this function when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- returns the size of a page, or 0 if this is not relevant on this + -- target + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_USER : constant := 8; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC + PROT_USER; + + PROT_ON : constant := PROT_READ; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Inline (sigwait); + -- LynxOS has non standard sigwait + + function pthread_kill (thread : pthread_t; sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + type sigset_t_ptr is access all sigset_t; + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask, "sigprocmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Inline (pthread_mutexattr_init); + -- LynxOS has a nonstandard pthread_mutexattr_init + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Inline (pthread_mutexattr_destroy); + -- Lynxos has a nonstandard pthread_mutexattr_destroy + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Inline (pthread_mutex_init); + -- LynxOS has a nonstandard pthread_mutex_init + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Inline (pthread_mutex_destroy); + -- LynxOS has a nonstandard pthread_mutex_destroy + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Inline (pthread_mutex_lock); + -- LynxOS has a nonstandard pthread_mutex_lock + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Inline (pthread_mutex_unlock); + -- LynxOS has a nonstandard pthread_mutex_unlock + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Inline (pthread_condattr_init); + -- LynxOS has a nonstandard pthread_condattr_init + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Inline (pthread_condattr_destroy); + -- LynxOS has a nonstandard pthread_condattr_destroy + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Inline (pthread_cond_init); + -- LynxOS has a non standard pthread_cond_init + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Inline (pthread_cond_destroy); + -- LynxOS has a nonstandard pthread_cond_destroy + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Inline (pthread_cond_signal); + -- LynxOS has a nonstandard pthread_cond_signal + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Inline (pthread_cond_wait); + -- LynxOS has a nonstandard pthread_cond_wait + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + reltime : access timespec) return int; + pragma Inline (pthread_cond_timedwait); + -- LynxOS has a nonstandard pthrad_cond_timedwait + + Relative_Timed_Wait : constant Boolean := True; + -- pthread_cond_timedwait requires a relative delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_INHERIT : constant := 0; + PTHREAD_PRIO_PROTECT : constant := 0; + + type struct_sched_param is record + sched_priority : int; -- scheduling priority + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Inline (pthread_setschedparam); + -- LynxOS doesn't have pthread_setschedparam. + -- Instead, use pthread_setscheduler + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Inline (pthread_mutexattr_setprotocol); + -- LynxOS doesn't have pthread_mutexattr_setprotocol + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Inline (pthread_mutexattr_setprioceiling); + -- LynxOS doesn't have pthread_mutexattr_setprioceiling + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + -- LynxOS doesn't have pthread_attr_setscope: all threads have system scope + pragma Inline (pthread_attr_setscope); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched"); + + function sched_yield return int; + -- pragma Import (C, sched_yield, "sched_yield"); + pragma Inline (sched_yield); + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_create"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_delete"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Inline (pthread_attr_setdetachstate); + -- LynxOS doesn't have pthread_attr_setdetachstate + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize, "pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Inline (pthread_create); + -- LynxOS has a non standard pthread_create + + function pthread_detach (thread : pthread_t) return int; + pragma Inline (pthread_detach); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Inline (pthread_setspecific); + -- LynxOS has a non standard pthread_setspecific + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Inline (pthread_getspecific); + -- LynxOS has a non standard pthread_getspecific + + type destructor_pointer is access procedure (arg : System.Address); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Inline (pthread_key_create); + -- LynxOS has a non standard pthread_keycreate + + procedure pthread_init; + -- This is a dummy procedure to share some GNULLI files + +private + + type sigbit_array is array (1 .. 2) of long; + type sigset_t is record + sa_sigbits : sigbit_array; + end record; + pragma Convention (C_Pass_By_Copy, sigset_t); + + type pid_t is new long; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new unsigned_char; + CLOCK_REALTIME : constant clockid_t := 0; + + type struct_timeval is record + tv_sec : time_t; + tv_usec : time_t; + end record; + pragma Convention (C, struct_timeval); + + type st_t is record + stksize : int; + prio : int; + inheritsched : int; + state : int; + sched : int; + end record; + pragma Convention (C, st_t); + + type pthread_attr_t is record + st : st_t; + pthread_attr_scope : int; -- ignored + end record; + pragma Convention (C, pthread_attr_t); + + type pthread_condattr_t is new int; + + type pthread_mutexattr_t is new int; + + type tid_t is new short; + type pthread_t is new tid_t; + + type synch_ptr is access all pthread_mutex_t; + type pthread_mutex_t is record + w_count : int; + mut_owner : int; + id : unsigned; + next : synch_ptr; + end record; + pragma Convention (C, pthread_mutex_t); + + type pthread_cond_t is new pthread_mutex_t; + + type pthread_key_t is new int; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-lynxos.adb b/gcc/ada/s-osinte-lynxos.adb new file mode 100644 index 00000000000..0cb052632a3 --- /dev/null +++ b/gcc/ada/s-osinte-lynxos.adb @@ -0,0 +1,154 @@ +------------------------------------------------------------------------------ +-- -- +-- 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) 2001-2002 Ada Core Technologies, 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 LynxOS (POSIX 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 : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return + struct_timeval' + (tv_sec => S, + tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); + end To_Timeval; + + ------------- + -- sigwait -- + ------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) + return int + is + function sigwaitinfo + (set : access sigset_t; + info : System.Address) return Signal; + pragma Import (C, sigwaitinfo, "sigwaitinfo"); + + begin + sig.all := sigwaitinfo (set, Null_Address); + + if sig.all = -1 then + return errno; + end if; + + return 0; + end sigwait; + + -------------------- + -- Get_Stack_Base -- + -------------------- + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + + begin + return Null_Address; + end Get_Stack_Base; + + ------------------ + -- pthread_init -- + ------------------ + + procedure pthread_init is + begin + null; + end pthread_init; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-lynxos.ads b/gcc/ada/s-osinte-lynxos.ads new file mode 100644 index 00000000000..8b6b33885d1 --- /dev/null +++ b/gcc/ada/s-osinte-lynxos.ads @@ -0,0 +1,592 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 a LynxOS (POSIX Threads) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-mthreads"); + -- Selects the POSIX 1.c runtime, rather than the non-threading runtime + -- or the deprecated legacy threads library. The -mthreads flag is + -- defined in patch.LynxOS and matches the definition for Lynx's gcc. + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 60; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 63; + + -- Max_Interrupt is the number of OS signals, as defined in: + -- + -- /usr/include/sys/signal.h + -- + -- + -- The lowest numbered signal is 1, but 0 is a valid argument to some + -- library functions, eg. kill(2). However, 0 is not just another + -- signal: For instance 'I in Signal' and similar should be used with + -- caution. + + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGBRK : constant := 6; -- break + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in future + SIGCORE : constant := 7; -- kill with core dump + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGURG : constant := 16; -- urgent condition on IO channel + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGCLD : constant := 20; -- alias for SIGCHLD + SIGCHLD : constant := 20; -- child status change + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGIO : constant := 23; -- I/O possible (Solaris SIGPOLL alias) + SIGPOLL : constant := 23; -- pollable event occurred + SIGTHREADKILL : constant := 24; -- Reserved by LynxOS runtime + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGWINCH : constant := 28; -- window size change + SIGLOST : constant := 29; -- SUN 4.1 compatibility + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + + SIGPRIO : constant := 32; + -- sent to a process with its priority or group is changed + + SIGADAABORT : constant := SIGABRT; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := + (SIGTRAP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF, SIGTHREADKILL); + Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP, SIGPRIO); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SA_SIGINFO : constant := 16#80#; + + SIG_BLOCK : constant := 0; + SIG_UNBLOCK : constant := 1; + SIG_SETMASK : constant := 2; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates whether time slicing is supported + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function clock_getres + (clock_id : clockid_t; + res : access timespec) return int; + pragma Import (C, clock_getres, "clock_getres"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timezone is record + tz_minuteswest : int; + tz_dsttime : int; + end record; + pragma Convention (C, struct_timezone); + type struct_timezone_ptr is access all struct_timezone; + + type struct_timeval is private; + -- This is needed on systems that do not have clock_gettime() + -- but do have gettimeofday(). + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 16#200000#; + SCHED_RR : constant := 16#100000#; + SCHED_OTHER : constant := 16#400000#; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + pragma Import (C, lwp_self, "pthread_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + PTHREAD_CREATE_JOINABLE : constant := 0; + + ----------- + -- Stack -- + ----------- + + Stack_Base_Available : constant Boolean := False; + -- Indicates whether the stack base is available on this target. + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- Returns the stack base of the specified thread. + -- Only call this function when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- Returns the size of a page, or 0 if this is not relevant on this + -- target + + PROT_NONE : constant := 1; + PROT_READ : constant := 2; + PROT_WRITE : constant := 4; + PROT_EXEC : constant := 8; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + + PROT_ON : constant := PROT_READ; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + ----------------------------------------- + -- Nonstandard Thread Initialization -- + ----------------------------------------- + + procedure pthread_init; + -- This is a dummy procedure to share some GNULLI files + + --------------------------- + -- POSIX.1c Section 3 -- + --------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Inline (sigwait); + -- LynxOS has non standard sigwait + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + type sigset_t_ptr is access all sigset_t; + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + -- The behavior of pthread_sigmask on LynxOS requires + -- further investigation. + + ---------------------------- + -- POSIX.1c Section 11 -- + ---------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_INHERIT : constant := 1; + PTHREAD_PRIO_PROTECT : constant := 2; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import (C, pthread_mutexattr_setprioceiling); + + type struct_sched_param is record + sched_priority : int; + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy); + + function sched_yield return int; + pragma Import (C, sched_yield, "sched_yield"); + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function st_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, st_setspecific, "st_setspecific"); + + function st_getspecific + (key : pthread_key_t; + retval : System.Address) return int; + pragma Import (C, st_getspecific, "st_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + + function st_keycreate + (destructor : destructor_pointer; + key : access pthread_key_t) return int; + pragma Import (C, st_keycreate, "st_keycreate"); + +private + + type sigset_t is record + X1, X2 : long; + end record; + pragma Convention (C, sigset_t); + + type pid_t is new long; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new unsigned_char; + CLOCK_REALTIME : constant clockid_t := 0; + + type struct_timeval is record + tv_sec : time_t; + tv_usec : time_t; + end record; + pragma Convention (C, struct_timeval); + + type st_attr_t is record + stksize : int; + prio : int; + inheritsched : int; + state : int; + sched : int; + detachstate : int; + guardsize : int; + end record; + pragma Convention (C, st_attr_t); + + type pthread_attr_t is record + pthread_attr_magic : unsigned; + st : st_attr_t; + pthread_attr_scope : int; + end record; + pragma Convention (C, pthread_attr_t); + + type pthread_condattr_t is record + cv_magic : unsigned; + cv_pshared : unsigned; + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_mutexattr_t is record + m_flags : unsigned; + m_prio_c : int; + m_pshared : int; + end record; + pragma Convention (C, pthread_mutexattr_t); + + type tid_t is new short; + type pthread_t is new tid_t; + + type block_obj_t is new System.Address; + -- typedef struct _block_obj_s { + -- struct st_entry *b_head; + -- } block_obj_t; + + type pthread_mutex_t is record + m_flags : unsigned; + m_owner : tid_t; + m_wait : block_obj_t; + m_prio_c : int; + m_oldprio : int; + m_count : int; + m_referenced : int; + end record; + pragma Convention (C, pthread_mutex_t); + type pthread_mutex_t_ptr is access all pthread_mutex_t; + + type pthread_cond_t is record + cv_magic : unsigned; + cv_wait : block_obj_t; + cv_mutex : pthread_mutex_t_ptr; + cv_refcnt : int; + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new int; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-mingw.ads b/gcc/ada/s-osinte-mingw.ads new file mode 100644 index 00000000000..eec2e6ead98 --- /dev/null +++ b/gcc/ada/s-osinte-mingw.ads @@ -0,0 +1,451 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 a NT (native) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Interfaces.C.Strings; +with Unchecked_Conversion; + +package System.OS_Interface is +pragma Preelaborate; + + pragma Linker_Options ("-mthreads"); + + subtype int is Interfaces.C.int; + subtype long is Interfaces.C.long; + + ------------------- + -- General Types -- + ------------------- + + type DWORD is new Interfaces.C.unsigned_long; + type WORD is new Interfaces.C.unsigned_short; + + -- The LARGE_INTEGER type is actually a fixed point type + -- that only can represent integers. The reason for this is + -- easier conversion to Duration or other fixed point types. + -- (See Operations.Clock) + + type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0; + + subtype PSZ is Interfaces.C.Strings.chars_ptr; + subtype PCHAR is Interfaces.C.Strings.chars_ptr; + subtype PVOID is System.Address; + + Null_Void : constant PVOID := System.Null_Address; + + type PLONG is access all Interfaces.C.long; + type PDWORD is access all DWORD; + + type BOOL is new Boolean; + for BOOL'Size use Interfaces.C.unsigned_long'Size; + + ------------------------- + -- Handles for objects -- + ------------------------- + + type HANDLE is new Interfaces.C.long; + type PHANDLE is access all HANDLE; + + subtype Thread_Id is HANDLE; + + ----------- + -- Errno -- + ----------- + + NO_ERROR : constant := 0; + FUNC_ERR : constant := -1; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 31; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGINT : constant := 2; -- interrupt (Ctrl-C) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGFPE : constant := 8; -- floating point exception + SIGSEGV : constant := 11; -- segmentation violation + SIGTERM : constant := 15; -- software termination signal from kill + SIGBREAK : constant := 21; -- break (Ctrl-Break) + SIGABRT : constant := 22; -- used by abort, replace SIGIOT in the future + + type sigset_t is private; + + type isr_address is access procedure (sig : int); + + function intr_attach (sig : int; handler : isr_address) return long; + pragma Import (C, intr_attach, "signal"); + + Intr_Attach_Reset : constant Boolean := True; + -- True if intr_attach is reset after an interrupt handler is called + + procedure kill (sig : Signal); + pragma Import (C, kill, "raise"); + + --------------------- + -- Time Management -- + --------------------- + + procedure Sleep (dwMilliseconds : DWORD); + pragma Import (Stdcall, Sleep, External_Name => "Sleep"); + + type SYSTEMTIME is record + wYear : WORD; + wMonth : WORD; + wDayOfWeek : WORD; + wDay : WORD; + wHour : WORD; + wMinute : WORD; + wSecond : WORD; + wMilliseconds : WORD; + end record; + + procedure GetSystemTime (pSystemTime : access SYSTEMTIME); + pragma Import (Stdcall, GetSystemTime, "GetSystemTime"); + + procedure GetSystemTimeAsFileTime (lpFileTime : access Long_Long_Integer); + pragma Import (Stdcall, GetSystemTimeAsFileTime, "GetSystemTimeAsFileTime"); + + function SetSystemTime (pSystemTime : access SYSTEMTIME) return BOOL; + pragma Import (Stdcall, SetSystemTime, "SetSystemTime"); + + function FileTimeToSystemTime + (lpFileTime : access Long_Long_Integer; + lpSystemTime : access SYSTEMTIME) return BOOL; + pragma Import (Stdcall, FileTimeToSystemTime, "FileTimeToSystemTime"); + + function SystemTimeToFileTime + (lpSystemTime : access SYSTEMTIME; + lpFileTime : access Long_Long_Integer) return BOOL; + pragma Import (Stdcall, SystemTimeToFileTime, "SystemTimeToFileTime"); + + function FileTimeToLocalFileTime + (lpFileTime : access Long_Long_Integer; + lpLocalFileTime : access Long_Long_Integer) return BOOL; + pragma Import (Stdcall, FileTimeToLocalFileTime, "FileTimeToLocalFileTime"); + + function LocalFileTimeToFileTime + (lpFileTime : access Long_Long_Integer; + lpLocalFileTime : access Long_Long_Integer) return BOOL; + pragma Import (Stdcall, LocalFileTimeToFileTime, "LocalFileTimeToFileTime"); + + function QueryPerformanceCounter + (lpPerformanceCount : access LARGE_INTEGER) return BOOL; + pragma Import + (Stdcall, QueryPerformanceCounter, "QueryPerformanceCounter"); + + function QueryPerformanceFrequency + (lpFrequency : access LARGE_INTEGER) return BOOL; + pragma Import + (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + procedure SwitchToThread; + pragma Import (Stdcall, SwitchToThread, "SwitchToThread"); + + ----------------------- + -- Critical sections -- + ----------------------- + + type CRITICAL_SECTION is private; + type PCRITICAL_SECTION is access all CRITICAL_SECTION; + + procedure InitializeCriticalSection (pCriticalSection : PCRITICAL_SECTION); + pragma Import + (Stdcall, InitializeCriticalSection, "InitializeCriticalSection"); + + procedure EnterCriticalSection (pCriticalSection : PCRITICAL_SECTION); + pragma Import (Stdcall, EnterCriticalSection, "EnterCriticalSection"); + + procedure LeaveCriticalSection (pCriticalSection : PCRITICAL_SECTION); + pragma Import (Stdcall, LeaveCriticalSection, "LeaveCriticalSection"); + + procedure DeleteCriticalSection (pCriticalSection : PCRITICAL_SECTION); + pragma Import (Stdcall, DeleteCriticalSection, "DeleteCriticalSection"); + + ------------------------------------------------------------- + -- Thread Creation, Activation, Suspension And Termination -- + ------------------------------------------------------------- + + type PTHREAD_START_ROUTINE is access function + (pThreadParameter : PVOID) return DWORD; + pragma Convention (Stdcall, PTHREAD_START_ROUTINE); + + function To_PTHREAD_START_ROUTINE is new + Unchecked_Conversion (System.Address, PTHREAD_START_ROUTINE); + + type SECURITY_ATTRIBUTES is record + nLength : DWORD; + pSecurityDescriptor : PVOID; + bInheritHandle : BOOL; + end record; + + type PSECURITY_ATTRIBUTES is access all SECURITY_ATTRIBUTES; + + function CreateThread + (pThreadAttributes : PSECURITY_ATTRIBUTES; + dwStackSize : DWORD; + pStartAddress : PTHREAD_START_ROUTINE; + pParameter : PVOID; + dwCreationFlags : DWORD; + pThreadId : PDWORD) return HANDLE; + pragma Import (Stdcall, CreateThread, "CreateThread"); + + function BeginThreadEx + (pThreadAttributes : PSECURITY_ATTRIBUTES; + dwStackSize : DWORD; + pStartAddress : PTHREAD_START_ROUTINE; + pParameter : PVOID; + dwCreationFlags : DWORD; + pThreadId : PDWORD) return HANDLE; + pragma Import (C, BeginThreadEx, "_beginthreadex"); + + Debug_Process : constant := 16#00000001#; + Debug_Only_This_Process : constant := 16#00000002#; + Create_Suspended : constant := 16#00000004#; + Detached_Process : constant := 16#00000008#; + Create_New_Console : constant := 16#00000010#; + + Create_New_Process_Group : constant := 16#00000200#; + + Create_No_window : constant := 16#08000000#; + + Profile_User : constant := 16#10000000#; + Profile_Kernel : constant := 16#20000000#; + Profile_Server : constant := 16#40000000#; + + function GetExitCodeThread + (hThread : HANDLE; + pExitCode : PDWORD) return BOOL; + pragma Import (Stdcall, GetExitCodeThread, "GetExitCodeThread"); + + function ResumeThread (hThread : HANDLE) return DWORD; + pragma Import (Stdcall, ResumeThread, "ResumeThread"); + + function SuspendThread (hThread : HANDLE) return DWORD; + pragma Import (Stdcall, SuspendThread, "SuspendThread"); + + procedure ExitThread (dwExitCode : DWORD); + pragma Import (Stdcall, ExitThread, "ExitThread"); + + procedure EndThreadEx (dwExitCode : DWORD); + pragma Import (C, EndThreadEx, "_endthreadex"); + + function TerminateThread + (hThread : HANDLE; + dwExitCode : DWORD) return BOOL; + pragma Import (Stdcall, TerminateThread, "TerminateThread"); + + function GetCurrentThread return HANDLE; + pragma Import (Stdcall, GetCurrentThread, "GetCurrentThread"); + + function GetCurrentProcess return HANDLE; + pragma Import (Stdcall, GetCurrentProcess, "GetCurrentProcess"); + + function GetCurrentThreadId return DWORD; + pragma Import (Stdcall, GetCurrentThreadId, "GetCurrentThreadId"); + + function TlsAlloc return DWORD; + pragma Import (Stdcall, TlsAlloc, "TlsAlloc"); + + function TlsGetValue (dwTlsIndex : DWORD) return PVOID; + pragma Import (Stdcall, TlsGetValue, "TlsGetValue"); + + function TlsSetValue (dwTlsIndex : DWORD; pTlsValue : PVOID) return BOOL; + pragma Import (Stdcall, TlsSetValue, "TlsSetValue"); + + function TlsFree (dwTlsIndex : DWORD) return BOOL; + pragma Import (Stdcall, TlsFree, "TlsFree"); + + TLS_Nothing : constant := DWORD'Last; + + procedure ExitProcess (uExitCode : Interfaces.C.unsigned); + pragma Import (Stdcall, ExitProcess, "ExitProcess"); + + function WaitForSingleObject + (hHandle : HANDLE; + dwMilliseconds : DWORD) return DWORD; + pragma Import (Stdcall, WaitForSingleObject, "WaitForSingleObject"); + + function WaitForSingleObjectEx + (hHandle : HANDLE; + dwMilliseconds : DWORD; + fAlertable : BOOL) return DWORD; + pragma Import (Stdcall, WaitForSingleObjectEx, "WaitForSingleObjectEx"); + + Wait_Infinite : constant := DWORD'Last; + WAIT_TIMEOUT : constant := 16#0000_0102#; + WAIT_FAILED : constant := 16#FFFF_FFFF#; + + ------------------------------------ + -- Semaphores, Events and Mutexes -- + ------------------------------------ + + function CloseHandle (hObject : HANDLE) return BOOL; + pragma Import (Stdcall, CloseHandle, "CloseHandle"); + + function CreateSemaphore + (pSemaphoreAttributes : PSECURITY_ATTRIBUTES; + lInitialCount : Interfaces.C.long; + lMaximumCount : Interfaces.C.long; + pName : PSZ) return HANDLE; + pragma Import (Stdcall, CreateSemaphore, "CreateSemaphoreA"); + + function OpenSemaphore + (dwDesiredAccess : DWORD; + bInheritHandle : BOOL; + pName : PSZ) return HANDLE; + pragma Import (Stdcall, OpenSemaphore, "OpenSemaphoreA"); + + function ReleaseSemaphore + (hSemaphore : HANDLE; + lReleaseCount : Interfaces.C.long; + pPreviousCount : PLONG) return BOOL; + pragma Import (Stdcall, ReleaseSemaphore, "ReleaseSemaphore"); + + function CreateEvent + (pEventAttributes : PSECURITY_ATTRIBUTES; + bManualReset : BOOL; + bInitialState : BOOL; + pName : PSZ) return HANDLE; + pragma Import (Stdcall, CreateEvent, "CreateEventA"); + + function OpenEvent + (dwDesiredAccess : DWORD; + bInheritHandle : BOOL; + pName : PSZ) return HANDLE; + pragma Import (Stdcall, OpenEvent, "OpenEventA"); + + function SetEvent (hEvent : HANDLE) return BOOL; + pragma Import (Stdcall, SetEvent, "SetEvent"); + + function ResetEvent (hEvent : HANDLE) return BOOL; + pragma Import (Stdcall, ResetEvent, "ResetEvent"); + + function PulseEvent (hEvent : HANDLE) return BOOL; + pragma Import (Stdcall, PulseEvent, "PulseEvent"); + + function CreateMutex + (pMutexAttributes : PSECURITY_ATTRIBUTES; + bInitialOwner : BOOL; + pName : PSZ) return HANDLE; + pragma Import (Stdcall, CreateMutex, "CreateMutexA"); + + function OpenMutex + (dwDesiredAccess : DWORD; + bInheritHandle : BOOL; + pName : PSZ) return HANDLE; + pragma Import (Stdcall, OpenMutex, "OpenMutexA"); + + function ReleaseMutex (hMutex : HANDLE) return BOOL; + pragma Import (Stdcall, ReleaseMutex, "ReleaseMutex"); + + --------------------------------------------------- + -- Accessing properties of Threads and Processes -- + --------------------------------------------------- + + ----------------- + -- Priorities -- + ----------------- + + function SetThreadPriority + (hThread : HANDLE; + nPriority : Interfaces.C.int) return BOOL; + pragma Import (Stdcall, SetThreadPriority, "SetThreadPriority"); + + function GetThreadPriority (hThread : HANDLE) return Interfaces.C.int; + pragma Import (Stdcall, GetThreadPriority, "GetThreadPriority"); + + function SetPriorityClass + (hProcess : HANDLE; + dwPriorityClass : DWORD) return BOOL; + pragma Import (Stdcall, SetPriorityClass, "SetPriorityClass"); + + procedure SetThreadPriorityBoost + (hThread : HANDLE; + DisablePriorityBoost : BOOL); + pragma Import (Stdcall, SetThreadPriorityBoost, "SetThreadPriorityBoost"); + + Normal_Priority_Class : constant := 16#00000020#; + Idle_Priority_Class : constant := 16#00000040#; + High_Priority_Class : constant := 16#00000080#; + Realtime_Priority_Class : constant := 16#00000100#; + + Thread_Priority_Idle : constant := -15; + Thread_Priority_Lowest : constant := -2; + Thread_Priority_Below_Normal : constant := -1; + Thread_Priority_Normal : constant := 0; + Thread_Priority_Above_Normal : constant := 1; + Thread_Priority_Highest : constant := 2; + Thread_Priority_Time_Critical : constant := 15; + Thread_Priority_Error_Return : constant := Interfaces.C.long'Last; + + function GetLastError return DWORD; + pragma Import (Stdcall, GetLastError, "GetLastError"); + +private + + type sigset_t is new Interfaces.C.unsigned_long; + + type CRITICAL_SECTION is record + DebugInfo : System.Address; + -- The following three fields control entering and + -- exiting the critical section for the resource + LockCount : Long_Integer; + RecursionCount : Long_Integer; + OwningThread : HANDLE; + LockSemaphore : HANDLE; + Reserved : DWORD; + end record; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-os2.adb b/gcc/ada/s-osinte-os2.adb new file mode 100644 index 00000000000..e2a241118d5 --- /dev/null +++ b/gcc/ada/s-osinte-os2.adb @@ -0,0 +1,120 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 the OS/2 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.OS2Lib.Errors; +with Interfaces.OS2Lib.Synchronization; + +package body System.OS_Interface is + + use Interfaces; + use Interfaces.OS2Lib; + use Interfaces.OS2Lib.Synchronization; + use Interfaces.OS2Lib.Errors; + + ----------- + -- Yield -- + ----------- + + -- Give up the remainder of the time-slice and yield the processor + -- to other threads of equal priority. Yield will return immediately + -- without giving up the current time-slice when the only threads + -- that are ready have a lower priority. + + -- ??? Just giving up the current time-slice seems not to be enough + -- to get the thread to the end of the ready queue if OS/2 does use + -- a queue at all. As a partial work-around, we give up two time-slices. + + -- This is the best we can do now, and at least is sufficient for passing + -- the ACVC 2.0.1 Annex D tests. + + procedure Yield is + begin + Delay_For (0); + Delay_For (0); + end Yield; + + --------------- + -- Delay_For -- + --------------- + + procedure Delay_For (Period : in Duration_In_Millisec) is + Result : APIRET; + + begin + pragma Assert (Period >= 0, "GNULLI---Delay_For: negative argument"); + + -- ??? DosSleep is not the appropriate function for a delay in real + -- time. It only gives up some number of scheduled time-slices. + -- Use a timer instead or block for some semaphore with a time-out. + Result := DosSleep (ULONG (Period)); + + if Result = ERROR_TS_WAKEUP then + + -- Do appropriate processing for interrupted sleep + -- Can we raise an exception here? + + null; + end if; + + pragma Assert (Result = NO_ERROR, "GNULLI---Error in Delay_For"); + end Delay_For; + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + + -- Implement conversion from tick count to Duration + -- using fixed point arithmetic. The frequency of + -- the Intel 8254 timer chip is 18.2 * 2**16 Hz. + + Tick_Duration : constant := 1.0 / (18.2 * 2**16); + Tick_Count : aliased QWORD; + + begin + -- Read nr of clock ticks since boot time + + Must_Not_Fail (DosTmrQueryTime (Tick_Count'Access)); + + return Tick_Count * Tick_Duration; + end Clock; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-os2.ads b/gcc/ada/s-osinte-os2.ads new file mode 100644 index 00000000000..4ddd2d0b06d --- /dev/null +++ b/gcc/ada/s-osinte-os2.ads @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 OS/2 version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; + +package System.OS_Interface is + pragma Preelaborate; + + package C renames Interfaces.C; + + subtype int is C.int; + subtype unsigned_long is C.unsigned_long; + + type Duration_In_Millisec is new C.long; + -- New type to prevent confusing time functions in this package + -- with time functions returning seconds or other units. + + type Thread_Id is new unsigned_long; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 5; + EINTR : constant := 13; + EINVAL : constant := 14; + ENOMEM : constant := 25; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 15; + type Signal is new int range 0 .. Max_Interrupt; + + -- Signals for OS/2, only SIGTERM used currently. The values are + -- fake, since OS/2 uses 32 bit exception numbers that cannot be + -- used to index arrays etc. The GNULLI maps these Unix-like signals + -- to OS/2 exception numbers. + + -- SIGTERM is used for the abort interrupt. + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGEMT : constant := 0; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + + subtype sigset_t is unsigned_long; + + ---------- + -- Time -- + ---------- + + function Clock return Duration; + pragma Inline (Clock); + -- Clock measuring time since the epoch, which is the boot-time. + -- The clock resolution is approximately 838 ns. + + procedure Delay_For (Period : in Duration_In_Millisec); + pragma Inline (Delay_For); + -- Changed Sleep to Delay_For, for consistency with System.Time_Operations + + ---------------- + -- Scheduling -- + ---------------- + + -- Put the calling task at the end of the ready queue for its priority + + procedure Yield; + pragma Inline (Yield); + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-posix.adb b/gcc/ada/s-osinte-posix.adb new file mode 100644 index 00000000000..36c082c86aa --- /dev/null +++ b/gcc/ada/s-osinte-posix.adb @@ -0,0 +1,132 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 GNU/LinuxThreads, Solaris pthread and HP-UX pthread version +-- of this package. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +with Interfaces.C; use Interfaces.C; +package body System.OS_Interface is + + -------------------- + -- Get_Stack_Base -- + -------------------- + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + + begin + return Null_Address; + end Get_Stack_Base; + + ------------------ + -- pthread_init -- + ------------------ + + procedure pthread_init is + begin + null; + end pthread_init; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + function To_Duration (TV : struct_timeval) return Duration is + begin + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end To_Duration; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ---------------- + -- To_Timeval -- + ---------------- + + function To_Timeval (D : Duration) return struct_timeval is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return + struct_timeval' + (tv_sec => S, + tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); + end To_Timeval; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-solaris-fsu.ads b/gcc/ada/s-osinte-solaris-fsu.ads new file mode 100644 index 00000000000..14caf4e3ddd --- /dev/null +++ b/gcc/ada/s-osinte-solaris-fsu.ads @@ -0,0 +1,667 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 a Solaris (FSU THREADS) version of this package + +-- This package includes all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lgthreads"); + pragma Linker_Options ("-lmalloc"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 145; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 45; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + SIGCLD : constant := 18; -- alias for SIGCHLD + SIGCHLD : constant := 18; -- child status change + SIGPWR : constant := 19; -- power-fail restart + SIGWINCH : constant := 20; -- window size change + SIGURG : constant := 21; -- urgent condition on IO channel + SIGPOLL : constant := 22; -- pollable event occurred + SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias) + SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 24; -- user stop requested from tty + SIGCONT : constant := 25; -- stopped process has been continued + SIGTTIN : constant := 26; -- background tty read attempted + SIGTTOU : constant := 27; -- background tty write attempted + SIGVTALRM : constant := 28; -- virtual timer expired + SIGPROF : constant := 29; -- profiling timer expired + SIGXCPU : constant := 30; -- CPU time limit exceeded + SIGXFSZ : constant := 31; -- filesize limit exceeded + SIGWAITING : constant := 32; -- process's lwps blocked (Solaris) + SIGLWP : constant := 33; -- used by thread library (Solaris) + SIGFREEZE : constant := 34; -- used by CPR (Solaris) + SIGTHAW : constant := 35; -- used by CPR (Solaris) + SIGCANCEL : constant := 36; -- used for thread cancel (Solaris) + SIGRTMIN : constant := 38; -- first (highest-priority) realtime signal + SIGRTMAX : constant := 45; -- last (lowest-priority) realtime signal + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := + (SIGTRAP, SIGLWP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); + + Reserved : constant Signal_Set := + (SIGKILL, SIGSTOP, SIGALRM, SIGVTALRM, SIGWAITING, SIGRTMAX); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type union_type_3 is new String (1 .. 116); + type siginfo_t is record + si_signo : int; + si_code : int; + si_errno : int; + X_data : union_type_3; + end record; + pragma Convention (C, siginfo_t); + + -- The types mcontext_t and gregset_t are part of the ucontext_t + -- information, which is specific to Solaris2.4 for SPARC + -- The ucontext_t info seems to be used by the handler + -- for SIGSEGV to decide whether it is a Storage_Error (stack overflow) or + -- a Constraint_Error (bad pointer). The original code that did this + -- is suspect, so it is not clear whether we really need this part of + -- the signal context information, or perhaps something else. + -- More analysis is needed, after which these declarations may need to + -- be changed. + + EMT_TAGOVF : constant := 1; -- tag overflow + FPE_INTDIV : constant := 1; -- integer divide by zero + FPE_INTOVF : constant := 2; -- integer overflow + FPE_FLTDIV : constant := 3; -- floating point divide by zero + FPE_FLTOVF : constant := 4; -- floating point overflow + FPE_FLTUND : constant := 5; -- floating point underflow + FPE_FLTRES : constant := 6; -- floating point inexact result + FPE_FLTINV : constant := 7; -- invalid floating point operation + FPE_FLTSUB : constant := 8; -- subscript out of range + + SEGV_MAPERR : constant := 1; -- address not mapped to object + SEGV_ACCERR : constant := 2; -- invalid permissions + + BUS_ADRALN : constant := 1; -- invalid address alignment + BUS_ADRERR : constant := 2; -- non-existent physical address + BUS_OBJERR : constant := 3; -- object specific hardware error + + ILL_ILLOPC : constant := 1; -- illegal opcode + ILL_ILLOPN : constant := 2; -- illegal operand + ILL_ILLADR : constant := 3; -- illegal addressing mode + ILL_ILLTRP : constant := 4; -- illegal trap + ILL_PRVOPC : constant := 5; -- privileged opcode + ILL_PRVREG : constant := 6; -- privileged register + ILL_COPROC : constant := 7; -- co-processor + ILL_BADSTK : constant := 8; -- bad stack + + type greg_t is new int; + + type gregset_t is array (Integer range 0 .. 18) of greg_t; + + REG_O0 : constant := 11; + -- index of saved register O0 in ucontext.uc_mcontext.gregs array + + type union_type_2 is new String (1 .. 128); + type record_type_1 is record + fpu_fr : union_type_2; + fpu_q : System.Address; + fpu_fsr : unsigned; + fpu_qcnt : unsigned_char; + fpu_q_entrysize : unsigned_char; + fpu_en : unsigned_char; + end record; + pragma Convention (C, record_type_1); + type array_type_7 is array (Integer range 0 .. 20) of long; + type mcontext_t is record + gregs : gregset_t; + gwins : System.Address; + fpregs : record_type_1; + filler : array_type_7; + end record; + pragma Convention (C, mcontext_t); + + type record_type_2 is record + ss_sp : System.Address; + ss_size : int; + ss_flags : int; + end record; + pragma Convention (C, record_type_2); + type array_type_8 is array (Integer range 0 .. 22) of long; + type ucontext_t is record + uc_flags : unsigned_long; + uc_link : System.Address; + uc_sigmask : sigset_t; + uc_stack : record_type_2; + uc_mcontext : mcontext_t; + uc_filler : array_type_8; + end record; + pragma Convention (C, ucontext_t); + + type Signal_Handler is access procedure + (signo : Signal; + info : access siginfo_t; + context : access ucontext_t); + + type union_type_1 is new plain_char; + type array_type_2 is array (Integer range 0 .. 1) of int; + type struct_sigaction is record + sa_flags : int; + sa_handler : System.Address; + sa_mask : sigset_t; + sa_resv : array_type_2; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SA_SIGINFO : constant := 16#08#; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := False; + -- Indicates wether time slicing is supported (i.e FSU threads have been + -- compiled with DEF_RR) + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timeval is private; + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 0; + SCHED_RR : constant := 1; + SCHED_OTHER : constant := 2; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + -- lwp_self does not exist on this thread library, revert to pthread_self + -- which is the closest approximation (with getpid). This function is + -- needed to share 7staprop.adb across POSIX-like targets. + pragma Import (C, lwp_self, "pthread_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + + ----------- + -- Stack -- + ----------- + + Stack_Base_Available : constant Boolean := False; + -- Indicates wether the stack base is available on this target. + -- This allows us to share s-osinte.adb between all the FSU run time. + -- Note that this value can only be true if pthread_t has a complete + -- definition that corresponds exactly to the C header files. + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- returns the stack base of the specified thread. + -- Only call this function when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- returns the size of a page, or 0 if this is not relevant on this + -- target + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + + PROT_ON : constant := PROT_NONE; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + -- FSU_THREADS requires pthread_init, which is nonstandard + -- and this should be invoked during the elaboration of s-taprop.adb + pragma Import (C, pthread_init, "pthread_init"); + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait (set : access sigset_t; sig : access Signal) return int; + -- FSU_THREADS has a nonstandard sigwait + + function pthread_kill (thread : pthread_t; sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + type sigset_t_ptr is access all sigset_t; + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask, "sigprocmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + -- FSU_THREADS has nonstandard pthread_mutex_lock + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + -- FSU_THREADS has nonstandard pthread_mutex_lock + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + -- FSU_THREADS has a nonstandard pthread_cond_wait + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + -- FSU_THREADS has a nonstandard pthread_cond_timedwait + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_PROTECT : constant := 2; + PTHREAD_PRIO_INHERIT : constant := 1; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import + (C, pthread_mutexattr_setprioceiling, + "pthread_mutexattr_setprio_ceiling"); + + type struct_sched_param is record + sched_priority : int; -- scheduling priority + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + -- FSU_THREADS does not have pthread_setschedparam + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy, "pthread_attr_setsched"); + + function sched_yield return int; + -- FSU_THREADS does not have sched_yield; + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + -- FSU_THREADS has a nonstandard pthread_attr_setdetachstate + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + -- FSU_THREADS has a nonstandard pthread_getspecific + + type destructor_pointer is access procedure (arg : System.Address); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + +private + + type array_type_1 is array (Integer range 0 .. 3) of unsigned_long; + type sigset_t is record + X_X_sigbits : array_type_1; + end record; + pragma Convention (C, sigset_t); + + type pid_t is new long; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + + type struct_timeval is record + tv_sec : long; + tv_usec : long; + end record; + pragma Convention (C, struct_timeval); + + type pthread_attr_t is record + flags : int; + stacksize : int; + contentionscope : int; + inheritsched : int; + detachstate : int; + sched : int; + prio : int; + starttime : timespec; + deadline : timespec; + period : timespec; + end record; + pragma Convention (C, pthread_attr_t); + + type pthread_condattr_t is record + flags : int; + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_mutexattr_t is record + flags : int; + prio_ceiling : int; + protocol : int; + end record; + pragma Convention (C, pthread_mutexattr_t); + + type sigjmp_buf is array (Integer range 0 .. 18) of int; + + type pthread_t_struct is record + context : sigjmp_buf; + pbody : sigjmp_buf; + errno : int; + ret : int; + stack_base : System.Address; + end record; + pragma Convention (C, pthread_t_struct); + + type pthread_t is access all pthread_t_struct; + + type queue_t is record + head : System.Address; + tail : System.Address; + end record; + pragma Convention (C, queue_t); + + type pthread_mutex_t is record + queue : queue_t; + lock : plain_char; + owner : System.Address; + flags : int; + prio_ceiling : int; + protocol : int; + prev_max_ceiling_prio : int; + end record; + pragma Convention (C, pthread_mutex_t); + + type pthread_cond_t is record + queue : queue_t; + flags : int; + waiters : int; + mutex : System.Address; + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new int; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-solaris-posix.ads b/gcc/ada/s-osinte-solaris-posix.ads new file mode 100644 index 00000000000..b5ad0af3877 --- /dev/null +++ b/gcc/ada/s-osinte-solaris-posix.ads @@ -0,0 +1,539 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 a Solaris (POSIX Threads) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lposix4"); + pragma Linker_Options ("-lpthread"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 145; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 45; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + SIGCLD : constant := 18; -- alias for SIGCHLD + SIGCHLD : constant := 18; -- child status change + SIGPWR : constant := 19; -- power-fail restart + SIGWINCH : constant := 20; -- window size change + SIGURG : constant := 21; -- urgent condition on IO channel + SIGPOLL : constant := 22; -- pollable event occurred + SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias) + SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 24; -- user stop requested from tty + SIGCONT : constant := 25; -- stopped process has been continued + SIGTTIN : constant := 26; -- background tty read attempted + SIGTTOU : constant := 27; -- background tty write attempted + SIGVTALRM : constant := 28; -- virtual timer expired + SIGPROF : constant := 29; -- profiling timer expired + SIGXCPU : constant := 30; -- CPU time limit exceeded + SIGXFSZ : constant := 31; -- filesize limit exceeded + SIGWAITING : constant := 32; -- process's lwps blocked (Solaris) + SIGLWP : constant := 33; -- used by thread library (Solaris) + SIGFREEZE : constant := 34; -- used by CPR (Solaris) + SIGTHAW : constant := 35; -- used by CPR (Solaris) + SIGCANCEL : constant := 36; -- thread cancellation signal (libthread) + + SIGADAABORT : constant := SIGABRT; + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := (SIGTRAP, SIGLWP, SIGPROF); + + -- Following signals should not be disturbed. + -- See c-posix-signals.c in FLORIST + + Reserved : constant Signal_Set := + (SIGKILL, SIGSTOP, SIGWAITING, SIGCANCEL); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type struct_sigaction is record + sa_flags : int; + sa_handler : System.Address; + sa_mask : sigset_t; + sa_resv1 : int; + sa_resv2 : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SA_SIGINFO : constant := 16#0008#; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := True; + -- Indicates wether time slicing is supported + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timeval is private; + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 1; + SCHED_RR : constant := 2; + SCHED_OTHER : constant := 0; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + pragma Import (C, lwp_self, "_lwp_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 16#40#; + + ----------- + -- Stack -- + ----------- + + Stack_Base_Available : constant Boolean := False; + -- Indicates wether the stack base is available on this target. + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- returns the stack base of the specified thread. + -- Only call this function when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- returns the size of a page, or 0 if this is not relevant on this + -- target + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC; + + PROT_ON : constant := PROT_READ; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + -- This is a dummy procedure to share some GNULLI files + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Import (C, sigwait, "__posix_sigwait"); + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill, "pthread_kill"); + + type sigset_t_ptr is access all sigset_t; + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 0; + PTHREAD_PRIO_INHERIT : constant := 16#10#; + PTHREAD_PRIO_PROTECT : constant := 16#20#; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import (C, pthread_mutexattr_setprioceiling); + + type Array_8_Int is array (0 .. 7) of int; + type struct_sched_param is record + sched_priority : int; + sched_pad : Array_8_Int; + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy); + + function sched_yield return int; + pragma Import (C, sched_yield, "sched_yield"); + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + +private + + type array_type_1 is array (Integer range 0 .. 3) of unsigned_long; + type sigset_t is record + X_X_sigbits : array_type_1; + end record; + pragma Convention (C, sigset_t); + + type pid_t is new long; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + + type struct_timeval is record + tv_sec : time_t; + tv_usec : time_t; + end record; + pragma Convention (C, struct_timeval); + + type pthread_attr_t is record + pthread_attrp : System.Address; + end record; + pragma Convention (C, pthread_attr_t); + + type pthread_condattr_t is record + pthread_condattrp : System.Address; + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_mutexattr_t is record + pthread_mutexattrp : System.Address; + end record; + pragma Convention (C, pthread_mutexattr_t); + + type pthread_t is new unsigned; + + type uint64_t is mod 2 ** 64; + + type pthread_mutex_t is record + pthread_mutex_flags : uint64_t; + pthread_mutex_owner64 : uint64_t; + pthread_mutex_data : uint64_t; + end record; + pragma Convention (C, pthread_mutex_t); + type pthread_mutex_t_ptr is access pthread_mutex_t; + + type pthread_cond_t is record + pthread_cond_flags : uint64_t; + pthread_cond_data : uint64_t; + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new unsigned; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-solaris.adb b/gcc/ada/s-osinte-solaris.adb new file mode 100644 index 00000000000..299625dadc2 --- /dev/null +++ b/gcc/ada/s-osinte-solaris.adb @@ -0,0 +1,100 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 Solaris version of this package. + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Interfaces.C; use Interfaces.C; +package body System.OS_Interface is + + ----------------- + -- 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; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + if F < 0.0 then S := S - 1; F := F + 1.0; end if; + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + function To_Duration (TV : struct_timeval) return Duration is + begin + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end To_Duration; + + 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; + + procedure pthread_init is + begin + null; + end pthread_init; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-solaris.ads b/gcc/ada/s-osinte-solaris.ads new file mode 100644 index 00000000000..b5754630372 --- /dev/null +++ b/gcc/ada/s-osinte-solaris.ads @@ -0,0 +1,569 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 a Solaris (native) version of this package + +-- This package includes all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lposix4"); + pragma Linker_Options ("-lthread"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIME : constant := 62; + ETIMEDOUT : constant := 145; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 45; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + SIGCLD : constant := 18; -- alias for SIGCHLD + SIGCHLD : constant := 18; -- child status change + SIGPWR : constant := 19; -- power-fail restart + SIGWINCH : constant := 20; -- window size change + SIGURG : constant := 21; -- urgent condition on IO channel + SIGPOLL : constant := 22; -- pollable event occurred + SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias) + SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 24; -- user stop requested from tty + SIGCONT : constant := 25; -- stopped process has been continued + SIGTTIN : constant := 26; -- background tty read attempted + SIGTTOU : constant := 27; -- background tty write attempted + SIGVTALRM : constant := 28; -- virtual timer expired + SIGPROF : constant := 29; -- profiling timer expired + SIGXCPU : constant := 30; -- CPU time limit exceeded + SIGXFSZ : constant := 31; -- filesize limit exceeded + SIGWAITING : constant := 32; -- process's lwps blocked (Solaris) + SIGLWP : constant := 33; -- used by thread library (Solaris) + SIGFREEZE : constant := 34; -- used by CPR (Solaris) + SIGTHAW : constant := 35; -- used by CPR (Solaris) + SIGCANCEL : constant := 36; -- thread cancellation signal (libthread) + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := (SIGTRAP, SIGLWP, SIGPROF); + + -- Following signals should not be disturbed. + -- See c-posix-signals.c in FLORIST + + Reserved : constant Signal_Set := + (SIGKILL, SIGSTOP, SIGWAITING, SIGCANCEL, SIGTRAP, SIGSEGV); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type union_type_3 is new String (1 .. 116); + type siginfo_t is record + si_signo : int; + si_code : int; + si_errno : int; + X_data : union_type_3; + end record; + pragma Convention (C, siginfo_t); + + -- The types mcontext_t and gregset_t are part of the ucontext_t + -- information, which is specific to Solaris2.4 for SPARC + -- The ucontext_t info seems to be used by the handler + -- for SIGSEGV to decide whether it is a Storage_Error (stack overflow) or + -- a Constraint_Error (bad pointer). The original code that did this + -- is suspect, so it is not clear whether we really need this part of + -- the signal context information, or perhaps something else. + -- More analysis is needed, after which these declarations may need to + -- be changed. + + FPE_INTDIV : constant := 1; -- integer divide by zero + FPE_INTOVF : constant := 2; -- integer overflow + FPE_FLTDIV : constant := 3; -- floating point divide by zero + FPE_FLTOVF : constant := 4; -- floating point overflow + FPE_FLTUND : constant := 5; -- floating point underflow + FPE_FLTRES : constant := 6; -- floating point inexact result + FPE_FLTINV : constant := 7; -- invalid floating point operation + FPE_FLTSUB : constant := 8; -- subscript out of range + + type greg_t is new int; + + type gregset_t is array (0 .. 18) of greg_t; + + type union_type_2 is new String (1 .. 128); + type record_type_1 is record + fpu_fr : union_type_2; + fpu_q : System.Address; + fpu_fsr : unsigned; + fpu_qcnt : unsigned_char; + fpu_q_entrysize : unsigned_char; + fpu_en : unsigned_char; + end record; + pragma Convention (C, record_type_1); + + type array_type_7 is array (Integer range 0 .. 20) of long; + type mcontext_t is record + gregs : gregset_t; + gwins : System.Address; + fpregs : record_type_1; + filler : array_type_7; + end record; + pragma Convention (C, mcontext_t); + + type record_type_2 is record + ss_sp : System.Address; + ss_size : int; + ss_flags : int; + end record; + pragma Convention (C, record_type_2); + + type array_type_8 is array (Integer range 0 .. 22) of long; + type ucontext_t is record + uc_flags : unsigned_long; + uc_link : System.Address; + uc_sigmask : sigset_t; + uc_stack : record_type_2; + uc_mcontext : mcontext_t; + uc_filler : array_type_8; + end record; + pragma Convention (C, ucontext_t); + + type Signal_Handler is access procedure + (signo : Signal; + info : access siginfo_t; + context : access ucontext_t); + + type union_type_1 is new plain_char; + type array_type_2 is array (Integer range 0 .. 1) of int; + type struct_sigaction is record + sa_flags : int; + sa_handler : System.Address; + sa_mask : sigset_t; + sa_resv : array_type_2; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + function clock_getres + (clock_id : clockid_t; res : access timespec) return int; + pragma Import (C, clock_getres, "clock_getres"); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timeval is private; + -- This is needed on systems that do not have clock_gettime() + -- but do have gettimeofday(). + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + THR_DETACHED : constant := 64; + THR_BOUND : constant := 1; + THR_NEW_LWP : constant := 2; + USYNC_THREAD : constant := 0; + + type thread_t is new unsigned; + subtype Thread_Id is thread_t; + -- These types should be commented ??? + + function To_thread_t is new Unchecked_Conversion (Integer, thread_t); + + type mutex_t is limited private; + + type cond_t is limited private; + + type thread_key_t is private; + + function thr_create + (stack_base : System.Address; + stack_size : size_t; + start_routine : Thread_Body; + arg : System.Address; + flags : int; + new_thread : access thread_t) return int; + pragma Import (C, thr_create, "thr_create"); + + function thr_min_stack return size_t; + pragma Import (C, thr_min_stack, "thr_min_stack"); + + function thr_self return thread_t; + pragma Import (C, thr_self, "thr_self"); + + function mutex_init + (mutex : access mutex_t; + mtype : int; + arg : System.Address) return int; + pragma Import (C, mutex_init, "mutex_init"); + + function mutex_destroy (mutex : access mutex_t) return int; + pragma Import (C, mutex_destroy, "mutex_destroy"); + + function mutex_lock (mutex : access mutex_t) return int; + pragma Import (C, mutex_lock, "mutex_lock"); + + function mutex_unlock (mutex : access mutex_t) return int; + pragma Import (C, mutex_unlock, "mutex_unlock"); + + function cond_init + (cond : access cond_t; + ctype : int; + arg : int) return int; + pragma Import (C, cond_init, "cond_init"); + + function cond_wait + (cond : access cond_t; mutex : access mutex_t) return int; + pragma Import (C, cond_wait, "cond_wait"); + + function cond_timedwait + (cond : access cond_t; + mutex : access mutex_t; + abstime : access timespec) return int; + pragma Import (C, cond_timedwait, "cond_timedwait"); + + function cond_signal (cond : access cond_t) return int; + pragma Import (C, cond_signal, "cond_signal"); + + function cond_destroy (cond : access cond_t) return int; + pragma Import (C, cond_destroy, "cond_destroy"); + + function thr_setspecific + (key : thread_key_t; value : System.Address) return int; + pragma Import (C, thr_setspecific, "thr_setspecific"); + + function thr_getspecific + (key : thread_key_t; + value : access System.Address) return int; + pragma Import (C, thr_getspecific, "thr_getspecific"); + + function thr_keycreate + (key : access thread_key_t; destructor : System.Address) return int; + pragma Import (C, thr_keycreate, "thr_keycreate"); + + function thr_setprio (thread : thread_t; priority : int) return int; + pragma Import (C, thr_setprio, "thr_setprio"); + + procedure thr_exit (status : System.Address); + pragma Import (C, thr_exit, "thr_exit"); + + function thr_setconcurrency (new_level : int) return int; + pragma Import (C, thr_setconcurrency, "thr_setconcurrency"); + + function sigwait (set : access sigset_t; sig : access Signal) return int; + pragma Import (C, sigwait, "__posix_sigwait"); + + function thr_kill (thread : thread_t; sig : Signal) return int; + pragma Import (C, thr_kill, "thr_kill"); + + type sigset_t_ptr is access all sigset_t; + + function thr_sigsetmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, thr_sigsetmask, "thr_sigsetmask"); + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask, "thr_sigsetmask"); + + function thr_suspend (target_thread : thread_t) return int; + pragma Import (C, thr_suspend, "thr_suspend"); + + function thr_continue (target_thread : thread_t) return int; + pragma Import (C, thr_continue, "thr_continue"); + + procedure thr_yield; + pragma Import (C, thr_yield, "thr_yield"); + + --------- + -- LWP -- + --------- + + P_PID : constant := 0; + P_LWPID : constant := 8; + + PC_GETCID : constant := 0; + PC_GETCLINFO : constant := 1; + PC_SETPARMS : constant := 2; + PC_GETPARMS : constant := 3; + PC_ADMIN : constant := 4; + + PC_CLNULL : constant := -1; + + RT_NOCHANGE : constant := -1; + RT_TQINF : constant := -2; + RT_TQDEF : constant := -3; + + PC_CLNMSZ : constant := 16; + + PC_VERSION : constant := 1; + + type lwpid_t is new int; + + type pri_t is new short; + + type id_t is new long; + + P_MYID : constant := -1; + -- the specified LWP or process is the current one. + + type struct_pcinfo is record + pc_cid : id_t; + pc_clname : String (1 .. PC_CLNMSZ); + rt_maxpri : short; + end record; + pragma Convention (C, struct_pcinfo); + + type struct_pcparms is record + pc_cid : id_t; + rt_pri : pri_t; + rt_tqsecs : long; + rt_tqnsecs : long; + end record; + pragma Convention (C, struct_pcparms); + + function priocntl + (ver : int; + id_type : int; + id : lwpid_t; + cmd : int; + arg : System.Address) return Interfaces.C.long; + pragma Import (C, priocntl, "__priocntl"); + + function lwp_self return lwpid_t; + pragma Import (C, lwp_self, "_lwp_self"); + + type processorid_t is new int; + type processorid_t_ptr is access all processorid_t; + + -- Constants for function processor_bind + + PBIND_QUERY : constant processorid_t := -2; + -- the processor bindings are not changed. + + PBIND_NONE : constant processorid_t := -1; + -- the processor bindings of the specified LWPs are cleared. + + -- Flags for function p_online + + PR_OFFLINE : constant int := 1; + -- processor is offline, as quiet as possible + + PR_ONLINE : constant int := 2; + -- processor online + + PR_STATUS : constant int := 3; + -- value passed to p_online to request status + + function p_online (processorid : processorid_t; flag : int) return int; + pragma Import (C, p_online, "p_online"); + + function processor_bind + (id_type : int; + id : id_t; + proc_id : processorid_t; + obind : processorid_t_ptr) return int; + pragma Import (C, processor_bind, "processor_bind"); + + procedure pthread_init; + -- dummy procedure to share s-intman.adb with other Solaris targets. + +private + + type array_type_1 is array (0 .. 3) of unsigned_long; + type sigset_t is record + X_X_sigbits : array_type_1; + end record; + pragma Convention (C, sigset_t); + + type pid_t is new long; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + + type struct_timeval is record + tv_sec : long; + tv_usec : long; + end record; + pragma Convention (C, struct_timeval); + + type array_type_9 is array (0 .. 3) of unsigned_char; + type record_type_3 is record + flag : array_type_9; + Xtype : unsigned_long; + end record; + pragma Convention (C, record_type_3); + + type mutex_t is record + flags : record_type_3; + lock : String (1 .. 8); + data : String (1 .. 8); + end record; + pragma Convention (C, mutex_t); + + type cond_t is record + flag : array_type_9; + Xtype : unsigned_long; + data : String (1 .. 8); + end record; + pragma Convention (C, cond_t); + + type thread_key_t is new unsigned; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-tru64.adb b/gcc/ada/s-osinte-tru64.adb new file mode 100644 index 00000000000..e0b683e52cd --- /dev/null +++ b/gcc/ada/s-osinte-tru64.adb @@ -0,0 +1,135 @@ +------------------------------------------------------------------------------ +-- -- +-- 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) 1998-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 the DEC Unix version of this package. + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Interfaces.C; use Interfaces.C; +with System.Machine_Code; use System.Machine_Code; + +package body System.OS_Interface is + + ------------------ + -- pthread_init -- + ------------------ + + procedure pthread_init is + begin + null; + end pthread_init; + + ------------------ + -- pthread_self -- + ------------------ + + function pthread_self return pthread_t is + Self : pthread_t; + begin + Asm ("call_pal 0x9e" & ASCII.LF & ASCII.HT & + "bis $31, $0, %0", + Outputs => pthread_t'Asm_Output ("=r", Self), + Clobber => "$0"); + return Self; + end pthread_self; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + function To_Duration (TV : struct_timeval) return Duration is + begin + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end To_Duration; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ---------------- + -- To_Timeval -- + ---------------- + + function To_Timeval (D : Duration) return struct_timeval is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return + struct_timeval' + (tv_sec => S, + tv_usec => time_t (Long_Long_Integer (F * 10#1#E6))); + end To_Timeval; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-tru64.ads b/gcc/ada/s-osinte-tru64.ads new file mode 100644 index 00000000000..dc01b058343 --- /dev/null +++ b/gcc/ada/s-osinte-tru64.ads @@ -0,0 +1,539 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 DEC Unix 4.0/5.1 version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lpthread"); + pragma Linker_Options ("-lmach"); + pragma Linker_Options ("-lexc"); + pragma Linker_Options ("-lrt"); + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + subtype char_array is Interfaces.C.char_array; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "_Geterrno"); + + EAGAIN : constant := 35; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 60; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 48; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGIOT : constant := 6; -- abort (terminate) process + SIGLOST : constant := 6; -- old BSD signal ?? + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGURG : constant := 16; -- urgent condition on IO channel + SIGIOINT : constant := 16; -- printer to backend error signal + SIGSTOP : constant := 17; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 18; -- user stop requested from tty + SIGCONT : constant := 19; -- stopped process has been continued + SIGCHLD : constant := 20; -- child status change + SIGTTIN : constant := 21; -- background tty read attempted + SIGTTOU : constant := 22; -- background tty write attempted + SIGPOLL : constant := 23; -- I/O possible, or completed + SIGIO : constant := 23; -- STREAMS version of SIGPOLL + SIGAIO : constant := 23; -- base lan i/o + SIGPTY : constant := 23; -- pty i/o + SIGXCPU : constant := 24; -- CPU time limit exceeded + SIGXFSZ : constant := 25; -- filesize limit exceeded + SIGVTALRM : constant := 26; -- virtual timer expired + SIGPROF : constant := 27; -- profiling timer expired + SIGWINCH : constant := 28; -- window size change + SIGINFO : constant := 29; -- information request + SIGPWR : constant := 29; -- Power Fail/Restart -- SVID3/SVR4 + SIGUSR1 : constant := 30; -- user defined signal 1 + SIGUSR2 : constant := 31; -- user defined signal 2 + SIGRESV : constant := 32; -- reserved by Digital for future use + + SIGADAABORT : constant := SIGABRT; + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := (0 .. 0 => SIGTRAP); + Reserved : constant Signal_Set := (SIGALRM, SIGABRT, SIGKILL, SIGSTOP); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset); + + type union_type_3 is new String (1 .. 116); + type siginfo_t is record + si_signo : int; + si_errno : int; + si_code : int; + X_data : union_type_3; + end record; + for siginfo_t'Size use 8 * 128; + pragma Convention (C, siginfo_t); + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + sa_signo : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + SA_NODEFER : constant := 8; + SA_SIGINFO : constant := 16#40#; + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction); + + ---------- + -- Time -- + ---------- + + type timespec is private; + + function nanosleep (rqtp, rmtp : access timespec) return int; + pragma Import (C, nanosleep); + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + pragma Import (C, clock_gettime); + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timezone is record + tz_minuteswest : int; + tz_dsttime : int; + end record; + pragma Convention (C, struct_timezone); + type struct_timeval is private; + -- This is needed on systems that do not have clock_gettime() + -- but do have gettimeofday(). + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 1; + SCHED_RR : constant := 2; + SCHED_OTHER : constant := 3; + SCHED_LFI : constant := 5; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill); + + function getpid return pid_t; + pragma Import (C, getpid); + + BIND_NO_INHERIT : constant := 1; + + function bind_to_cpu + (pid : pid_t; + cpu_mask : unsigned_long; + flag : unsigned_long := BIND_NO_INHERIT) return int; + pragma Import (C, bind_to_cpu); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 1; + + PTHREAD_SCOPE_PROCESS : constant := 0; + PTHREAD_SCOPE_SYSTEM : constant := 1; + + PTHREAD_EXPLICIT_SCHED : constant := 1; + + --------------------------------------- + -- Nonstandard Thread Initialization -- + --------------------------------------- + + procedure pthread_init; + pragma Inline (pthread_init); + -- This is a dummy procedure to share some GNULLI files + + --------------------------- + -- POSIX.1c Section 3 -- + --------------------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int; + pragma Import (C, sigwait, "__sigwaitd10"); + + function pthread_kill + (thread : pthread_t; + sig : Signal) return int; + pragma Import (C, pthread_kill); + + type sigset_t_ptr is access all sigset_t; + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask); + + ---------------------------- + -- POSIX.1c Section 11 -- + ---------------------------- + + function pthread_mutexattr_init (attr : access pthread_mutexattr_t) + return int; + pragma Import (C, pthread_mutexattr_init); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "__pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "__pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "__pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "__pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "__pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "__pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "__pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "__pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "__pthread_cond_timedwait"); + + ---------------------------- + -- POSIX.1c Section 13 -- + ---------------------------- + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import (C, pthread_mutexattr_setprioceiling); + + type struct_sched_param is record + sched_priority : int; -- scheduling priority + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched, + "__pthread_attr_setinheritsched"); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy); + + function pthread_attr_setschedparam + (attr : access pthread_attr_t; + sched_param : access struct_sched_param) return int; + pragma Import (C, pthread_attr_setschedparam); + + function sched_yield return int; + pragma Import (C, sched_yield); + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) + return int; + pragma Import (C, pthread_attr_init); + + function pthread_attr_destroy (attributes : access pthread_attr_t) + return int; + pragma Import (C, pthread_attr_destroy); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize, "__pthread_attr_setstacksize"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "__pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "__pthread_exit"); + + function pthread_self return pthread_t; + pragma Inline (pthread_self); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; value : System.Address) return int; + pragma Import (C, pthread_setspecific, "__pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "__pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create); + +private + + type sigset_t is new unsigned_long; + + type pid_t is new int; + + type time_t is new int; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 1; + + type struct_timeval is record + tv_sec : time_t; + tv_usec : time_t; + end record; + pragma Convention (C, struct_timeval); + + type unsigned_long_array is array (Natural range <>) of unsigned_long; + + type pthread_t is new System.Address; + + type pthread_cond_t is record + state : unsigned; + valid : unsigned; + name : System.Address; + arg : unsigned; + reserved1 : unsigned; + sequence : unsigned_long; + block : System.Address; + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_attr_t is record + valid : long; + name : System.Address; + arg : unsigned_long; + reserved : unsigned_long_array (0 .. 18); + end record; + pragma Convention (C, pthread_attr_t); + + type pthread_mutex_t is record + lock : unsigned; + valid : unsigned; + name : System.Address; + arg : unsigned; + depth : unsigned; + sequence : unsigned_long; + owner : unsigned_long; + block : System.Address; + end record; + for pthread_mutex_t'Size use 8 * 48; + pragma Convention (C, pthread_mutex_t); + + type pthread_mutexattr_t is record + valid : long; + reserved : unsigned_long_array (0 .. 14); + end record; + pragma Convention (C, pthread_mutexattr_t); + + type pthread_condattr_t is record + valid : long; + reserved : unsigned_long_array (0 .. 12); + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_key_t is new unsigned; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-unixware.adb b/gcc/ada/s-osinte-unixware.adb new file mode 100644 index 00000000000..9916e8846f4 --- /dev/null +++ b/gcc/ada/s-osinte-unixware.adb @@ -0,0 +1,182 @@ +------------------------------------------------------------------------------ +-- -- +-- 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) 1999-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 UnixWare (Native) version of this package + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Interfaces.C; + +package body System.OS_Interface is + + use Interfaces.C; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.tv_sec) + Duration (TS.tv_nsec) / 10#1#E9; + end To_Duration; + + function To_Duration (TV : struct_timeval) return Duration is + begin + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end To_Duration; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return timespec'(tv_sec => S, + tv_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ---------------- + -- To_Timeval -- + ---------------- + + function To_Timeval (D : Duration) return struct_timeval is + S : long; + F : Duration; + + begin + S := long (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return + struct_timeval' + (tv_sec => S, + tv_usec => long (Long_Long_Integer (F * 10#1#E6))); + end To_Timeval; + + ------------------- + -- clock_gettime -- + ------------------- + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) + return int + is + pragma Warnings (Off, clock_id); + + Result : int; + tv : aliased struct_timeval; + + function gettimeofday + (tv : access struct_timeval; + tz : System.Address := System.Null_Address) + return int; + pragma Import (C, gettimeofday, "gettimeofday"); + + begin + Result := gettimeofday (tv'Unchecked_Access); + tp.all := To_Timespec (To_Duration (tv)); + return Result; + end clock_gettime; + + --------------------------- + -- POSIX.1c Section 3 -- + --------------------------- + + function sigwait (set : access sigset_t; sig : access Signal) return int is + Result : int; + + function sigwait (set : access sigset_t) return int; + pragma Import (C, sigwait, "sigwait"); + + begin + Result := sigwait (set); + + if Result < 0 then + sig.all := 0; + return errno; + end if; + + sig.all := Signal (Result); + return 0; + end sigwait; + + function pthread_kill (thread : pthread_t; sig : Signal) return int is + function pthread_kill_base + (thread : access pthread_t; sig : access Signal) return int; + pragma Import (C, pthread_kill_base, "pthread_kill"); + + thr : aliased pthread_t := thread; + signo : aliased Signal := sig; + + begin + return pthread_kill_base (thr'Unchecked_Access, signo'Unchecked_Access); + end pthread_kill; + + function Get_Stack_Base (thread : pthread_t) return Address is + pragma Warnings (Off, thread); + + begin + return Null_Address; + end Get_Stack_Base; + + procedure pthread_init is + begin + null; + end pthread_init; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-unixware.ads b/gcc/ada/s-osinte-unixware.ads new file mode 100644 index 00000000000..efc55eb54d5 --- /dev/null +++ b/gcc/ada/s-osinte-unixware.ads @@ -0,0 +1,600 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 a UnixWare (Native THREADS) version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("-lthread"); + + subtype int is Interfaces.C.int; + subtype char is Interfaces.C.char; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EAGAIN : constant := 11; + EINTR : constant := 4; + EINVAL : constant := 22; + ENOMEM : constant := 12; + ETIMEDOUT : constant := 145; + + ------------- + -- Signals -- + ------------- + + Max_Interrupt : constant := 34; + type Signal is new int range 0 .. Max_Interrupt; + for Signal'Size use int'Size; + + SIGHUP : constant := 1; -- hangup + SIGINT : constant := 2; -- interrupt (rubout) + SIGQUIT : constant := 3; -- quit (ASCD FS) + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGTRAP : constant := 5; -- trace trap (not reset) + SIGIOT : constant := 6; -- IOT instruction + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGEMT : constant := 7; -- EMT instruction + SIGFPE : constant := 8; -- floating point exception + SIGKILL : constant := 9; -- kill (cannot be caught or ignored) + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + SIGSYS : constant := 12; -- bad argument to system call + SIGPIPE : constant := 13; -- write on a pipe with no one to read it + SIGALRM : constant := 14; -- alarm clock + SIGTERM : constant := 15; -- software termination signal from kill + SIGUSR1 : constant := 16; -- user defined signal 1 + SIGUSR2 : constant := 17; -- user defined signal 2 + SIGCLD : constant := 18; -- alias for SIGCHLD + SIGCHLD : constant := 18; -- child status change + SIGPWR : constant := 19; -- power-fail restart + SIGWINCH : constant := 20; -- window size change + SIGURG : constant := 21; -- urgent condition on IO channel + SIGPOLL : constant := 22; -- pollable event occurred + SIGIO : constant := 22; -- I/O possible (Solaris SIGPOLL alias) + SIGSTOP : constant := 23; -- stop (cannot be caught or ignored) + SIGTSTP : constant := 24; -- user stop requested from tty + SIGCONT : constant := 25; -- stopped process has been continued + SIGTTIN : constant := 26; -- background tty read attempted + SIGTTOU : constant := 27; -- background tty write attempted + SIGVTALRM : constant := 28; -- virtual timer expired + SIGPROF : constant := 29; -- profiling timer expired + SIGXCPU : constant := 30; -- CPU time limit exceeded + SIGXFSZ : constant := 31; -- filesize limit exceeded + SIGWAITING : constant := 32; -- all LWPs blocked interruptibly notific. + SIGLWP : constant := 33; -- signal reserved for thread lib impl. + SIGAIO : constant := 34; -- Asynchronous I/O signal + + SIGADAABORT : constant := SIGABRT; + -- Change this if you want to use another signal for task abort. + -- SIGTERM might be a good one. + + type Signal_Set is array (Natural range <>) of Signal; + + Unmasked : constant Signal_Set := + (SIGTRAP, SIGLWP, SIGWAITING, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF); + Reserved : constant Signal_Set := (SIGABRT, SIGKILL, SIGSTOP); + + type sigset_t is private; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + type struct_sigaction is record + sa_flags : int; + sa_handler : System.Address; + sa_mask : sigset_t; + sa_resv1 : int; + sa_resv2 : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + -- SIG_ERR : constant := -1; + -- not used + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + ---------- + -- Time -- + ---------- + + Time_Slice_Supported : constant Boolean := False; + -- Indicates wether time slicing is supported + + type timespec is private; + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; + + function clock_gettime + (clock_id : clockid_t; + tp : access timespec) return int; + -- UnixWare threads don't have clock_gettime + -- We instead use gettimeofday() + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + type struct_timezone is record + tz_minuteswest : int; + tz_dsttime : int; + end record; + pragma Convention (C, struct_timezone); + type struct_timezone_ptr is access all struct_timezone; + + type struct_timeval is private; + -- This is needed on systems that do not have clock_gettime() + -- but do have gettimeofday(). + + function To_Duration (TV : struct_timeval) return Duration; + pragma Inline (To_Duration); + + function To_Timeval (D : Duration) return struct_timeval; + pragma Inline (To_Timeval); + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 2; + SCHED_RR : constant := 3; + SCHED_OTHER : constant := 1; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + function getpid return pid_t; + pragma Import (C, getpid, "getpid"); + + --------- + -- LWP -- + --------- + + function lwp_self return System.Address; + pragma Import (C, lwp_self, "_lwp_self"); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_DETACHED : constant := 0; + + ----------- + -- Stack -- + ----------- + + Stack_Base_Available : constant Boolean := False; + -- Indicates wether the stack base is available on this target. + + function Get_Stack_Base (thread : pthread_t) return Address; + pragma Inline (Get_Stack_Base); + -- returns the stack base of the specified thread. + -- Only call this function when Stack_Base_Available is True. + + function Get_Page_Size return size_t; + function Get_Page_Size return Address; + pragma Import (C, Get_Page_Size, "getpagesize"); + -- returns the size of a page, or 0 if this is not relevant on this + -- target + + PROT_NONE : constant := 0; + PROT_READ : constant := 1; + PROT_WRITE : constant := 2; + PROT_EXEC : constant := 4; + PROT_USER : constant := 8; + PROT_ALL : constant := PROT_READ + PROT_WRITE + PROT_EXEC + PROT_USER; + + PROT_ON : constant := PROT_READ; + PROT_OFF : constant := PROT_ALL; + + function mprotect (addr : Address; len : size_t; prot : int) return int; + pragma Import (C, mprotect); + + ------------------------- + -- POSIX.1c Section 3 -- + ------------------------- + + function sigwait (set : access sigset_t; sig : access Signal) return int; + pragma Inline (sigwait); + -- UnixWare provides a non standard sigwait + + function pthread_kill (thread : pthread_t; sig : Signal) return int; + pragma Inline (pthread_kill); + -- UnixWare provides a non standard pthread_kill + + type sigset_t_ptr is access all sigset_t; + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask, "pthread_sigmask"); + + -------------------------- + -- POSIX.1c Section 11 -- + -------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "pthread_mutexattr_init"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "pthread_mutexattr_destroy"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "pthread_mutex_init"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "pthread_mutex_destroy"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "pthread_mutex_lock"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "pthread_mutex_unlock"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "pthread_condattr_init"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "pthread_condattr_destroy"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "pthread_cond_init"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "pthread_cond_destroy"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "pthread_cond_signal"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "pthread_cond_wait"); + + function pthread_cond_timedwait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t; + abstime : access timespec) return int; + pragma Import (C, pthread_cond_timedwait, "pthread_cond_timedwait"); + + Relative_Timed_Wait : constant Boolean := False; + -- pthread_cond_timedwait requires an absolute delay time + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + PTHREAD_PRIO_NONE : constant := 1; + PTHREAD_PRIO_INHERIT : constant := 2; + PTHREAD_PRIO_PROTECT : constant := 3; + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; + protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol); + + function pthread_mutexattr_setprioceiling + (attr : access pthread_mutexattr_t; + prioceiling : int) return int; + pragma Import (C, pthread_mutexattr_setprioceiling); + + type sched_union is record + sched_fifo : int; + sched_fcfs : int; + sched_other : int; + sched_ts : int; + policy_params : long; + end record; + + type struct_sched_param is record + sched_priority : int; + sched_other_stuff : sched_union; + end record; + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "pthread_setschedparam"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "pthread_attr_setscope"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; + policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy); + + function sched_yield return int; + pragma Import (C, sched_yield, "sched_yield"); + + --------------------------- + -- P1003.1c - Section 16 -- + --------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "pthread_attr_init"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "pthread_attr_destroy"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "pthread_create"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "pthread_exit"); + + function pthread_self return pthread_t; + pragma Import (C, pthread_self, "pthread_self"); + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "pthread_setspecific"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "pthread_getspecific"); + + type destructor_pointer is access procedure (arg : System.Address); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "pthread_key_create"); + + procedure pthread_init; + -- This is a dummy procedure to share some GNULLI files + +private + + type sigbit_array is array (1 .. 4) of unsigned; + type sigset_t is record + sa_sigbits : sigbit_array; + end record; + pragma Convention (C_Pass_By_Copy, sigset_t); + + type pid_t is new unsigned; + + type time_t is new long; + + type timespec is record + tv_sec : time_t; + tv_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + + type struct_timeval is record + tv_sec : long; + tv_usec : long; + end record; + pragma Convention (C, struct_timeval); + + type pthread_attr_t is record + pt_attr_status : int; + pt_attr_stacksize : size_t; + pt_attr_stackaddr : System.Address; + pt_attr_detachstate : int; + pt_attr_contentionscope : int; + pt_attr_inheritsched : int; + pt_attr_schedpolicy : int; + pt_attr_sched_param : struct_sched_param; + pt_attr_tlflags : int; + end record; + pragma Convention (C, pthread_attr_t); + + type pthread_condattr_t is record + pt_condattr_status : int; + pt_condattr_pshared : int; + end record; + pragma Convention (C, pthread_condattr_t); + + type pthread_mutexattr_t is record + pt_mutexattr_status : int; + pt_mutexattr_pshared : int; + pt_mutexattr_type : int; + end record; + pragma Convention (C, pthread_mutexattr_t); + + type thread_t is new long; + type pthread_t is new thread_t; + + type thrq_elt_t; + type thrq_elt_t_ptr is access all thrq_elt_t; + + type thrq_elt_t is record + thrq_next : thrq_elt_t_ptr; + thrq_prev : thrq_elt_t_ptr; + end record; + pragma Convention (C, thrq_elt_t); + + type lwp_mutex_t is record + wanted : char; + lock : unsigned_char; + end record; + pragma Convention (C, lwp_mutex_t); + pragma Volatile (lwp_mutex_t); + + type mutex_t is record + m_lmutex : lwp_mutex_t; + m_sync_lock : lwp_mutex_t; + m_type : int; + m_sleepq : thrq_elt_t; + filler1 : int; + filler2 : int; + end record; + pragma Convention (C, mutex_t); + pragma Volatile (mutex_t); + + type pthread_mutex_t is record + pt_mutex_mutex : mutex_t; + pt_mutex_pid : pid_t; + pt_mutex_owner : thread_t; + pt_mutex_depth : int; + pt_mutex_attr : pthread_mutexattr_t; + end record; + pragma Convention (C, pthread_mutex_t); + + type lwp_cond_t is record + wanted : char; + end record; + pragma Convention (C, lwp_cond_t); + pragma Volatile (lwp_cond_t); + + type cond_t is record + c_lcond : lwp_cond_t; + c_sync_lock : lwp_mutex_t; + c_type : int; + c_syncq : thrq_elt_t; + end record; + pragma Convention (C, cond_t); + pragma Volatile (cond_t); + + type pthread_cond_t is record + pt_cond_cond : cond_t; + pt_cond_attr : pthread_condattr_t; + end record; + pragma Convention (C, pthread_cond_t); + + type pthread_key_t is new unsigned; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-vms.adb b/gcc/ada/s-osinte-vms.adb new file mode 100644 index 00000000000..0b806daa809 --- /dev/null +++ b/gcc/ada/s-osinte-vms.adb @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 OpenVMS/Alpha version of this package. + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Interfaces.C; use Interfaces.C; +with System.Machine_Code; use System.Machine_Code; + +package body System.OS_Interface is + + ------------------ + -- pthread_self -- + ------------------ + + function pthread_self return pthread_t is + use ASCII; + Self : pthread_t; + + begin + Asm ("call_pal 0x9e" & LF & HT & + "bis $31, $0, %0", + Outputs => pthread_t'Asm_Output ("=r", Self), + Clobber => "$0"); + return Self; + end pthread_self; + + ----------------- + -- sched_yield -- + ----------------- + + function sched_yield return int is + procedure sched_yield_base; + pragma Import (C, sched_yield_base, "PTHREAD_YIELD_NP"); + + begin + sched_yield_base; + return 0; + end sched_yield; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-vms.ads b/gcc/ada/s-osinte-vms.ads new file mode 100644 index 00000000000..333e02a37b8 --- /dev/null +++ b/gcc/ada/s-osinte-vms.ads @@ -0,0 +1,646 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 a OpenVMS/Alpha version of this package + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with Unchecked_Conversion; + +package System.OS_Interface is + pragma Preelaborate; + + pragma Linker_Options ("--for-linker=sys$library:pthread$rtl.exe"); + -- Link in the DEC threads library. + + -- pragma Linker_Options ("--for-linker=/threads_enable"); + -- Enable upcalls and multiple kernel threads. + + subtype int is Interfaces.C.int; + subtype short is Interfaces.C.short; + subtype long is Interfaces.C.long; + subtype unsigned is Interfaces.C.unsigned; + subtype unsigned_short is Interfaces.C.unsigned_short; + subtype unsigned_long is Interfaces.C.unsigned_long; + subtype unsigned_char is Interfaces.C.unsigned_char; + subtype plain_char is Interfaces.C.plain_char; + subtype size_t is Interfaces.C.size_t; + + ----------------------------- + -- Signals (Interrupt IDs) -- + ----------------------------- + + -- Type signal has an arbitrary limit of 31 + + Max_Interrupt : constant := 31; + type Signal is new unsigned range 0 .. Max_Interrupt; + for Signal'Size use unsigned'Size; + + type sigset_t is array (Signal) of Boolean; + pragma Pack (sigset_t); + + -- Interrupt_Number_Type + -- Unsigned long integer denoting the number of an interrupt + + subtype Interrupt_Number_Type is unsigned_long; + + -- OpenVMS system services return values of type Cond_Value_Type. + + subtype Cond_Value_Type is unsigned_long; + subtype Short_Cond_Value_Type is unsigned_short; + + type IO_Status_Block_Type is record + Status : Short_Cond_Value_Type; + Count : unsigned_short; + Dev_Info : unsigned_long; + end record; + + type AST_Handler is access procedure (Param : Address); + No_AST_Handler : constant AST_Handler := null; + + CMB_M_READONLY : constant := 16#00000001#; + CMB_M_WRITEONLY : constant := 16#00000002#; + AGN_M_READONLY : constant := 16#00000001#; + AGN_M_WRITEONLY : constant := 16#00000002#; + + IO_WRITEVBLK : constant := 48; -- WRITE VIRTUAL BLOCK + IO_READVBLK : constant := 49; -- READ VIRTUAL BLOCK + + ---------------- + -- Sys_Assign -- + ---------------- + -- + -- Assign I/O Channel + -- + -- Status = returned status + -- Devnam = address of device name or logical name string + -- descriptor + -- Chan = address of word to receive channel number assigned + -- Acmode = access mode associated with channel + -- Mbxnam = address of mailbox logical name string descriptor, if + -- mailbox associated with device + -- Flags = optional channel flags longword for specifying options + -- for the $ASSIGN operation + -- + + procedure Sys_Assign + (Status : out Cond_Value_Type; + Devnam : in String; + Chan : out unsigned_short; + Acmode : in unsigned_short := 0; + Mbxnam : in String := String'Null_Parameter; + Flags : in unsigned_long := 0); + pragma Interface (External, Sys_Assign); + pragma Import_Valued_Procedure + (Sys_Assign, "SYS$ASSIGN", + (Cond_Value_Type, String, unsigned_short, + unsigned_short, String, unsigned_long), + (Value, Descriptor (s), Reference, + Value, Descriptor (s), Value), + Flags); + + ---------------- + -- Sys_Cantim -- + ---------------- + -- + -- Cancel Timer + -- + -- Status = returned status + -- Reqidt = ID of timer to be cancelled + -- Acmode = Access mode + -- + procedure Sys_Cantim + (Status : out Cond_Value_Type; + Reqidt : in Address; + Acmode : in unsigned); + pragma Interface (External, Sys_Cantim); + pragma Import_Valued_Procedure + (Sys_Cantim, "SYS$CANTIM", + (Cond_Value_Type, Address, unsigned), + (Value, Value, Value)); + + ---------------- + -- Sys_Crembx -- + ---------------- + -- + -- Create mailbox + -- + -- Status = returned status + -- Prmflg = permanent flag + -- Chan = channel + -- Maxmsg = maximum message + -- Bufquo = buufer quote + -- Promsk = protection mast + -- Acmode = access mode + -- Lognam = logical name + -- Flags = flags + -- + procedure Sys_Crembx + (Status : out Cond_Value_Type; + Prmflg : in Boolean; + Chan : out unsigned_short; + Maxmsg : in unsigned_long := 0; + Bufquo : in unsigned_long := 0; + Promsk : in unsigned_short := 0; + Acmode : in unsigned_short := 0; + Lognam : in String; + Flags : in unsigned_long := 0); + pragma Interface (External, Sys_Crembx); + pragma Import_Valued_Procedure + (Sys_Crembx, "SYS$CREMBX", + (Cond_Value_Type, Boolean, unsigned_short, + unsigned_long, unsigned_long, unsigned_short, + unsigned_short, String, unsigned_long), + (Value, Value, Reference, + Value, Value, Value, + Value, Descriptor (s), Value)); + + ------------- + -- Sys_QIO -- + ------------- + -- + -- Queue I/O + -- + -- Status = Returned status of call + -- EFN = event flag to be set when I/O completes + -- Chan = channel + -- Func = function + -- Iosb = I/O status block + -- Astadr = system trap to be generated when I/O completes + -- Astprm = AST parameter + -- P1-6 = optional parameters + + procedure Sys_QIO + (Status : out Cond_Value_Type; + EFN : in unsigned_long := 0; + Chan : in unsigned_short; + Func : in unsigned_long := 0; + Iosb : out IO_Status_Block_Type; + Astadr : in AST_Handler := No_AST_Handler; + Astprm : in Address := Null_Address; + P1 : in unsigned_long := 0; + P2 : in unsigned_long := 0; + P3 : in unsigned_long := 0; + P4 : in unsigned_long := 0; + P5 : in unsigned_long := 0; + P6 : in unsigned_long := 0); + + procedure Sys_QIO + (Status : out Cond_Value_Type; + EFN : in unsigned_long := 0; + Chan : in unsigned_short; + Func : in unsigned_long := 0; + Iosb : in Address := Null_Address; + Astadr : in AST_Handler := No_AST_Handler; + Astprm : in Address := Null_Address; + P1 : in unsigned_long := 0; + P2 : in unsigned_long := 0; + P3 : in unsigned_long := 0; + P4 : in unsigned_long := 0; + P5 : in unsigned_long := 0; + P6 : in unsigned_long := 0); + + pragma Interface (External, Sys_QIO); + pragma Import_Valued_Procedure + (Sys_QIO, "SYS$QIO", + (Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long, + IO_Status_Block_Type, AST_Handler, Address, + unsigned_long, unsigned_long, unsigned_long, + unsigned_long, unsigned_long, unsigned_long), + (Value, Value, Value, Value, + Reference, Value, Value, + Value, Value, Value, + Value, Value, Value)); + + pragma Import_Valued_Procedure + (Sys_QIO, "SYS$QIO", + (Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long, + Address, AST_Handler, Address, + unsigned_long, unsigned_long, unsigned_long, + unsigned_long, unsigned_long, unsigned_long), + (Value, Value, Value, Value, + Value, Value, Value, + Value, Value, Value, + Value, Value, Value)); + + ---------------- + -- Sys_Setimr -- + ---------------- + -- + -- Set Timer + -- + -- Status = Returned status of call + -- EFN = event flag to be set when timer expires + -- Tim = expiration time + -- AST = system trap to be generated when timer expires + -- Redidt = returned ID of timer (e.g. to cancel timer) + -- Flags = flags + -- + procedure Sys_Setimr + (Status : out Cond_Value_Type; + EFN : in unsigned_long; + Tim : in Long_Integer; + AST : in AST_Handler; + Reqidt : in Address; + Flags : in unsigned_long); + pragma Interface (External, Sys_Setimr); + pragma Import_Valued_Procedure + (Sys_Setimr, "SYS$SETIMR", + (Cond_Value_Type, unsigned_long, Long_Integer, + AST_Handler, Address, unsigned_long), + (Value, Value, Reference, + Value, Value, Value)); + + Interrupt_ID_0 : constant := 0; + Interrupt_ID_1 : constant := 1; + Interrupt_ID_2 : constant := 2; + Interrupt_ID_3 : constant := 3; + Interrupt_ID_4 : constant := 4; + Interrupt_ID_5 : constant := 5; + Interrupt_ID_6 : constant := 6; + Interrupt_ID_7 : constant := 7; + Interrupt_ID_8 : constant := 8; + Interrupt_ID_9 : constant := 9; + Interrupt_ID_10 : constant := 10; + Interrupt_ID_11 : constant := 11; + Interrupt_ID_12 : constant := 12; + Interrupt_ID_13 : constant := 13; + Interrupt_ID_14 : constant := 14; + Interrupt_ID_15 : constant := 15; + Interrupt_ID_16 : constant := 16; + Interrupt_ID_17 : constant := 17; + Interrupt_ID_18 : constant := 18; + Interrupt_ID_19 : constant := 19; + Interrupt_ID_20 : constant := 20; + Interrupt_ID_21 : constant := 21; + Interrupt_ID_22 : constant := 22; + Interrupt_ID_23 : constant := 23; + Interrupt_ID_24 : constant := 24; + Interrupt_ID_25 : constant := 25; + Interrupt_ID_26 : constant := 26; + Interrupt_ID_27 : constant := 27; + Interrupt_ID_28 : constant := 28; + Interrupt_ID_29 : constant := 29; + Interrupt_ID_30 : constant := 30; + Interrupt_ID_31 : constant := 31; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "__get_errno"); + + EINTR : constant := 4; -- Interrupted system call + EAGAIN : constant := 11; -- No more processes + ENOMEM : constant := 12; -- Not enough core + + ------------------------- + -- Priority Scheduling -- + ------------------------- + + SCHED_FIFO : constant := 1; + SCHED_RR : constant := 2; + SCHED_OTHER : constant := 3; + SCHED_BG : constant := 4; + SCHED_LFI : constant := 5; + SCHED_LRR : constant := 6; + + ------------- + -- Process -- + ------------- + + type pid_t is private; + + function kill (pid : pid_t; sig : Signal) return int; + pragma Import (C, kill); + + function getpid return pid_t; + pragma Import (C, getpid); + + ------------- + -- Threads -- + ------------- + + type Thread_Body is access + function (arg : System.Address) return System.Address; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + type pthread_t is private; + subtype Thread_Id is pthread_t; + + type pthread_mutex_t is limited private; + type pthread_cond_t is limited private; + type pthread_attr_t is limited private; + type pthread_mutexattr_t is limited private; + type pthread_condattr_t is limited private; + type pthread_key_t is private; + + PTHREAD_CREATE_JOINABLE : constant := 0; + PTHREAD_CREATE_DETACHED : constant := 1; + + PTHREAD_CANCEL_DISABLE : constant := 0; + PTHREAD_CANCEL_ENABLE : constant := 1; + + PTHREAD_CANCEL_DEFERRED : constant := 0; + PTHREAD_CANCEL_ASYNCHRONOUS : constant := 1; + + -- Don't use ERRORCHECK mutexes, they don't work when a thread is not + -- the owner. AST's, at least, unlock others threads mutexes. Even + -- if the error is ignored, they don't work. + PTHREAD_MUTEX_NORMAL_NP : constant := 0; + PTHREAD_MUTEX_RECURSIVE_NP : constant := 1; + PTHREAD_MUTEX_ERRORCHECK_NP : constant := 2; + + PTHREAD_INHERIT_SCHED : constant := 0; + PTHREAD_EXPLICIT_SCHED : constant := 1; + + function pthread_cancel (thread : pthread_t) return int; + pragma Import (C, pthread_cancel, "PTHREAD_CANCEL"); + + procedure pthread_testcancel; + pragma Import (C, pthread_testcancel, "PTHREAD_TESTCANCEL"); + + function pthread_setcancelstate + (newstate : int; oldstate : access int) return int; + pragma Import (C, pthread_setcancelstate, "PTHREAD_SETCANCELSTATE"); + + function pthread_setcanceltype + (newtype : int; oldtype : access int) return int; + pragma Import (C, pthread_setcanceltype, "PTHREAD_SETCANCELTYPE"); + + --------------------------- + -- POSIX.1c Section 3 -- + --------------------------- + + function pthread_lock_global_np return int; + pragma Import (C, pthread_lock_global_np, "PTHREAD_LOCK_GLOBAL_NP"); + + function pthread_unlock_global_np return int; + pragma Import (C, pthread_unlock_global_np, "PTHREAD_UNLOCK_GLOBAL_NP"); + + ---------------------------- + -- POSIX.1c Section 11 -- + ---------------------------- + + function pthread_mutexattr_init + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_init, "PTHREAD_MUTEXATTR_INIT"); + + function pthread_mutexattr_destroy + (attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutexattr_destroy, "PTHREAD_MUTEXATTR_DESTROY"); + + function pthread_mutexattr_settype_np + (attr : access pthread_mutexattr_t; + mutextype : int) return int; + pragma Import (C, pthread_mutexattr_settype_np, + "PTHREAD_MUTEXATTR_SETTYPE_NP"); + + function pthread_mutex_init + (mutex : access pthread_mutex_t; + attr : access pthread_mutexattr_t) return int; + pragma Import (C, pthread_mutex_init, "PTHREAD_MUTEX_INIT"); + + function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_destroy, "PTHREAD_MUTEX_DESTROY"); + + function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_lock, "PTHREAD_MUTEX_LOCK"); + + function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_mutex_unlock, "PTHREAD_MUTEX_UNLOCK"); + + function pthread_condattr_init + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_init, "PTHREAD_CONDATTR_INIT"); + + function pthread_condattr_destroy + (attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_condattr_destroy, "PTHREAD_CONDATTR_DESTROY"); + + function pthread_cond_init + (cond : access pthread_cond_t; + attr : access pthread_condattr_t) return int; + pragma Import (C, pthread_cond_init, "PTHREAD_COND_INIT"); + + function pthread_cond_destroy (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_destroy, "PTHREAD_COND_DESTROY"); + + function pthread_cond_signal (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal, "PTHREAD_COND_SIGNAL"); + + function pthread_cond_signal_int_np + (cond : access pthread_cond_t) return int; + pragma Import (C, pthread_cond_signal_int_np, + "PTHREAD_COND_SIGNAL_INT_NP"); + + function pthread_cond_wait + (cond : access pthread_cond_t; + mutex : access pthread_mutex_t) return int; + pragma Import (C, pthread_cond_wait, "PTHREAD_COND_WAIT"); + + -------------------------- + -- POSIX.1c Section 13 -- + -------------------------- + + function pthread_mutexattr_setprotocol + (attr : access pthread_mutexattr_t; protocol : int) return int; + pragma Import (C, pthread_mutexattr_setprotocol, + "PTHREAD_MUTEXATTR_SETPROTOCOL"); + + type struct_sched_param is record + sched_priority : int; -- scheduling priority + end record; + for struct_sched_param'Size use 8*4; + pragma Convention (C, struct_sched_param); + + function pthread_setschedparam + (thread : pthread_t; + policy : int; + param : access struct_sched_param) return int; + pragma Import (C, pthread_setschedparam, "PTHREAD_SETSCHEDPARAM"); + + function pthread_attr_setscope + (attr : access pthread_attr_t; + contentionscope : int) return int; + pragma Import (C, pthread_attr_setscope, "PTHREAD_ATTR_SETSCOPE"); + + function pthread_attr_setinheritsched + (attr : access pthread_attr_t; + inheritsched : int) return int; + pragma Import (C, pthread_attr_setinheritsched, + "PTHREAD_ATTR_SETINHERITSCHED"); + + function pthread_attr_setschedpolicy + (attr : access pthread_attr_t; policy : int) return int; + pragma Import (C, pthread_attr_setschedpolicy, + "PTHREAD_ATTR_SETSCHEDPOLICY"); + + function pthread_attr_setschedparam + (attr : access pthread_attr_t; + sched_param : int) return int; + pragma Import (C, pthread_attr_setschedparam, "PTHREAD_ATTR_SETSCHEDPARAM"); + + function sched_yield return int; + + ----------------------------- + -- P1003.1c - Section 16 -- + ----------------------------- + + function pthread_attr_init (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_init, "PTHREAD_ATTR_INIT"); + + function pthread_attr_destroy + (attributes : access pthread_attr_t) return int; + pragma Import (C, pthread_attr_destroy, "PTHREAD_ATTR_DESTROY"); + + function pthread_attr_setdetachstate + (attr : access pthread_attr_t; + detachstate : int) return int; + pragma Import (C, pthread_attr_setdetachstate, + "PTHREAD_ATTR_SETDETACHSTATE"); + + function pthread_attr_setstacksize + (attr : access pthread_attr_t; + stacksize : size_t) return int; + pragma Import (C, pthread_attr_setstacksize, "PTHREAD_ATTR_SETSTACKSIZE"); + + function pthread_create + (thread : access pthread_t; + attributes : access pthread_attr_t; + start_routine : Thread_Body; + arg : System.Address) return int; + pragma Import (C, pthread_create, "PTHREAD_CREATE"); + + procedure pthread_exit (status : System.Address); + pragma Import (C, pthread_exit, "PTHREAD_EXIT"); + + function pthread_self return pthread_t; + + -------------------------- + -- POSIX.1c Section 17 -- + -------------------------- + + function pthread_setspecific + (key : pthread_key_t; + value : System.Address) return int; + pragma Import (C, pthread_setspecific, "PTHREAD_SETSPECIFIC"); + + function pthread_getspecific (key : pthread_key_t) return System.Address; + pragma Import (C, pthread_getspecific, "PTHREAD_GETSPECIFIC"); + + type destructor_pointer is access procedure (arg : System.Address); + + function pthread_key_create + (key : access pthread_key_t; + destructor : destructor_pointer) return int; + pragma Import (C, pthread_key_create, "PTHREAD_KEY_CREATE"); + +private + + type pid_t is new int; + + type pthreadLongAddr_p is mod 2 ** Long_Integer'Size; + + type pthreadLongAddr_t is mod 2 ** Long_Integer'Size; + type pthreadLongAddr_t_ptr is mod 2 ** Long_Integer'Size; + + type pthreadLongString_t is mod 2 ** Long_Integer'Size; + + type pthreadLongUint_t is mod 2 ** Long_Integer'Size; + type pthreadLongUint_array is array (Natural range <>) + of pthreadLongUint_t; + + type pthread_t is mod 2 ** Long_Integer'Size; + + type pthread_cond_t is record + state : unsigned; + valid : unsigned; + name : pthreadLongString_t; + arg : unsigned; + sequence : unsigned; + block : pthreadLongAddr_t_ptr; + end record; + for pthread_cond_t'Size use 8*32; + pragma Convention (C, pthread_cond_t); + + type pthread_attr_t is record + valid : long; + name : pthreadLongString_t; + arg : pthreadLongUint_t; + reserved : pthreadLongUint_array (0 .. 18); + end record; + for pthread_attr_t'Size use 8*176; + pragma Convention (C, pthread_attr_t); + + type pthread_mutex_t is record + lock : unsigned; + valid : unsigned; + name : pthreadLongString_t; + arg : unsigned; + sequence : unsigned; + block : pthreadLongAddr_p; + owner : unsigned; + depth : unsigned; + end record; + for pthread_mutex_t'Size use 8*40; + pragma Convention (C, pthread_mutex_t); + + type pthread_mutexattr_t is record + valid : long; + reserved : pthreadLongUint_array (0 .. 14); + end record; + for pthread_mutexattr_t'Size use 8*128; + pragma Convention (C, pthread_mutexattr_t); + + type pthread_condattr_t is record + valid : long; + reserved : pthreadLongUint_array (0 .. 12); + end record; + for pthread_condattr_t'Size use 8*112; + pragma Convention (C, pthread_condattr_t); + + type pthread_key_t is new unsigned; + + pragma Inline (pthread_self); + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-vxworks.adb b/gcc/ada/s-osinte-vxworks.adb new file mode 100644 index 00000000000..7c665e7d2a4 --- /dev/null +++ b/gcc/ada/s-osinte-vxworks.adb @@ -0,0 +1,164 @@ +------------------------------------------------------------------------------ +-- -- +-- 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) 1997-2002 Free Software Foundation -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks version. + +-- This package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +package body System.OS_Interface is + + use type Interfaces.C.int; + + Low_Priority : constant := 255; + -- VxWorks native (default) lowest scheduling priority. + + ------------- + -- sigwait -- + ------------- + + function sigwait + (set : access sigset_t; + sig : access Signal) return int + is + Result : int; + + function sigwaitinfo + (set : access sigset_t; sigvalue : System.Address) return int; + pragma Import (C, sigwaitinfo, "sigwaitinfo"); + + begin + Result := sigwaitinfo (set, System.Null_Address); + + if Result /= -1 then + sig.all := Signal (Result); + return 0; + else + sig.all := 0; + return errno; + end if; + end sigwait; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (TS : timespec) return Duration is + begin + return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; + 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'(ts_sec => S, + ts_nsec => long (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ------------------------- + -- To_VxWorks_Priority -- + ------------------------- + + function To_VxWorks_Priority (Priority : in int) return int is + begin + return Low_Priority - Priority; + end To_VxWorks_Priority; + + -------------------- + -- To_Clock_Ticks -- + -------------------- + + -- ??? - For now, we'll always get the system clock rate + -- since it is allowed to be changed during run-time in + -- VxWorks. A better method would be to provide an operation + -- to set it that so we can always know its value. + -- + -- Another thing we should probably allow for is a resultant + -- tick count greater than int'Last. This should probably + -- be a procedure with two output parameters, one in the + -- range 0 .. int'Last, and another representing the overflow + -- count. + + function To_Clock_Ticks (D : Duration) return int is + Ticks : Long_Long_Integer; + Rate_Duration : Duration; + Ticks_Duration : Duration; + + begin + if D < 0.0 then + return -1; + end if; + + -- Ensure that the duration can be converted to ticks + -- at the current clock tick rate without overflowing. + + Rate_Duration := Duration (sysClkRateGet); + + if D > (Duration'Last / Rate_Duration) then + Ticks := Long_Long_Integer (int'Last); + else + Ticks_Duration := D * Rate_Duration; + Ticks := Long_Long_Integer (Ticks_Duration); + + if Ticks_Duration > Duration (Ticks) then + Ticks := Ticks + 1; + end if; + + if Ticks > Long_Long_Integer (int'Last) then + Ticks := Long_Long_Integer (int'Last); + end if; + end if; + + return int (Ticks); + end To_Clock_Ticks; + +end System.OS_Interface; diff --git a/gcc/ada/s-osinte-vxworks.ads b/gcc/ada/s-osinte-vxworks.ads new file mode 100644 index 00000000000..7888cc18e68 --- /dev/null +++ b/gcc/ada/s-osinte-vxworks.ads @@ -0,0 +1,371 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1991-1994, Florida State University -- +-- Copyright (C) 1995-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 package encapsulates all direct interfaces to OS services +-- that are needed by children of System. + +-- PLEASE DO NOT add any with-clauses to this package or remove the pragma +-- Preelaborate. This package is designed to be a bottom-level (leaf) package. + +with Interfaces.C; +with System.VxWorks; + +package System.OS_Interface is + pragma Preelaborate; + + subtype int is Interfaces.C.int; + subtype short is Short_Integer; + type long is new Long_Integer; + type unsigned_long is mod 2 ** long'Size; + type size_t is mod 2 ** Standard'Address_Size; + + ----------- + -- Errno -- + ----------- + + function errno return int; + pragma Import (C, errno, "errnoGet"); + + EINTR : constant := 4; + EAGAIN : constant := 35; + ENOMEM : constant := 12; + EINVAL : constant := 22; + ETIMEDOUT : constant := 60; + + FUNC_ERR : constant := -1; + + ---------------------------- + -- Signals and Interrupts -- + ---------------------------- + + NSIG : constant := 32; + -- Number of signals on the target OS + type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1); + + Max_HW_Interrupt : constant := System.VxWorks.Num_HW_Interrupts - 1; + type HW_Interrupt is new int range 0 .. Max_HW_Interrupt; + + Max_Interrupt : constant := Max_HW_Interrupt; + + SIGILL : constant := 4; -- illegal instruction (not reset) + SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future + SIGFPE : constant := 8; -- floating point exception + SIGBUS : constant := 10; -- bus error + SIGSEGV : constant := 11; -- segmentation violation + + ----------------------------------- + -- Signal processing definitions -- + ----------------------------------- + + -- The how in sigprocmask(). + SIG_BLOCK : constant := 1; + SIG_UNBLOCK : constant := 2; + SIG_SETMASK : constant := 3; + + -- The sa_flags in struct sigaction. + SA_SIGINFO : constant := 16#0002#; + SA_ONSTACK : constant := 16#0004#; + + SIG_DFL : constant := 0; + SIG_IGN : constant := 1; + + type sigset_t is private; + + type struct_sigaction is record + sa_handler : System.Address; + sa_mask : sigset_t; + sa_flags : int; + end record; + pragma Convention (C, struct_sigaction); + type struct_sigaction_ptr is access all struct_sigaction; + + function sigaddset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigaddset, "sigaddset"); + + function sigdelset (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigdelset, "sigdelset"); + + function sigfillset (set : access sigset_t) return int; + pragma Import (C, sigfillset, "sigfillset"); + + function sigismember (set : access sigset_t; sig : Signal) return int; + pragma Import (C, sigismember, "sigismember"); + + function sigemptyset (set : access sigset_t) return int; + pragma Import (C, sigemptyset, "sigemptyset"); + + function sigaction + (sig : Signal; + act : struct_sigaction_ptr; + oact : struct_sigaction_ptr) return int; + pragma Import (C, sigaction, "sigaction"); + + type isr_address is access procedure (sig : int); + + function c_signal (sig : Signal; handler : isr_address) return isr_address; + pragma Import (C, c_signal, "signal"); + + function sigwait (set : access sigset_t; sig : access Signal) return int; + pragma Inline (sigwait); + + type sigset_t_ptr is access all sigset_t; + + function pthread_sigmask + (how : int; + set : sigset_t_ptr; + oset : sigset_t_ptr) return int; + pragma Import (C, pthread_sigmask, "sigprocmask"); + + type t_id is new long; + subtype Thread_Id is t_id; + + function kill (pid : t_id; sig : Signal) return int; + pragma Import (C, kill, "kill"); + + -- VxWorks doesn't have getpid; taskIdSelf is the equivalent + -- routine. + function getpid return t_id; + pragma Import (C, getpid, "taskIdSelf"); + + ---------- + -- Time -- + ---------- + + type time_t is new unsigned_long; + + type timespec is record + ts_sec : time_t; + ts_nsec : long; + end record; + pragma Convention (C, timespec); + + type clockid_t is private; + + CLOCK_REALTIME : constant clockid_t; -- System wide realtime clock + + function To_Duration (TS : timespec) return Duration; + pragma Inline (To_Duration); + + function To_Timespec (D : Duration) return timespec; + pragma Inline (To_Timespec); + + function To_Clock_Ticks (D : Duration) return int; + -- Convert a duration value (in seconds) into clock ticks. + + function clock_gettime + (clock_id : clockid_t; tp : access timespec) return int; + pragma Import (C, clock_gettime, "clock_gettime"); + + type ULONG is new unsigned_long; + + procedure tickSet (ticks : ULONG); + pragma Import (C, tickSet, "tickSet"); + + function tickGet return ULONG; + pragma Import (C, tickGet, "tickGet"); + + ----------------------------------------------------- + -- Convenience routine to convert between VxWorks -- + -- priority and Ada priority. -- + ----------------------------------------------------- + + function To_VxWorks_Priority (Priority : in int) return int; + pragma Inline (To_VxWorks_Priority); + + -------------------------- + -- VxWorks specific API -- + -------------------------- + + subtype STATUS is int; + -- Equivalent of the C type STATUS + + OK : constant STATUS := 0; + ERROR : constant STATUS := Interfaces.C.int (-1); + + function taskIdVerify (tid : t_id) return STATUS; + pragma Import (C, taskIdVerify, "taskIdVerify"); + + function taskIdSelf return t_id; + pragma Import (C, taskIdSelf, "taskIdSelf"); + + function taskSuspend (tid : t_id) return int; + pragma Import (C, taskSuspend, "taskSuspend"); + + function taskResume (tid : t_id) return int; + pragma Import (C, taskResume, "taskResume"); + + function taskIsSuspended (tid : t_id) return int; + pragma Import (C, taskIsSuspended, "taskIsSuspended"); + + function taskVarAdd + (tid : t_id; pVar : access System.Address) return int; + pragma Import (C, taskVarAdd, "taskVarAdd"); + + function taskVarDelete + (tid : t_id; pVar : access System.Address) return int; + pragma Import (C, taskVarDelete, "taskVarDelete"); + + function taskVarSet + (tid : t_id; + pVar : access System.Address; + value : System.Address) return int; + pragma Import (C, taskVarSet, "taskVarSet"); + + function taskVarGet + (tid : t_id; + pVar : access System.Address) return int; + pragma Import (C, taskVarGet, "taskVarGet"); + + function taskDelay (ticks : int) return int; + procedure taskDelay (ticks : int); + pragma Import (C, taskDelay, "taskDelay"); + + function sysClkRateGet return int; + pragma Import (C, sysClkRateGet, "sysClkRateGet"); + + -- Option flags for taskSpawn + + VX_UNBREAKABLE : constant := 16#0002#; + VX_FP_TASK : constant := 16#0008#; + VX_FP_PRIVATE_ENV : constant := 16#0080#; + VX_NO_STACK_FILL : constant := 16#0100#; + + function taskSpawn + (name : System.Address; -- Pointer to task name + priority : int; + options : int; + stacksize : size_t; + start_routine : System.Address; + arg1 : System.Address; + arg2 : int := 0; + arg3 : int := 0; + arg4 : int := 0; + arg5 : int := 0; + arg6 : int := 0; + arg7 : int := 0; + arg8 : int := 0; + arg9 : int := 0; + arg10 : int := 0) return t_id; + pragma Import (C, taskSpawn, "taskSpawn"); + + procedure taskDelete (tid : t_id); + pragma Import (C, taskDelete, "taskDelete"); + + function kernelTimeSlice (ticks : int) return int; + pragma Import (C, kernelTimeSlice, "kernelTimeSlice"); + + function taskPrioritySet + (tid : t_id; newPriority : int) return int; + pragma Import (C, taskPrioritySet, "taskPrioritySet"); + + -- Semaphore creation flags. + + SEM_Q_FIFO : constant := 0; + SEM_Q_PRIORITY : constant := 1; + SEM_DELETE_SAFE : constant := 4; -- only valid for binary semaphore + SEM_INVERSION_SAFE : constant := 8; -- only valid for binary semaphore + + -- Semaphore initial state flags + + SEM_EMPTY : constant := 0; + SEM_FULL : constant := 1; + + -- Semaphore take (semTake) time constants. + + WAIT_FOREVER : constant := -1; + NO_WAIT : constant := 0; + + -- Error codes (errno). The lower level 16 bits are the + -- error code, with the upper 16 bits representing the + -- module number in which the error occurred. By convention, + -- the module number is 0 for UNIX errors. VxWorks reserves + -- module numbers 1-500, with the remaining module numbers + -- being available for user applications. + + M_objLib : constant := 61 * 2**16; + -- semTake() failure with ticks = NO_WAIT + S_objLib_OBJ_UNAVAILABLE : constant := M_objLib + 2; + -- semTake() timeout with ticks > NO_WAIT + S_objLib_OBJ_TIMEOUT : constant := M_objLib + 4; + + type SEM_ID is new System.Address; + -- typedef struct semaphore *SEM_ID; + + -- We use two different kinds of VxWorks semaphores: mutex + -- and binary semaphores. A null ID is returned when + -- a semaphore cannot be created. + + function semBCreate (options : int; initial_state : int) return SEM_ID; + -- Create a binary semaphore. Return ID, or 0 if memory could not + -- be allocated. + pragma Import (C, semBCreate, "semBCreate"); + + function semMCreate (options : int) return SEM_ID; + pragma Import (C, semMCreate, "semMCreate"); + + function semDelete (Sem : SEM_ID) return int; + -- Delete a semaphore + pragma Import (C, semDelete, "semDelete"); + + function semGive (Sem : SEM_ID) return int; + pragma Import (C, semGive, "semGive"); + + function semTake (Sem : SEM_ID; timeout : int) return int; + -- Attempt to take binary semaphore. Error is returned if operation + -- times out + pragma Import (C, semTake, "semTake"); + + function semFlush (SemID : SEM_ID) return STATUS; + -- Release all threads blocked on the semaphore + pragma Import (C, semFlush, "semFlush"); + + function taskLock return int; + pragma Import (C, taskLock, "taskLock"); + + function taskUnlock return int; + pragma Import (C, taskUnlock, "taskUnlock"); + +private + type sigset_t is new long; + + type pid_t is new int; + + ERROR_PID : constant pid_t := -1; + + type clockid_t is new int; + CLOCK_REALTIME : constant clockid_t := 0; + +end System.OS_Interface; diff --git a/gcc/ada/s-osprim-mingw.adb b/gcc/ada/s-osprim-mingw.adb new file mode 100644 index 00000000000..07a8ca79eab --- /dev/null +++ b/gcc/ada/s-osprim-mingw.adb @@ -0,0 +1,286 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 is the NT version of this package + +with Ada.Exceptions; +with Interfaces.C; + +package body System.OS_Primitives is + + --------------------------- + -- Win32 API Definitions -- + --------------------------- + + -- These definitions are copied from System.OS_Interface because we do not + -- want to depend on gnarl here. + + type DWORD is new Interfaces.C.unsigned_long; + + type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0; + + type BOOL is new Boolean; + for BOOL'Size use Interfaces.C.unsigned_long'Size; + + procedure GetSystemTimeAsFileTime (lpFileTime : access Long_Long_Integer); + pragma Import (Stdcall, GetSystemTimeAsFileTime, "GetSystemTimeAsFileTime"); + + function QueryPerformanceCounter + (lpPerformanceCount : access LARGE_INTEGER) return BOOL; + pragma Import + (Stdcall, QueryPerformanceCounter, "QueryPerformanceCounter"); + + function QueryPerformanceFrequency + (lpFrequency : access LARGE_INTEGER) return BOOL; + pragma Import + (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency"); + + procedure Sleep (dwMilliseconds : DWORD); + pragma Import (Stdcall, Sleep, External_Name => "Sleep"); + + ---------------------------------------- + -- Data for the high resolution clock -- + ---------------------------------------- + + -- Declare some pointers to access multi-word data above. This is needed + -- to workaround a limitation in the GNU/Linker auto-import feature used + -- to build the GNAT runtime DLLs. In fact the Clock and Monotonic_Clock + -- routines are inlined and they are using some multi-word variables. + -- GNU/Linker will fail to auto-import those variables when building + -- libgnarl.dll. The indirection level introduced here has no measurable + -- penalties. + -- + -- Note that access variables below must not be declared as constant + -- otherwise the compiler optimization will remove this indirect access. + + type DA is access all Duration; + -- Use to have indirect access to multi-word variables + + type LIA is access all LARGE_INTEGER; + -- Use to have indirect access to multi-word variables + + type LLIA is access all Long_Long_Integer; + -- Use to have indirect access to multi-word variables + + Tick_Frequency : aliased LARGE_INTEGER; + TFA : constant LIA := Tick_Frequency'Access; + -- Holds frequency of high-performance counter used by Clock + -- Windows NT uses a 1_193_182 Hz counter on PCs. + + Base_Ticks : aliased LARGE_INTEGER; + BTA : constant LIA := Base_Ticks'Access; + -- Holds the Tick count for the base time. + + Base_Monotonic_Ticks : aliased LARGE_INTEGER; + BMTA : constant LIA := Base_Monotonic_Ticks'Access; + -- Holds the Tick count for the base monotonic time + + Base_Clock : aliased Duration; + BCA : constant DA := Base_Clock'Access; + -- Holds the current clock for the standard clock's base time + + Base_Monotonic_Clock : aliased Duration; + BMCA : constant DA := Base_Monotonic_Clock'Access; + -- Holds the current clock for monotonic clock's base time + + Base_Time : aliased Long_Long_Integer; + BTiA : constant LLIA := Base_Time'Access; + -- Holds the base time used to check for system time change, used with + -- the standard clock. + + procedure Get_Base_Time; + -- Retrieve the base time and base ticks. These values will be used by + -- clock to compute the current time by adding to it a fraction of the + -- performance counter. This is for the implementation of a + -- high-resolution clock. Note that this routine does not change the base + -- monotonic values used by the monotonic clock. + + ----------- + -- Clock -- + ----------- + + -- This implementation of clock provides high resolution timer values + -- using QueryPerformanceCounter. This call return a 64 bits values (based + -- on the 8253 16 bits counter). This counter is updated every 1/1_193_182 + -- times per seconds. The call to QueryPerformanceCounter takes 6 + -- microsecs to complete. + + function Clock return Duration is + Max_Shift : constant Duration := 2.0; + Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7; + Current_Ticks : aliased LARGE_INTEGER; + Elap_Secs_Tick : Duration; + Elap_Secs_Sys : Duration; + Now : aliased Long_Long_Integer; + + begin + if not QueryPerformanceCounter (Current_Ticks'Access) then + return 0.0; + end if; + + GetSystemTimeAsFileTime (Now'Access); + + Elap_Secs_Sys := + Duration (Long_Long_Float (abs (Now - BTiA.all)) / + Hundreds_Nano_In_Sec); + + Elap_Secs_Tick := + Duration (Long_Long_Float (Current_Ticks - BTA.all) / + Long_Long_Float (TFA.all)); + + -- If we have a shift of more than Max_Shift seconds we resynchonize the + -- Clock. This is probably due to a manual Clock adjustment, an DST + -- adjustment or an NTP synchronisation. And we want to adjust the + -- time for this system (non-monotonic) clock. + + if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then + Get_Base_Time; + + Elap_Secs_Tick := + Duration (Long_Long_Float (Current_Ticks - BTA.all) / + Long_Long_Float (TFA.all)); + end if; + + return BCA.all + Elap_Secs_Tick; + end Clock; + + ------------------- + -- Get_Base_Time -- + ------------------- + + procedure Get_Base_Time is + -- The resolution for GetSystemTime is 1 millisecond. + + -- The time to get both base times should take less than 1 millisecond. + -- Therefore, the elapsed time reported by GetSystemTime between both + -- actions should be null. + + Max_Elapsed : constant := 0; + + Test_Now : aliased Long_Long_Integer; + + epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch + system_time_ns : constant := 100; -- 100 ns per tick + Sec_Unit : constant := 10#1#E9; + + begin + -- Here we must be sure that both of these calls are done in a short + -- amount of time. Both are base time and should in theory be taken + -- at the very same time. + + loop + GetSystemTimeAsFileTime (Base_Time'Access); + + if not QueryPerformanceCounter (Base_Ticks'Access) then + pragma Assert + (Standard.False, + "Could not query high performance counter in Clock"); + null; + end if; + + GetSystemTimeAsFileTime (Test_Now'Access); + + exit when Test_Now - Base_Time = Max_Elapsed; + end loop; + + Base_Clock := Duration + (Long_Long_Float ((Base_Time - epoch_1970) * system_time_ns) / + Long_Long_Float (Sec_Unit)); + end Get_Base_Time; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + Current_Ticks : aliased LARGE_INTEGER; + Elap_Secs_Tick : Duration; + begin + if not QueryPerformanceCounter (Current_Ticks'Access) then + return 0.0; + end if; + + Elap_Secs_Tick := + Duration (Long_Long_Float (Current_Ticks - BMTA.all) / + Long_Long_Float (TFA.all)); + + return BMCA.all + Elap_Secs_Tick; + end Monotonic_Clock; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay (Time : Duration; Mode : Integer) is + Rel_Time : Duration; + Abs_Time : Duration; + Check_Time : Duration := Monotonic_Clock; + + 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 + Sleep (DWORD (Rel_Time * 1000.0)); + Check_Time := Monotonic_Clock; + + exit when Abs_Time <= Check_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + +-- Package elaboration, get starting time as base + +begin + if not QueryPerformanceFrequency (Tick_Frequency'Access) then + Ada.Exceptions.Raise_Exception + (Program_Error'Identity, + "cannot get high performance counter frequency"); + end if; + + Get_Base_Time; + + -- Keep base clock and ticks for the monotonic clock. These values should + -- never be changed to ensure proper behavior of the monotonic clock. + + Base_Monotonic_Clock := Base_Clock; + Base_Monotonic_Ticks := Base_Ticks; +end System.OS_Primitives; diff --git a/gcc/ada/s-osprim-os2.adb b/gcc/ada/s-osprim-os2.adb new file mode 100644 index 00000000000..42e414cde44 --- /dev/null +++ b/gcc/ada/s-osprim-os2.adb @@ -0,0 +1,172 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2001 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the OS/2 version of this package + +with Interfaces.C; use Interfaces.C; +with Interfaces.OS2Lib; use Interfaces.OS2Lib; +with Interfaces.OS2Lib.Synchronization; use Interfaces.OS2Lib.Synchronization; + +package body System.OS_Primitives is + + ---------------- + -- Local Data -- + ---------------- + + Epoch_Offset : Duration; -- See Set_Epoch_Offset + Max_Tick_Count : QWORD := 0.0; + -- This is needed to compensate for small glitches in the + -- hardware clock or the way it is read by the OS + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Set_Epoch_Offset; + -- Initializes the Epoch_1970_Offset to the offset of the System_Clock + -- relative to the Unix epoch (Jan 1, 1970), such that + -- Clock = System_Clock + Epoch_1970_Offset + + function System_Clock return Duration; + pragma Inline (System_Clock); + -- Function returning value of system clock with system-dependent timebase. + -- For OS/2 the system clock returns the elapsed time since system boot. + -- The clock resolution is approximately 838 ns. + + ------------------ + -- System_Clock -- + ------------------ + + function System_Clock return Duration is + + -- Implement conversion from tick count to Duration + -- using fixed point arithmetic. The frequency of + -- the Intel 8254 timer chip is 18.2 * 2**16 Hz. + + Tick_Duration : constant := 1.0 / (18.2 * 2**16); + Tick_Count : aliased QWORD; + + begin + Must_Not_Fail (DosTmrQueryTime (Tick_Count'Access)); + -- Read nr of clock ticks since boot time + + Max_Tick_Count := QWORD'Max (Tick_Count, Max_Tick_Count); + + return Max_Tick_Count * Tick_Duration; + end System_Clock; + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + begin + return System_Clock + Epoch_Offset; + end Clock; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration renames Clock; + + ---------------------- + -- Set_Epoch_Offset -- + ---------------------- + + procedure Set_Epoch_Offset is + + -- Interface to Unix C style gettimeofday + + type timeval is record + tv_sec : long; + tv_usec : long; + end record; + + procedure gettimeofday + (time : access timeval; + zone : System.Address := System.Address'Null_Parameter); + pragma Import (C, gettimeofday); + + Time_Of_Day : aliased timeval; + Micro_To_Nano : constant := 1.0E3; + Sec_To_Nano : constant := 1.0E9; + Nanos_Since_Epoch : QWORD; + + begin + gettimeofday (Time_Of_Day'Access); + Nanos_Since_Epoch := QWORD (Time_Of_Day.tv_sec) * Sec_To_Nano + + QWORD (Time_Of_Day.tv_usec) * Micro_To_Nano; + + Epoch_Offset := + Duration'(Nanos_Since_Epoch / Sec_To_Nano) - System_Clock; + + end Set_Epoch_Offset; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Rel_Time : Duration; + Abs_Time : Duration; + Check_Time : Duration := Clock; + + 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 + Must_Not_Fail (DosSleep (ULONG (Rel_Time * 1000.0))); + + Check_Time := Clock; + + exit when Abs_Time <= Check_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + +begin + Set_Epoch_Offset; +end System.OS_Primitives; diff --git a/gcc/ada/s-osprim-posix.adb b/gcc/ada/s-osprim-posix.adb new file mode 100644 index 00000000000..c4a7a112380 --- /dev/null +++ b/gcc/ada/s-osprim-posix.adb @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-osprim-solaris.adb b/gcc/ada/s-osprim-solaris.adb new file mode 100644 index 00000000000..b6d529d206c --- /dev/null +++ b/gcc/ada/s-osprim-solaris.adb @@ -0,0 +1,124 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 uses gettimeofday and select +-- This file is suitable for Solaris (32 and 64 bits). + +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_timeval is record + tv_sec : Long_Integer; + tv_usec : Long_Integer; + end record; + pragma Convention (C, struct_timeval); + + procedure gettimeofday + (tv : access struct_timeval; + tz : Address := Null_Address); + pragma Import (C, gettimeofday, "gettimeofday"); + + procedure C_select + (n : Integer := 0; + readfds, + writefds, + exceptfds : Address := Null_Address; + timeout : access struct_timeval); + pragma Import (C, C_select, "select"); + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + TV : aliased struct_timeval; + + begin + gettimeofday (TV'Access); + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end Clock; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration renames Clock; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Rel_Time : Duration; + Abs_Time : Duration; + Check_Time : Duration := Clock; + timeval : aliased struct_timeval; + + 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 + timeval.tv_sec := Long_Integer (Rel_Time); + + if Duration (timeval.tv_sec) > Rel_Time then + timeval.tv_sec := timeval.tv_sec - 1; + end if; + + timeval.tv_usec := + Long_Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6); + + C_select (timeout => timeval'Unchecked_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; diff --git a/gcc/ada/s-osprim-unix.adb b/gcc/ada/s-osprim-unix.adb new file mode 100644 index 00000000000..ed8a6f40f55 --- /dev/null +++ b/gcc/ada/s-osprim-unix.adb @@ -0,0 +1,124 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 uses gettimeofday and select +-- This file is suitable for OpenNT, Dec Unix and SCO UnixWare. + +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_timeval is record + tv_sec : Integer; + tv_usec : Integer; + end record; + pragma Convention (C, struct_timeval); + + procedure gettimeofday + (tv : access struct_timeval; + tz : Address := Null_Address); + pragma Import (C, gettimeofday, "gettimeofday"); + + procedure C_select + (n : Integer := 0; + readfds, + writefds, + exceptfds : Address := Null_Address; + timeout : access struct_timeval); + pragma Import (C, C_select, "select"); + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + TV : aliased struct_timeval; + + begin + gettimeofday (TV'Access); + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end Clock; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration renames Clock; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Rel_Time : Duration; + Abs_Time : Duration; + Check_Time : Duration := Clock; + timeval : aliased struct_timeval; + + 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 + timeval.tv_sec := Integer (Rel_Time); + + if Duration (timeval.tv_sec) > Rel_Time then + timeval.tv_sec := timeval.tv_sec - 1; + end if; + + timeval.tv_usec := + Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6); + + C_select (timeout => timeval'Unchecked_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; diff --git a/gcc/ada/s-osprim-vms.adb b/gcc/ada/s-osprim-vms.adb new file mode 100644 index 00000000000..c49c861bf34 --- /dev/null +++ b/gcc/ada/s-osprim-vms.adb @@ -0,0 +1,193 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 the OpenVMS/Alpha version of this file + +with System.Aux_DEC; + +package body System.OS_Primitives is + + -------------------------------------- + -- Local functions and declarations -- + -------------------------------------- + + function Get_GMToff return Integer; + pragma Import (C, Get_GMToff, "get_gmtoff"); + -- Get the offset from GMT for this timezone + + VMS_Epoch_Offset : constant Long_Integer := + 10_000_000 * + (3_506_716_800 + Long_Integer (Get_GMToff)); + -- The offset between the Unix Epoch and the VMS Epoch + + subtype Cond_Value_Type is System.Aux_DEC.Unsigned_Longword; + -- Condition Value return type + + ---------------- + -- Sys_Schdwk -- + ---------------- + -- + -- Schedule Wakeup + -- + -- status = returned status + -- pidadr = address of process id to be woken up + -- prcnam = name of process to be woken up + -- daytim = time to wake up + -- reptim = repitition interval of wakeup calls + -- + + procedure Sys_Schdwk + ( + Status : out Cond_Value_Type; + Pidadr : in Address := Null_Address; + Prcnam : in String := String'Null_Parameter; + Daytim : in Long_Integer; + Reptim : in Long_Integer := Long_Integer'Null_Parameter + ); + + pragma Interface (External, Sys_Schdwk); + -- VMS system call to schedule a wakeup event + pragma Import_Valued_Procedure + (Sys_Schdwk, "SYS$SCHDWK", + (Cond_Value_Type, Address, String, Long_Integer, Long_Integer), + (Value, Value, Descriptor (S), Reference, Reference) + ); + + ---------------- + -- Sys_Gettim -- + ---------------- + -- + -- Get System Time + -- + -- status = returned status + -- tim = current system time + -- + + procedure Sys_Gettim + ( + Status : out Cond_Value_Type; + Tim : out OS_Time + ); + -- VMS system call to get the current system time + pragma Interface (External, Sys_Gettim); + pragma Import_Valued_Procedure + (Sys_Gettim, "SYS$GETTIM", + (Cond_Value_Type, OS_Time), + (Value, Reference) + ); + + --------------- + -- Sys_Hiber -- + --------------- + + -- Hibernate (until woken up) + + -- status = returned status + + procedure Sys_Hiber (Status : out Cond_Value_Type); + -- VMS system call to hibernate the current process + pragma Interface (External, Sys_Hiber); + pragma Import_Valued_Procedure + (Sys_Hiber, "SYS$HIBER", + (Cond_Value_Type), + (Value) + ); + + ----------- + -- Clock -- + ----------- + + function OS_Clock return OS_Time is + Status : Cond_Value_Type; + T : OS_Time; + begin + Sys_Gettim (Status, T); + return (T); + end OS_Clock; + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + begin + return To_Duration (OS_Clock, Absolute_Calendar); + end Clock; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration renames Clock; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Sleep_Time : OS_Time; + Status : Cond_Value_Type; + + begin + Sleep_Time := To_OS_Time (Time, Mode); + Sys_Schdwk (Status => Status, Daytim => Sleep_Time); + Sys_Hiber (Status); + end Timed_Delay; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (T : OS_Time; Mode : Integer) return Duration is + pragma Warnings (Off, Mode); + begin + return Duration'Fixed_Value (T - VMS_Epoch_Offset) * 100; + end To_Duration; + + ---------------- + -- To_OS_Time -- + ---------------- + + function To_OS_Time (D : Duration; Mode : Integer) return OS_Time is + begin + if Mode = Relative then + return -(Long_Integer'Integer_Value (D) / 100); + else + return Long_Integer'Integer_Value (D) / 100 + VMS_Epoch_Offset; + end if; + end To_OS_Time; + +end System.OS_Primitives; diff --git a/gcc/ada/s-osprim-vms.ads b/gcc/ada/s-osprim-vms.ads new file mode 100644 index 00000000000..a777bea3b83 --- /dev/null +++ b/gcc/ada/s-osprim-vms.ads @@ -0,0 +1,106 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- -- +-- S p e c -- +-- -- +-- 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 package provides low level primitives used to implement clock and +-- delays in non tasking applications on Alpha/VMS + +-- The choice of the real clock/delay implementation (depending on whether +-- tasking is involved or not) is done via soft links (see s-tasoli.ads) + +-- NEVER add any dependency to tasking packages here + +package System.OS_Primitives is + + subtype OS_Time is Long_Integer; + -- System time on VMS is used for performance reasons. + -- Note that OS_Time is *not* the same as Ada.Calendar.Time, the + -- difference being that relative OS_Time is negative, but relative + -- Calendar.Time is positive. + -- See Ada.Calendar.Delays for more information on VMS Time. + + Max_Sensible_Delay : constant Duration := + Duration'Min (183 * 24 * 60 * 60.0, + Duration'Last); + -- Max of half a year delay, needed to prevent exceptions for large + -- delay values. It seems unlikely that any test will notice this + -- restriction, except in the case of applications setting the clock at + -- at run time (see s-tastim.adb). Also note that a larger value might + -- cause problems (e.g overflow, or more likely OS limitation in the + -- primitives used). In the case where half a year is too long (which + -- occurs in high integrity mode with 32-bit words, and possibly on + -- some specific ports of GNAT), Duration'Last is used instead. + + function OS_Clock return OS_Time; + -- Returns "absolute" time, represented as an offset + -- relative to "the Epoch", which is Nov 17, 1858 on VMS. + + function Clock return Duration; + pragma Inline (Clock); + -- Returns "absolute" time, represented as an offset + -- relative to "the Epoch", which is Jan 1, 1970 on unixes. + -- This implementation is affected by system's clock changes. + + function Monotonic_Clock return Duration; + pragma Inline (Monotonic_Clock); + -- Returns "absolute" time, represented as an offset + -- relative to "the Epoch", which is Jan 1, 1970. + -- This clock implementation is immune to the system's clock changes. + + Relative : constant := 0; + Absolute_Calendar : constant := 1; + Absolute_RT : constant := 2; + -- Values for Mode call below. Note that the compiler (exp_ch9.adb) + -- relies on these values. So any change here must be reflected in + -- corresponding changes in the compiler. + + procedure Timed_Delay (Time : Duration; Mode : Integer); + -- Implements the semantics of the delay statement when no tasking is + -- used in the application. + -- + -- Mode is one of the three values above + -- + -- Time is a relative or absolute duration value, depending on Mode. + -- + -- Note that currently Ada.Real_Time always uses the tasking run time, so + -- this procedure should never be called with Mode set to Absolute_RT. + -- This may change in future or bare board implementations. + + function To_Duration (T : OS_Time; Mode : Integer) return Duration; + -- Convert VMS system time to Duration + -- Mode is one of the three values above + + function To_OS_Time (D : Duration; Mode : Integer) return OS_Time; + -- Convert Duration to VMS system time + -- Mode is one of the three values above + +end System.OS_Primitives; diff --git a/gcc/ada/s-osprim-vxworks.adb b/gcc/ada/s-osprim-vxworks.adb new file mode 100644 index 00000000000..0f32bbe6dce --- /dev/null +++ b/gcc/ada/s-osprim-vxworks.adb @@ -0,0 +1,161 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 version is for VxWorks targets + +with System.OS_Interface; +-- Since the thread library is part of the VxWorks kernel, using OS_Interface +-- is not a problem here, as long as we only use System.OS_Interface as a +-- set of C imported routines: using Ada routines from this package would +-- create a dependency on libgnarl in libgnat, which is not desirable. + +with Interfaces.C; +-- used for type int + +package body System.OS_Primitives is + + use System.OS_Interface; + use type Interfaces.C.int; + + -------------------------- + -- Internal functions -- + -------------------------- + + function To_Clock_Ticks (D : Duration) return int; + -- Convert a duration value (in seconds) into clock ticks. + -- Note that this routine is duplicated from System.OS_Interface since + -- as explained above, we do not want to depend on libgnarl + + function To_Clock_Ticks (D : Duration) return int is + Ticks : Long_Long_Integer; + Rate_Duration : Duration; + Ticks_Duration : Duration; + + begin + if D < 0.0 then + return -1; + end if; + + -- Ensure that the duration can be converted to ticks + -- at the current clock tick rate without overflowing. + + Rate_Duration := Duration (sysClkRateGet); + + if D > (Duration'Last / Rate_Duration) then + Ticks := Long_Long_Integer (int'Last); + else + Ticks_Duration := D * Rate_Duration; + Ticks := Long_Long_Integer (Ticks_Duration); + + if Ticks_Duration > Duration (Ticks) then + Ticks := Ticks + 1; + end if; + + if Ticks > Long_Long_Integer (int'Last) then + Ticks := Long_Long_Integer (int'Last); + end if; + end if; + + return int (Ticks); + end To_Clock_Ticks; + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + TS : aliased timespec; + Result : int; + + use type Interfaces.C.int; + + begin + Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); + pragma Assert (Result = 0); + return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; + end Clock; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration renames Clock; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Rel_Time : Duration; + Abs_Time : Duration; + Check_Time : Duration := Clock; + Ticks : int; + + Result : int; + 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 + Ticks := To_Clock_Ticks (Rel_Time); + + if Mode = Relative and then Ticks < int'Last then + -- The first tick will delay anytime between 0 and + -- 1 / sysClkRateGet seconds, so we need to add one to + -- be on the safe side. + + Ticks := Ticks + 1; + end if; + + Result := taskDelay (Ticks); + 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; diff --git a/gcc/ada/s-parame-ae653.ads b/gcc/ada/s-parame-ae653.ads new file mode 100644 index 00000000000..af397c2aeb7 --- /dev/null +++ b/gcc/ada/s-parame-ae653.ads @@ -0,0 +1,203 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2003 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 default VxWorks AE 653 version of the package.` + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +package System.Parameters is +pragma Pure (Parameters); + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Ratio is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Ratio : constant Ratio := 50; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 14_336; + -- Assumed size of the environment task, if no other information + -- is available. This value is used when stack checking is + -- enabled and no GNAT_STACK_LIMIT environment variable is set. + -- This value is chosen as the VxWorks default stack size is 20kB, + -- and a little more than 4kB is necessary for the run time. + + Stack_Grows_Down : constant Boolean := True; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := Long_Integer'Size; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this is not true + -- of all targets. For example, in OpenVMS long /= Long_Integer. + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are ommitted only for outer level onjects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- In the following sections, constant parameters are defined to + -- allow some optimizations and fine tuning within the tasking run time + -- based on restrictions on the tasking features. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := False; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := False; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + ---------------------- + -- Dynamic Priority -- + ---------------------- + + Dynamic_Priority_Support : constant Boolean := True; + -- This constant indicates whether dynamic changes of task priorities + -- are allowed (True means normal RM mode in which such changes are + -- allowed). In particular, if this is False, then we do not need to + -- poll for pending base priority changes at every abort completion + -- point. A value of False for Dynamic_Priority_Support corresponds + -- to pragma Restrictions (No_Dynamic_Priorities); + + --------------------- + -- Task Attributes -- + --------------------- + + Default_Attribute_Count : constant := 4; + -- Number of pre-allocated Address-sized task attributes stored in the + -- task control block. + + -------------------- + -- Runtime Traces -- + -------------------- + + Runtime_Traces : constant Boolean := False; + -- This constant indicates whether the runtime outputs traces to a + -- predefined output or not (True means that traces are output). + -- See System.Traces for more details. + +end System.Parameters; diff --git a/gcc/ada/s-parame-hpux.ads b/gcc/ada/s-parame-hpux.ads new file mode 100644 index 00000000000..8be952a18c2 --- /dev/null +++ b/gcc/ada/s-parame-hpux.ads @@ -0,0 +1,202 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2003 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 HP version of this package +-- Blank line intentional so that it lines up exactly with default. + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +package System.Parameters is +pragma Pure (Parameters); + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Ratio is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Ratio : constant Ratio := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 8_192_000; + -- Assumed size of the environment task, if no other information + -- is available. This value is used when stack checking is + -- enabled and no GNAT_STACK_LIMIT environment variable is set. + + Stack_Grows_Down : constant Boolean := False; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of Types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := Long_Integer'Size; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this is not true + -- of all targets. For example, in OpenVMS long /= Long_Integer. + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are ommitted only for outer level onjects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- In the following sections, constant parameters are defined to + -- allow some optimizations and fine tuning within the tasking run time + -- based on restrictions on the tasking features. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := False; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := False; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + ---------------------- + -- Dynamic Priority -- + ---------------------- + + Dynamic_Priority_Support : constant Boolean := True; + -- This constant indicates whether dynamic changes of task priorities + -- are allowed (True means normal RM mode in which such changes are + -- allowed). In particular, if this is False, then we do not need to + -- poll for pending base priority changes at every abort completion + -- point. A value of False for Dynamic_Priority_Support corresponds + -- to pragma Restrictions (No_Dynamic_Priorities); + + --------------------- + -- Task Attributes -- + --------------------- + + Default_Attribute_Count : constant := 4; + -- Number of pre-allocated Address-sized task attributes stored in the + -- task control block. + + -------------------- + -- Runtime Traces -- + -------------------- + + Runtime_Traces : constant Boolean := False; + -- This constant indicates whether the runtime outputs traces to a + -- predefined output or not (True means that traces are output). + -- See System.Traces for more details. + +end System.Parameters; diff --git a/gcc/ada/s-parame-linux.adb b/gcc/ada/s-parame-linux.adb new file mode 100644 index 00000000000..9b17c158733 --- /dev/null +++ b/gcc/ada/s-parame-linux.adb @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2003 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 Linux (native) specific version + +package body System.Parameters is + + ------------------------- + -- Adjust_Storage_Size -- + ------------------------- + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type is + begin + if Size = Unspecified_Size then + return Default_Stack_Size; + + elsif Size < Minimum_Stack_Size then + return Minimum_Stack_Size; + + else + return Size; + end if; + end Adjust_Storage_Size; + + ------------------------ + -- Default_Stack_Size -- + ------------------------ + + function Default_Stack_Size return Size_Type is + begin + return 2 * 1024 * 1024; + end Default_Stack_Size; + + ------------------------ + -- Minimum_Stack_Size -- + ------------------------ + + function Minimum_Stack_Size return Size_Type is + begin + return 8 * 1024; + end Minimum_Stack_Size; + +end System.Parameters; diff --git a/gcc/ada/s-parame-os2.adb b/gcc/ada/s-parame-os2.adb new file mode 100644 index 00000000000..1ae7463618b --- /dev/null +++ b/gcc/ada/s-parame-os2.adb @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2002 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 OS/2 specific version - default stacksizes need to be large + +package body System.Parameters is + + ------------------------ + -- Default_Stack_Size -- + ------------------------ + + function Default_Stack_Size return Size_Type is + begin + -- The default stack size for extra tasks is based on the + -- default stack size for the main task (8 MB) and for the heap + -- (32 MB). + + -- In OS/2 it doesn't hurt to define large stacks, unless + -- the system is configured to commit all memory reservations. + -- This is not a default configuration however. + + return 1024 * 1024; + end Default_Stack_Size; + + ------------------------ + -- Minimum_Stack_Size -- + ------------------------ + + function Minimum_Stack_Size return Size_Type is + begin + -- System functions may need 8 kB of stack, so 12 kB seems a + -- good minimum. + return 12 * 1024; + end Minimum_Stack_Size; + + ------------------------- + -- Adjust_Storage_Size -- + ------------------------- + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type is + begin + if Size = Unspecified_Size then + return Default_Stack_Size; + + elsif Size < Minimum_Stack_Size then + return Minimum_Stack_Size; + + else + return Size; + end if; + end Adjust_Storage_Size; + +end System.Parameters; diff --git a/gcc/ada/s-parame-solaris.adb b/gcc/ada/s-parame-solaris.adb new file mode 100644 index 00000000000..847dda820e8 --- /dev/null +++ b/gcc/ada/s-parame-solaris.adb @@ -0,0 +1,80 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- B o d y -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Solaris (native) specific version + +package body System.Parameters is + + ------------------------ + -- Default_Stack_Size -- + ------------------------ + + function Default_Stack_Size return Size_Type is + begin + return 100_000; + end Default_Stack_Size; + + ------------------------ + -- Minimum_Stack_Size -- + ------------------------ + + function Minimum_Stack_Size return Size_Type is + + thr_min_stack : constant Size_Type := 1160; + -- hard coded value for Solaris 8 to avoid adding dependency on + -- libthread for every Ada program. + -- This value does not really matter anyway, since this is checked + -- and adjusted at the library level when creating a thread. + + begin + return thr_min_stack; + end Minimum_Stack_Size; + + ------------------------- + -- Adjust_Storage_Size -- + ------------------------- + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type is + begin + if Size = Unspecified_Size then + return Default_Stack_Size; + + elsif Size < Minimum_Stack_Size then + return Minimum_Stack_Size; + + else + return Size; + end if; + end Adjust_Storage_Size; + +end System.Parameters; diff --git a/gcc/ada/s-parame-vms-restrict.ads b/gcc/ada/s-parame-vms-restrict.ads new file mode 100644 index 00000000000..d1d48188176 --- /dev/null +++ b/gcc/ada/s-parame-vms-restrict.ads @@ -0,0 +1,203 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2003 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 version for restricted tasking. + +-- Blank line intentional so that it lines up exactly with default. + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +package System.Parameters is +pragma Pure (Parameters); + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Ratio is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Ratio : constant Ratio := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 8_192_000; + -- Assumed size of the environment task, if no other information + -- is available. This value is used when stack checking is + -- enabled and no GNAT_STACK_LIMIT environment variable is set. + + Stack_Grows_Down : constant Boolean := True; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := 32; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this is not true + -- of all targets. For example, in OpenVMS long /= Long_Integer. + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are ommitted only for outer level onjects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- In the following sections, constant parameters are defined to + -- allow some optimizations and fine tuning within the tasking run time + -- based on restrictions on the tasking features. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := True; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := True; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + ---------------------- + -- Dynamic Priority -- + ---------------------- + + Dynamic_Priority_Support : constant Boolean := False; + -- This constant indicates whether dynamic changes of task priorities + -- are allowed (True means normal RM mode in which such changes are + -- allowed). In particular, if this is False, then we do not need to + -- poll for pending base priority changes at every abort completion + -- point. A value of False for Dynamic_Priority_Support corresponds + -- to pragma Restrictions (No_Dynamic_Priorities); + + --------------------- + -- Task Attributes -- + --------------------- + + Default_Attribute_Count : constant := 4; + -- Number of pre-allocated Address-sized task attributes stored in the + -- task control block. + + -------------------- + -- Runtime Traces -- + -------------------- + + Runtime_Traces : constant Boolean := False; + -- This constant indicates whether the runtime outputs traces to a + -- predefined output or not (True means that traces are output). + -- See System.Traces for more details. + +end System.Parameters; diff --git a/gcc/ada/s-parame-vms.ads b/gcc/ada/s-parame-vms.ads new file mode 100644 index 00000000000..5b41ab79ec6 --- /dev/null +++ b/gcc/ada/s-parame-vms.ads @@ -0,0 +1,202 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2003 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 version. +-- Blank line intentional so that it lines up exactly with default. + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +package System.Parameters is +pragma Pure (Parameters); + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Ratio is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Ratio : constant Ratio := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 8_192_000; + -- Assumed size of the environment task, if no other information + -- is available. This value is used when stack checking is + -- enabled and no GNAT_STACK_LIMIT environment variable is set. + + Stack_Grows_Down : constant Boolean := True; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := 32; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this is not true + -- of all targets. For example, in OpenVMS long /= Long_Integer. + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are ommitted only for outer level onjects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- In the following sections, constant parameters are defined to + -- allow some optimizations and fine tuning within the tasking run time + -- based on restrictions on the tasking features. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := True; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := False; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + ---------------------- + -- Dynamic Priority -- + ---------------------- + + Dynamic_Priority_Support : constant Boolean := True; + -- This constant indicates whether dynamic changes of task priorities + -- are allowed (True means normal RM mode in which such changes are + -- allowed). In particular, if this is False, then we do not need to + -- poll for pending base priority changes at every abort completion + -- point. A value of False for Dynamic_Priority_Support corresponds + -- to pragma Restrictions (No_Dynamic_Priorities); + + --------------------- + -- Task Attributes -- + --------------------- + + Default_Attribute_Count : constant := 4; + -- Number of pre-allocated Address-sized task attributes stored in the + -- task control block. + + -------------------- + -- Runtime Traces -- + -------------------- + + Runtime_Traces : constant Boolean := False; + -- This constant indicates whether the runtime outputs traces to a + -- predefined output or not (True means that traces are output). + -- See System.Traces for more details. + +end System.Parameters; diff --git a/gcc/ada/s-parame-vxworks.ads b/gcc/ada/s-parame-vxworks.ads new file mode 100644 index 00000000000..774280f8307 --- /dev/null +++ b/gcc/ada/s-parame-vxworks.ads @@ -0,0 +1,203 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2003 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 default VxWorks version of the package.` + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +package System.Parameters is +pragma Pure (Parameters); + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Ratio is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Ratio : constant Ratio := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 14_336; + -- Assumed size of the environment task, if no other information + -- is available. This value is used when stack checking is + -- enabled and no GNAT_STACK_LIMIT environment variable is set. + -- This value is chosen as the VxWorks default stack size is 20kB, + -- and a little more than 4kB is necessary for the run time. + + Stack_Grows_Down : constant Boolean := True; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := Long_Integer'Size; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this is not true + -- of all targets. For example, in OpenVMS long /= Long_Integer. + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are ommitted only for outer level onjects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- In the following sections, constant parameters are defined to + -- allow some optimizations and fine tuning within the tasking run time + -- based on restrictions on the tasking features. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := False; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := False; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + ---------------------- + -- Dynamic Priority -- + ---------------------- + + Dynamic_Priority_Support : constant Boolean := True; + -- This constant indicates whether dynamic changes of task priorities + -- are allowed (True means normal RM mode in which such changes are + -- allowed). In particular, if this is False, then we do not need to + -- poll for pending base priority changes at every abort completion + -- point. A value of False for Dynamic_Priority_Support corresponds + -- to pragma Restrictions (No_Dynamic_Priorities); + + --------------------- + -- Task Attributes -- + --------------------- + + Default_Attribute_Count : constant := 4; + -- Number of pre-allocated Address-sized task attributes stored in the + -- task control block. + + -------------------- + -- Runtime Traces -- + -------------------- + + Runtime_Traces : constant Boolean := False; + -- This constant indicates whether the runtime outputs traces to a + -- predefined output or not (True means that traces are output). + -- See System.Traces for more details. + +end System.Parameters; diff --git a/gcc/ada/s-proinf-irix-athread.adb b/gcc/ada/s-proinf-irix-athread.adb new file mode 100644 index 00000000000..3e6bbc9557d --- /dev/null +++ b/gcc/ada/s-proinf-irix-athread.adb @@ -0,0 +1,221 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P R O G R A M _ I N F O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-1999 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Irix (old pthread library) version of this package. + +-- This package contains the parameters used by the run-time system at +-- program startup. These parameters are isolated in this package body to +-- facilitate replacement by the end user. +-- +-- To replace the default values, copy this source file into your build +-- directory, edit the file to reflect your desired behavior, and recompile +-- with the command: +-- +-- % gcc -c -O2 -gnatpg s-proinf.adb +-- +-- then relink your application as usual. +-- + +with GNAT.OS_Lib; + +package body System.Program_Info is + + Kbytes : constant := 1024; + + Default_Initial_Sproc_Count : constant := 0; + Default_Max_Sproc_Count : constant := 128; + Default_Sproc_Stack_Size : constant := 16#4000#; + Default_Stack_Guard_Pages : constant := 1; + Default_Default_Time_Slice : constant := 0.0; + Default_Default_Task_Stack : constant := 12 * Kbytes; + Default_Pthread_Sched_Signal : constant := 35; + Default_Pthread_Arena_Size : constant := 16#40000#; + Default_Os_Default_Priority : constant := 0; + + ------------------------- + -- Initial_Sproc_Count -- + ------------------------- + + function Initial_Sproc_Count return Integer is + + function sysmp (P1 : Integer) return Integer; + pragma Import (C, sysmp, "sysmp", "sysmp"); + + MP_NPROCS : constant := 1; -- # processor in complex + + Pthread_Sproc_Count : constant GNAT.OS_Lib.String_Access := + GNAT.OS_Lib.Getenv ("PTHREAD_SPROC_COUNT"); + + begin + if Pthread_Sproc_Count.all'Length = 0 then + return Default_Initial_Sproc_Count; + + elsif Pthread_Sproc_Count.all = "AUTO" then + return sysmp (MP_NPROCS); + + else + return Integer'Value (Pthread_Sproc_Count.all); + end if; + exception + when others => + return Default_Initial_Sproc_Count; + end Initial_Sproc_Count; + + --------------------- + -- Max_Sproc_Count -- + --------------------- + + function Max_Sproc_Count return Integer is + Pthread_Max_Sproc_Count : constant GNAT.OS_Lib.String_Access := + GNAT.OS_Lib.Getenv ("PTHREAD_MAX_SPROC_COUNT"); + + begin + if Pthread_Max_Sproc_Count.all'Length = 0 then + return Default_Max_Sproc_Count; + else + return Integer'Value (Pthread_Max_Sproc_Count.all); + end if; + exception + when others => + return Default_Max_Sproc_Count; + end Max_Sproc_Count; + + ---------------------- + -- Sproc_Stack_Size -- + ---------------------- + + function Sproc_Stack_Size return Integer is + begin + return Default_Sproc_Stack_Size; + end Sproc_Stack_Size; + + ------------------------ + -- Default_Time_Slice -- + ------------------------ + + function Default_Time_Slice return Duration is + Pthread_Time_Slice_Sec : constant GNAT.OS_Lib.String_Access := + GNAT.OS_Lib.Getenv ("PTHREAD_TIME_SLICE_SEC"); + Pthread_Time_Slice_Usec : constant GNAT.OS_Lib.String_Access := + GNAT.OS_Lib.Getenv ("PTHREAD_TIME_SLICE_USEC"); + + Val_Sec, Val_Usec : Integer := 0; + + begin + if Pthread_Time_Slice_Sec.all'Length /= 0 or + Pthread_Time_Slice_Usec.all'Length /= 0 + then + if Pthread_Time_Slice_Sec.all'Length /= 0 then + Val_Sec := Integer'Value (Pthread_Time_Slice_Sec.all); + end if; + + if Pthread_Time_Slice_Usec.all'Length /= 0 then + Val_Usec := Integer'Value (Pthread_Time_Slice_Usec.all); + end if; + + return Duration (Val_Sec) + Duration (Val_Usec) / 1000.0; + else + return Default_Default_Time_Slice; + end if; + + exception + when others => + return Default_Default_Time_Slice; + end Default_Time_Slice; + + ------------------------ + -- Default_Task_Stack -- + ------------------------ + + function Default_Task_Stack return Integer is + begin + return Default_Default_Task_Stack; + end Default_Task_Stack; + + ----------------------- + -- Stack_Guard_Pages -- + ----------------------- + + function Stack_Guard_Pages return Integer is + Pthread_Stack_Guard_Pages : constant GNAT.OS_Lib.String_Access := + GNAT.OS_Lib.Getenv ("PTHREAD_STACK_GUARD_PAGES"); + + begin + if Pthread_Stack_Guard_Pages.all'Length /= 0 then + return Integer'Value (Pthread_Stack_Guard_Pages.all); + else + return Default_Stack_Guard_Pages; + end if; + exception + when others => + return Default_Stack_Guard_Pages; + end Stack_Guard_Pages; + + -------------------------- + -- Pthread_Sched_Signal -- + -------------------------- + + function Pthread_Sched_Signal return Integer is + begin + return Default_Pthread_Sched_Signal; + end Pthread_Sched_Signal; + + ------------------------ + -- Pthread_Arena_Size -- + ------------------------ + + function Pthread_Arena_Size return Integer is + Pthread_Arena_Size : constant GNAT.OS_Lib.String_Access := + GNAT.OS_Lib.Getenv ("PTHREAD_ARENA_SIZE"); + + begin + if Pthread_Arena_Size.all'Length = 0 then + return Default_Pthread_Arena_Size; + else + return Integer'Value (Pthread_Arena_Size.all); + end if; + exception + when others => + return Default_Pthread_Arena_Size; + end Pthread_Arena_Size; + + ------------------------- + -- Os_Default_Priority -- + ------------------------- + + function Os_Default_Priority return Integer is + begin + return Default_Os_Default_Priority; + end Os_Default_Priority; + +end System.Program_Info; diff --git a/gcc/ada/s-proinf-irix-athread.ads b/gcc/ada/s-proinf-irix-athread.ads new file mode 100644 index 00000000000..a4259c3c916 --- /dev/null +++ b/gcc/ada/s-proinf-irix-athread.ads @@ -0,0 +1,96 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P R O G R A M _ I N F O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-2003 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 contains the definitions and routines used as parameters +-- to the run-time system at program startup for the SGI implementation. + +package System.Program_Info is + + function Initial_Sproc_Count return Integer; + -- + -- The number of sproc created at program startup for scheduling + -- threads. + -- + + function Max_Sproc_Count return Integer; + -- + -- The maximum number of sprocs that can be created by the program + -- for servicing threads. This limit includes both the pre-created + -- sprocs and those explicitly created under program control. + -- + + function Sproc_Stack_Size return Integer; + -- + -- The size, in bytes, of the sproc's initial stack. + -- + + function Default_Time_Slice return Duration; + -- + -- The default time quanta for round-robin scheduling of threads of + -- equal priority. This default value can be overridden on a per-task + -- basis by specifying an alternate value via the implementation-defined + -- Task_Info pragma. See s-tasinf.ads for more information. + -- + + function Default_Task_Stack return Integer; + -- + -- The default stack size for each created thread. This default value + -- can be overriden on a per-task basis by the language-defined + -- Storage_Size pragma. + -- + + function Stack_Guard_Pages return Integer; + -- + -- The number of non-writable, guard pages to append to the bottom of + -- each thread's stack. + -- + + function Pthread_Sched_Signal return Integer; + -- + -- The signal used by the Pthreads library to affect scheduling actions + -- in remote sprocs. + -- + + function Pthread_Arena_Size return Integer; + -- + -- The size of the shared arena from which pthread locks are allocated. + -- See the usinit(3p) man page for more information on shared arenas. + -- + + function Os_Default_Priority return Integer; + -- + -- The default Irix Non-Degrading priority for each sproc created to + -- service threads. + -- + +end System.Program_Info; diff --git a/gcc/ada/s-stchop-vxworks.adb b/gcc/ada/s-stchop-vxworks.adb new file mode 100644 index 00000000000..b19bb56f274 --- /dev/null +++ b/gcc/ada/s-stchop-vxworks.adb @@ -0,0 +1,255 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-taprop-dummy.adb b/gcc/ada/s-taprop-dummy.adb new file mode 100644 index 00000000000..365b0d911d3 --- /dev/null +++ b/gcc/ada/s-taprop-dummy.adb @@ -0,0 +1,438 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 no tasking version of this package + +-- This package contains all the GNULL primitives that interface directly +-- with the underlying OS. + +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.Tasking; +-- used for Ada_Task_Control_Block +-- Task_ID + +with System.Error_Reporting; +-- used for Shutdown + +package body System.Task_Primitives.Operations is + + use System.Tasking; + use System.Parameters; + + pragma Warnings (Off); + -- Turn off warnings since so many unreferenced parameters + + ----------------- + -- Stack_Guard -- + ----------------- + + procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + begin + null; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is + begin + return OSI.Thread_Id (T.Common.LL.Thread); + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID is + begin + return Null_Task; + end Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : access Lock) + is + begin + null; + end Initialize_Lock; + + procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + begin + null; + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : access Lock) is + begin + null; + end Finalize_Lock; + + procedure Finalize_Lock (L : access RTS_Lock) is + begin + null; + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + begin + Ceiling_Violation := False; + end Write_Lock; + + procedure Write_Lock + (L : access RTS_Lock; + Global_Lock : Boolean := False) + is + begin + null; + end Write_Lock; + + procedure Write_Lock (T : Task_ID) is + begin + null; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + begin + Ceiling_Violation := False; + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : access Lock) is + begin + null; + end Unlock; + + procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is + begin + null; + end Unlock; + + procedure Unlock (T : Task_ID) is + begin + null; + end Unlock; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is + begin + null; + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + procedure Timed_Sleep + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) is + begin + Timedout := False; + Yielded := False; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes) is + begin + null; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + begin + return 0.0; + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 10#1.0#E-6; + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is + begin + null; + end Wakeup; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_ID; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) is + begin + null; + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_ID) return System.Any_Priority is + begin + return 0; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_ID) is + begin + null; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + begin + return False; + end Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + return null; + end Register_Foreign_Thread; + + ---------------------- + -- Initialize_TCB -- + ---------------------- + + procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is + begin + Succeeded := False; + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_ID; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) is + begin + Succeeded := False; + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_ID) is + begin + null; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + null; + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_ID) is + begin + null; + end Abort_Task; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + begin + null; + end Yield; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy versions. The only currently working versions is for solaris + -- (native). + + function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_ID is + begin + return null; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + null; + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + null; + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_ID; + Thread_Self : OSI.Thread_Id) + return Boolean + is + begin + return False; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_ID; + Thread_Self : OSI.Thread_Id) + return Boolean + is + begin + return False; + end Resume_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + begin + null; + end Initialize; + + No_Tasking : Boolean; + +begin + -- Can't raise an exception because target independent packages try to + -- do an Abort_Defer, which gets a memory fault. + + No_Tasking := + System.Error_Reporting.Shutdown + ("Tasking not implemented on this configuration"); +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb new file mode 100644 index 00000000000..1aaf3c26c56 --- /dev/null +++ b/gcc/ada/s-taprop-hpux-dce.adb @@ -0,0 +1,1061 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 a HP-UX DCE threads (HPUX 10) version of this package + +-- This package contains all the GNULL primitives that interface directly +-- with the underlying OS. + +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.Tasking.Debug; +-- used for Known_Tasks + +with Interfaces.C; +-- used for int +-- size_t + +with System.Interrupt_Management; +-- used for Keep_Unmasked +-- Abort_Task_Interrupt +-- Interrupt_ID + +with System.Interrupt_Management.Operations; +-- used for Set_Interrupt_Mask +-- All_Tasks_Mask +pragma Elaborate_All (System.Interrupt_Management.Operations); + +with System.Parameters; +-- used for Size_Type + +with System.Task_Primitives.Interrupt_Operations; +-- used for Get_Interrupt_ID + +with System.Tasking; +-- used for Ada_Task_Control_Block +-- Task_ID + +with System.Soft_Links; +-- used for Defer/Undefer_Abort + +-- Note that we do not use System.Tasking.Initialization directly since +-- this is a higher level package that we shouldn't depend on. For example +-- when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Initialization + +with System.OS_Primitives; +-- used for Delay_Modes + +with Unchecked_Conversion; +with Unchecked_Deallocation; + +package body System.Task_Primitives.Operations is + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + + package PIO renames System.Task_Primitives.Interrupt_Operations; + package SSL renames System.Soft_Links; + + ------------------ + -- Local Data -- + ------------------ + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_ID associated with a thread + + Environment_Task_ID : Task_ID; + -- A variable to hold Task_ID for the environment task. + + Unblocked_Signal_Mask : aliased sigset_t; + -- The set of signals that should unblocked in all tasks + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + -- Note: the reason that Locking_Policy is not needed is that this + -- is not implemented for DCE threads. The HPUX 10 port is at this + -- stage considered dead, and no further work is planned on it. + + FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; + -- Indicates whether FIFO_Within_Priorities is set. + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads). + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_ID); + pragma Inline (Initialize); + -- Initialize various data needed by this package. + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does the executing thread have a TCB? + + procedure Set (Self_Id : Task_ID); + pragma Inline (Set); + -- Set the self id for the current task. + + function Self return Task_ID; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task. + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific. + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; + -- Allocate and Initialize a new ATCB for the current Thread. + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_ID is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Abort_Handler (Sig : Signal); + + function To_Address is new Unchecked_Conversion (Task_ID, System.Address); + + ------------------- + -- Abort_Handler -- + ------------------- + + procedure Abort_Handler (Sig : Signal) is + pragma Unreferenced (Sig); + + Self_Id : constant Task_ID := Self; + Result : Interfaces.C.int; + Old_Set : aliased sigset_t; + + begin + if Self_Id.Deferral_Level = 0 + and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level and then + not Self_Id.Aborting + then + Self_Id.Aborting := True; + + -- Make sure signals used for RTS internal purpose are unmasked + + Result := pthread_sigmask (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + ----------------- + -- Stack_Guard -- + ----------------- + + -- The underlying thread system sets a guard page at the + -- bottom of a thread stack, so nothing is needed. + -- ??? Check the comment above + + procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Unreferenced (T, On); + begin + null; + end Stack_Guard; + + ------------------- + -- Get_Thread_Id -- + ------------------- + + function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID renames Specific.Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are + -- initialized in Initialize_TCB and the Storage_Error is + -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) + -- used in RTS is initialized before any status change of RTS. + -- Therefore rasing Storage_Error in the following routines + -- should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : access Lock) + is + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + L.Priority := Prio; + + Result := pthread_mutex_init (L.L'Access, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L.L'Access); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + Result : Interfaces.C.int; + + begin + L.Owner_Priority := Get_Priority (Self); + + if L.Priority < L.Owner_Priority then + Ceiling_Violation := True; + return; + end if; + + Result := pthread_mutex_lock (L.L'Access); + pragma Assert (Result = 0); + Ceiling_Violation := False; + end Write_Lock; + + procedure Write_Lock + (L : access RTS_Lock; Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_ID) is + Result : Interfaces.C.int; + + begin + if not Single_Lock then + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : access Lock) is + Result : Interfaces.C.int; + + begin + Result := pthread_mutex_unlock (L.L'Access); + pragma Assert (Result = 0); + end Unlock; + + procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_ID) is + Result : Interfaces.C.int; + + begin + if not Single_Lock then + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_ID; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + + Result : Interfaces.C.int; + begin + if Single_Lock then + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + else + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + end if; + + -- EINTR is not considered a failure. + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + procedure Timed_Sleep + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Check_Time : constant Duration := Monotonic_Clock; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + Timedout := True; + Yielded := False; + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + end if; + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + or else Self_ID.Pending_Priority_Change; + + if Single_Lock then + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, + Request'Access); + + else + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, + Request'Access); + end if; + + exit when Abs_Time <= Monotonic_Clock; + + if Result = 0 or Result = EINTR then + + -- Somebody may have called Wakeup for us + + Timedout := False; + exit; + end if; + + pragma Assert (Result = ETIMEDOUT); + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes) + is + Check_Time : constant Duration := Monotonic_Clock; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + -- Only the little window between deferring abort and + -- locking Self_ID is the reason we need to + -- check for pending abort and priority change below! :( + + SSL.Abort_Defer.all; + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + if Mode = Relative then + Abs_Time := Time + Check_Time; + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + end if; + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + Self_ID.Common.State := Delay_Sleep; + + loop + if Self_ID.Pending_Priority_Change then + Self_ID.Pending_Priority_Change := False; + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + end if; + + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + if Single_Lock then + Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, Request'Access); + else + Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, Request'Access); + end if; + + exit when Abs_Time <= Monotonic_Clock; + + pragma Assert (Result = 0 or else + Result = ETIMEDOUT or else + Result = EINTR); + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Result := sched_yield; + SSL.Abort_Undefer.all; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; + + begin + Result := Clock_Gettime (CLOCK_REALTIME, TS'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (TS); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 10#1.0#E-6; + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + + Result : Interfaces.C.int; + + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin + if Do_Yield then + Result := sched_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + type Prio_Array_Type is array (System.Any_Priority) of Integer; + pragma Atomic_Components (Prio_Array_Type); + + Prio_Array : Prio_Array_Type; + -- Global array containing the id of the currently running task for + -- each priority. + -- + -- Note: we assume that we are on a single processor with run-til-blocked + -- scheduling. + + procedure Set_Priority + (T : Task_ID; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + Result : Interfaces.C.int; + Array_Item : Integer; + Param : aliased struct_sched_param; + + begin + Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); + + if Time_Slice_Val > 0 then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); + + elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + + else + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + end if; + + pragma Assert (Result = 0); + + if FIFO_Within_Priorities then + + -- Annex D requirement [RM D.2.2 par. 9]: + -- If the task drops its priority due to the loss of inherited + -- priority, it is added at the head of the ready queue for its + -- new active priority. + + if Loss_Of_Inheritance + and then Prio < T.Common.Current_Priority + then + Array_Item := Prio_Array (T.Common.Base_Priority) + 1; + Prio_Array (T.Common.Base_Priority) := Array_Item; + + loop + -- Let some processes a chance to arrive + + Yield; + + -- Then wait for our turn to proceed + + exit when Array_Item = Prio_Array (T.Common.Base_Priority) + or else Prio_Array (T.Common.Base_Priority) = 1; + end loop; + + Prio_Array (T.Common.Base_Priority) := + Prio_Array (T.Common.Base_Priority) - 1; + end if; + end if; + + T.Common.Current_Priority := Prio; + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_ID) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_ID) is + begin + Self_ID.Common.LL.Thread := pthread_self; + Specific.Set (Self_ID); + + Lock_RTS; + + for J in Known_Tasks'Range loop + if Known_Tasks (J) = null then + Known_Tasks (J) := Self_ID; + Self_ID.Known_Tasks_Index := J; + exit; + end if; + end loop; + + Unlock_RTS; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + + begin + if not Single_Lock then + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, + Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, + Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + else + if not Single_Lock then + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_ID; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Attributes : aliased pthread_attr_t; + Adjusted_Stack_Size : Interfaces.C.size_t; + Result : Interfaces.C.int; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + begin + if Stack_Size = Unspecified_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size); + + elsif Stack_Size < Minimum_Stack_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); + + else + Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); + end if; + + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); + pragma Assert (Result = 0); + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + Result := pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + pragma Assert (Result = 0 or else Result = EAGAIN); + + Succeeded := Result = 0; + + pthread_detach (T.Common.LL.Thread'Access); + -- Detach the thread using pthread_detach, sinc DCE threads do not have + -- pthread_attr_set_detachstate. + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + + Set_Priority (T, Priority); + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_ID) is + Result : Interfaces.C.int; + Tmp : Task_ID := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); + + begin + if not Single_Lock then + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_ID) is + begin + -- + -- Interrupt Server_Tasks may be waiting on an "event" flag (signal) + -- + if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then + System.Interrupt_Management.Operations.Interrupt_Self_Process + (System.Interrupt_Management.Interrupt_ID + (PIO.Get_Interrupt_ID (T))); + end if; + end Abort_Task; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy versions. The only currently working versions is for solaris + -- (native). + + function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_ID is + begin + return Environment_Task_ID; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) + return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + + begin + return False; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) + return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + + begin + return False; + end Resume_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + + function State (Int : System.Interrupt_Management.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: + + 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 + Environment_Task_ID := Environment_Task; + + -- Initialize the lock used to synchronize chain of all ATCBs. + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Specific.Initialize (Environment_Task); + + Enter_Task (Environment_Task); + + -- Install the abort-signal handler + + if State (System.Interrupt_Management.Abort_Task_Interrupt) + /= Default + then + act.sa_flags := 0; + act.sa_handler := Abort_Handler'Address; + + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction ( + Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + end if; + end Initialize; + + -- NOTE: Unlike other pthread implementations, we do *not* mask all + -- signals here since we handle signals using the process-wide primitive + -- signal, rather than using sigthreadmask and sigwait. The reason of + -- this difference is that sigwait doesn't work when some critical + -- signals (SIGABRT, SIGPIPE) are masked. + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-irix-athread.adb b/gcc/ada/s-taprop-irix-athread.adb new file mode 100644 index 00000000000..3c70a347ef2 --- /dev/null +++ b/gcc/ada/s-taprop-irix-athread.adb @@ -0,0 +1,955 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 an Irix (old athread library) version of this package + +-- This package contains all the GNULL primitives that interface directly +-- with the underlying OS. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Interfaces.C; +-- used for int +-- size_t + +with System.Tasking.Debug; +-- used for Known_Tasks + +with System.Task_Info; + +with System.Interrupt_Management; +-- used for Keep_Unmasked +-- Abort_Task_Interrupt +-- Interrupt_ID + +with System.Parameters; +-- used for Size_Type + +with System.Tasking; +-- used for Ada_Task_Control_Block +-- Task_ID + +with System.Program_Info; +-- used for Default_Task_Stack +-- Default_Time_Slice +-- Stack_Guard_Pages +-- Pthread_Sched_Signal +-- Pthread_Arena_Size + +with System.Soft_Links; +-- used for Defer/Undefer_Abort + +-- Note that we do not use System.Tasking.Initialization directly since +-- this is a higher level package that we shouldn't depend on. For example +-- when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Initialization + +with System.OS_Primitives; +-- used for Delay_Modes + +with System.Storage_Elements; +-- used for To_Address + +with Unchecked_Conversion; +with Unchecked_Deallocation; + +package body System.Task_Primitives.Operations is + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + + package SSL renames System.Soft_Links; + + ----------------- + -- Local Data -- + ----------------- + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + Environment_Task_ID : Task_ID; + -- A variable to hold Task_ID for the environment task. + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + + Clock_Address : constant System.Address := + System.Storage_Elements.To_Address (16#200F90#); + + RT_Clock_Id : clockid_t; + for RT_Clock_Id'Address use Clock_Address; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Initialize_Athread_Library; + + function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID); + + function To_Address is new Unchecked_Conversion (Task_ID, System.Address); + + ------------------- + -- Stack_Guard -- + ------------------- + + -- The underlying thread system sets a guard page at the + -- bottom of a thread stack, so nothing is needed. + -- ??? Check the comment above + + procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Unreferenced (T); + pragma Unreferenced (On); + begin + null; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID is + begin + return To_Task_ID (pthread_get_current_ada_tcb); + end Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are + -- initialized in Initialize_TCB and the Storage_Error is + -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) + -- used in RTS is initialized before any status change of RTS. + -- Therefore rasing Storage_Error in the following routines + -- should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : access Lock) + is + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + + if Result = FUNC_ERR then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + + Result := pthread_mutexattr_setqueueorder + (Attributes'Access, MUTEX_PRIORITY_CEILING); + + pragma Assert (Result /= FUNC_ERR); + + Result := pthread_mutexattr_setceilingprio + (Attributes'Access, Interfaces.C.int (Prio)); + + pragma Assert (Result /= FUNC_ERR); + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + + if Result = FUNC_ERR then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + end Initialize_Lock; + + procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + + if Result = FUNC_ERR then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + Result := pthread_mutexattr_setqueueorder + (Attributes'Access, MUTEX_PRIORITY_CEILING); + pragma Assert (Result /= FUNC_ERR); + + Result := pthread_mutexattr_setceilingprio + (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); + pragma Assert (Result /= FUNC_ERR); + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + + if Result = FUNC_ERR then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_lock (L); + Ceiling_Violation := Result = FUNC_ERR and then errno = EINVAL; + pragma Assert (Result /= FUNC_ERR); + end Write_Lock; + + procedure Write_Lock + (L : access RTS_Lock; Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_ID) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end Unlock; + + procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_ID) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : ST.Task_ID; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + + Result : Interfaces.C.int; + + begin + if Single_Lock then + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + else + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + end if; + + -- EINTR is not considered a failure. + + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + procedure Timed_Sleep + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Check_Time : constant Duration := Monotonic_Clock; + Abs_Time : Duration; + Request : aliased struct_timeval; + Result : Interfaces.C.int; + + begin + Timedout := True; + Yielded := False; + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + end if; + + if Abs_Time > Check_Time then + Request := To_Timeval (Abs_Time); + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + or else Self_ID.Pending_Priority_Change; + + if Single_Lock then + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, + Request'Access); + + else + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, + Request'Access); + end if; + + exit when Abs_Time <= Monotonic_Clock; + + if Result = 0 or Result = EINTR then + -- somebody may have called Wakeup for us + Timedout := False; + exit; + end if; + + pragma Assert (Result = ETIMEDOUT + or else (Result = -1 and then errno = EAGAIN)); + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes) + is + Check_Time : constant Duration := Monotonic_Clock; + Abs_Time : Duration; + Request : aliased struct_timeval; + Result : Interfaces.C.int; + + begin + -- Only the little window between deferring abort and + -- locking Self_ID is the reason we need to + -- check for pending abort and priority change below! + + SSL.Abort_Defer.all; + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + if Mode = Relative then + Abs_Time := Time + Check_Time; + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + end if; + + if Abs_Time > Check_Time then + Request := To_Timeval (Abs_Time); + Self_ID.Common.State := Delay_Sleep; + + loop + if Self_ID.Pending_Priority_Change then + Self_ID.Pending_Priority_Change := False; + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + end if; + + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + if Single_Lock then + Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, Request'Access); + else + Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, Request'Access); + end if; + + exit when Abs_Time <= Monotonic_Clock; + + pragma Assert (Result = 0 or else + Result = ETIMEDOUT or else + (Result = -1 and then errno = EAGAIN) or else + Result = EINTR); + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + pthread_yield; + SSL.Abort_Undefer.all; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + type timeval is record + tv_sec : Integer; + tv_usec : Integer; + end record; + pragma Convention (C, timeval); + + tv : aliased timeval; + + procedure gettimeofday (tp : access timeval); + pragma Import (C, gettimeofday, "gettimeofday", "gettimeofday"); + + begin + gettimeofday (tv'Access); + return Duration (tv.tv_sec) + Duration (tv.tv_usec) / 1_000_000.0; + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 10#1.0#E-6; + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup + (T : ST.Task_ID; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + begin + if Do_Yield then + pthread_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_ID; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + pragma Unreferenced (Loss_Of_Inheritance); + + Result : Interfaces.C.int; + + begin + T.Common.Current_Priority := Prio; + Result := pthread_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio)); + pragma Assert (Result /= FUNC_ERR); + + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_ID) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_ID) is + Result : Interfaces.C.int; + + begin + Self_ID.Common.LL.Thread := pthread_self; + Self_ID.Common.LL.LWP := sproc_self; + + Result := + pthread_set_ada_tcb (Self_ID.Common.LL.Thread, To_Address (Self_ID)); + + pragma Assert (Result = 0); + + Lock_RTS; + + for J in Known_Tasks'Range loop + if Known_Tasks (J) = null then + Known_Tasks (J) := Self_ID; + Self_ID.Known_Tasks_Index := J; + exit; + end if; + end loop; + + Unlock_RTS; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + begin + return False; + end Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + return null; + end Register_Foreign_Thread; + + ---------------------- + -- Initialize_TCB -- + ---------------------- + + procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is + Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + + begin + if not Single_Lock then + Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); + end if; + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, + Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + else + if not Single_Lock then + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_ID; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Attributes : aliased pthread_attr_t; + Adjusted_Stack_Size : Interfaces.C.size_t; + Result : Interfaces.C.int; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, start_addr); + + function To_Resource_T is new Unchecked_Conversion + (System.Task_Info.Resource_Vector_T, System.OS_Interface.resource_t); + + use System.Task_Info; + + begin + if Stack_Size = Unspecified_Size then + Adjusted_Stack_Size := + Interfaces.C.size_t (System.Program_Info.Default_Task_Stack); + + elsif Stack_Size < Minimum_Stack_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); + + else + Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); + end if; + + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_attr_setdetachstate (Attributes'Access, 1); + pragma Assert (Result = 0); + + Result := pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); + pragma Assert (Result = 0); + + if T.Common.Task_Info /= null then + Result := pthread_attr_setresources + (Attributes'Access, + To_Resource_T (T.Common.Task_Info.Thread_Resources)); + pragma Assert (Result /= FUNC_ERR); + + if T.Common.Task_Info.Thread_Timeslice /= 0.0 then + declare + use System.OS_Interface; + + Tv : aliased struct_timeval := To_Timeval + (T.Common.Task_Info.Thread_Timeslice); + begin + Result := pthread_attr_set_tslice + (Attributes'Access, Tv'Access); + end; + end if; + + if T.Common.Task_Info.Bound_To_Sproc then + Result := pthread_attr_set_boundtosproc + (Attributes'Access, PTHREAD_BOUND); + Result := pthread_attr_set_bsproc + (Attributes'Access, T.Common.Task_Info.Sproc); + end if; + + end if; + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + Result := pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + pragma Assert (Result = 0 or else Result = EAGAIN); + + Succeeded := Result = 0; + + Set_Priority (T, Priority); + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result /= FUNC_ERR); + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_ID) is + procedure Free is new + Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); + + Result : Interfaces.C.int; + Tmp : Task_ID := T; + + begin + if not Single_Lock then + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + Result : Interfaces.C.int; + begin + Result := pthread_set_ada_tcb (pthread_self, System.Null_Address); + pragma Assert (Result = 0); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_ID) is + Result : Interfaces.C.int; + begin + Result := + pthread_kill (T.Common.LL.Thread, + Interfaces.C.int + (System.Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + end Abort_Task; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_ID is + begin + return Environment_Task_ID; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= Thread_Self then + return pthread_suspend (T.Common.LL.Thread) = 0; + else + return True; + end if; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= Thread_Self then + return pthread_resume (T.Common.LL.Thread) = 0; + else + return True; + end if; + end Resume_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + begin + Environment_Task_ID := Environment_Task; + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + -- Initialize the lock used to synchronize chain of all ATCBs. + + Enter_Task (Environment_Task); + + Set_Priority (Environment_Task, + Environment_Task.Common.Current_Priority); + end Initialize; + + -------------------------------- + -- Initialize_Athread_Library -- + -------------------------------- + + procedure Initialize_Athread_Library is + Result : Interfaces.C.int; + Init : aliased pthread_init_struct; + + package PINF renames System.Program_Info; + package C renames Interfaces.C; + + begin + Init.conf_initsize := C.int (PINF.Pthread_Arena_Size); + Init.max_sproc_count := C.int (PINF.Max_Sproc_Count); + Init.sproc_stack_size := C.size_t (PINF.Sproc_Stack_Size); + Init.os_default_priority := C.int (PINF.Os_Default_Priority); + Init.os_sched_signal := C.int (PINF.Pthread_Sched_Signal); + Init.guard_pages := C.int (PINF.Stack_Guard_Pages); + Init.init_sproc_count := C.int (PINF.Initial_Sproc_Count); + + Result := pthread_exec_begin (Init'Access); + pragma Assert (Result /= FUNC_ERR); + + if Result = FUNC_ERR then + raise Storage_Error; -- Insufficient resources. + end if; + end Initialize_Athread_Library; + +-- Package initialization + +begin + Initialize_Athread_Library; +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb new file mode 100644 index 00000000000..6eb6e2ad52a --- /dev/null +++ b/gcc/ada/s-taprop-irix.adb @@ -0,0 +1,1139 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 a IRIX (pthread library) version of this package + +-- This package contains all the GNULL primitives that interface directly +-- with the underlying OS. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Interfaces.C; +-- used for int +-- size_t + +with System.Task_Info; + +with System.Tasking.Debug; +-- used for Known_Tasks + +with System.IO; +-- used for Put_Line + +with System.Interrupt_Management; +-- used for Keep_Unmasked +-- Abort_Task_Interrupt +-- Interrupt_ID + +with System.Interrupt_Management.Operations; +-- used for Set_Interrupt_Mask +-- All_Tasks_Mask +pragma Elaborate_All (System.Interrupt_Management.Operations); + +with System.Parameters; +-- used for Size_Type + +with System.Tasking; +-- used for Ada_Task_Control_Block +-- Task_ID + +with System.Soft_Links; +-- used for Defer/Undefer_Abort + +-- Note that we do not use System.Tasking.Initialization directly since +-- this is a higher level package that we shouldn't depend on. For example +-- when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Initialization + +with System.Program_Info; +-- used for Default_Task_Stack +-- Default_Time_Slice +-- Stack_Guard_Pages +-- Pthread_Sched_Signal +-- Pthread_Arena_Size + +with System.OS_Interface; +-- used for various type, constant, and operations + +with System.OS_Primitives; +-- used for Delay_Modes + +with Unchecked_Conversion; +with Unchecked_Deallocation; + +package body System.Task_Primitives.Operations is + + use System.Tasking; + use System.Tasking.Debug; + use Interfaces.C; + use System.OS_Interface; + use System.OS_Primitives; + use System.Parameters; + + package SSL renames System.Soft_Links; + + ------------------ + -- Local Data -- + ------------------ + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_ID associated with a thread + + Environment_Task_ID : Task_ID; + -- A variable to hold Task_ID for the environment task. + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + + Real_Time_Clock_Id : constant clockid_t := CLOCK_REALTIME; + + Unblocked_Signal_Mask : aliased sigset_t; + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads). + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_ID); + pragma Inline (Initialize); + -- Initialize various data needed by this package. + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_ID); + pragma Inline (Set); + -- Set the self id for the current task. + + function Self return Task_ID; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task. + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific. + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; + -- Allocate and Initialize a new ATCB for the current Thread. + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_ID is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function To_Address is new Unchecked_Conversion (Task_ID, System.Address); + + procedure Abort_Handler (Sig : Signal); + -- Signal handler used to implement asynchronous abort. + + ------------------- + -- Abort_Handler -- + ------------------- + + procedure Abort_Handler (Sig : Signal) is + pragma Unreferenced (Sig); + + T : constant Task_ID := Self; + Result : Interfaces.C.int; + Old_Set : aliased sigset_t; + + begin + -- It is not safe to raise an exception when using ZCX and the GCC + -- exception handling mechanism. + + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + + if T.Deferral_Level = 0 + and then T.Pending_ATC_Level < T.ATC_Nesting_Level + then + -- Make sure signals used for RTS internal purpose are unmasked + + Result := pthread_sigmask + (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, + Old_Set'Unchecked_Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + ----------------- + -- Stack_Guard -- + ----------------- + + -- The underlying thread system sets a guard page at the + -- bottom of a thread stack, so nothing is needed. + + procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Unreferenced (On); + pragma Unreferenced (T); + begin + null; + end Stack_Guard; + + ------------------- + -- Get_Thread_Id -- + ------------------- + + function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID renames Specific.Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are + -- initialized in Initialize_TCB and the Storage_Error is + -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) + -- used in RTS is initialized before any status change of RTS. + -- Therefore rasing Storage_Error in the following routines + -- should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : access Lock) + is + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := pthread_mutexattr_setprioceiling + (Attributes'Access, Interfaces.C.int (Prio)); + pragma Assert (Result = 0); + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := pthread_mutexattr_setprioceiling + (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); + pragma Assert (Result = 0); + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_lock (L); + Ceiling_Violation := Result = EINVAL; + + -- Assumes the cause of EINVAL is a priority ceiling violation + + pragma Assert (Result = 0 or else Result = EINVAL); + end Write_Lock; + + procedure Write_Lock + (L : access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_ID) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end Unlock; + + procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is + Result : Interfaces.C.int; + + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_ID) is + Result : Interfaces.C.int; + + begin + if not Single_Lock then + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : ST.Task_ID; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + + Result : Interfaces.C.int; + + begin + if Single_Lock then + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + else + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + end if; + + -- EINTR is not considered a failure. + + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + procedure Timed_Sleep + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Check_Time : constant Duration := Monotonic_Clock; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + Timedout := True; + Yielded := False; + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + end if; + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + or else Self_ID.Pending_Priority_Change; + + if Single_Lock then + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, + Request'Access); + + else + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, + Request'Access); + end if; + + exit when Abs_Time <= Monotonic_Clock; + + if Result = 0 or else errno = EINTR then + Timedout := False; + exit; + end if; + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + -- This is for use in implementing delay statements, so + -- we assume the caller is abort-deferred but is holding + -- no locks. + + procedure Timed_Delay + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes) + is + Check_Time : constant Duration := Monotonic_Clock; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + -- Only the little window between deferring abort and + -- locking Self_ID is the reason we need to + -- check for pending abort and priority change below! :( + + SSL.Abort_Defer.all; + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + if Mode = Relative then + Abs_Time := Time + Check_Time; + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + end if; + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + Self_ID.Common.State := Delay_Sleep; + + loop + if Self_ID.Pending_Priority_Change then + Self_ID.Pending_Priority_Change := False; + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + end if; + + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, Request'Access); + exit when Abs_Time <= Monotonic_Clock; + + pragma Assert (Result = 0 + or else Result = ETIMEDOUT + or else Result = EINTR); + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Yield; + SSL.Abort_Undefer.all; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; + begin + Result := clock_gettime (Real_Time_Clock_Id, TS'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (TS); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + -- The clock_getres (Real_Time_Clock_Id) function appears to return + -- the interrupt resolution of the realtime clock and not the actual + -- resolution of reading the clock. Even though this last value is + -- only guaranteed to be 100 Hz, at least the Origin 200 appears to + -- have a microsecond resolution or better. + -- ??? We should figure out a method to return the right value on + -- all SGI hardware. + + return 0.000_001; -- Assume microsecond resolution of clock + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : ST.Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin + if Do_Yield then + Result := sched_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_ID; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + pragma Unreferenced (Loss_Of_Inheritance); + + Result : Interfaces.C.int; + Param : aliased struct_sched_param; + Sched_Policy : Interfaces.C.int; + + use type System.Task_Info.Task_Info_Type; + + function To_Int is new Unchecked_Conversion + (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int); + + begin + T.Common.Current_Priority := Prio; + Param.sched_priority := Interfaces.C.int (Prio); + + if T.Common.Task_Info /= null then + Sched_Policy := To_Int (T.Common.Task_Info.Policy); + else + Sched_Policy := SCHED_FIFO; + end if; + + Result := pthread_setschedparam (T.Common.LL.Thread, Sched_Policy, + Param'Access); + pragma Assert (Result = 0); + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_ID) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_ID) is + Result : Interfaces.C.int; + + function To_Int is new Unchecked_Conversion + (System.Task_Info.CPU_Number, Interfaces.C.int); + + use System.Task_Info; + + begin + Self_ID.Common.LL.Thread := pthread_self; + Specific.Set (Self_ID); + + if Self_ID.Common.Task_Info /= null + and then Self_ID.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM + and then Self_ID.Common.Task_Info.Runon_CPU /= ANY_CPU + then + Result := pthread_setrunon_np + (To_Int (Self_ID.Common.Task_Info.Runon_CPU)); + pragma Assert (Result = 0); + end if; + + Lock_RTS; + + for J in Known_Tasks'Range loop + if Known_Tasks (J) = null then + Known_Tasks (J) := Self_ID; + Self_ID.Known_Tasks_Index := J; + exit; + end if; + end loop; + + Unlock_RTS; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is + Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + + begin + if not Single_Lock then + Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); + end if; + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, + Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + else + if not Single_Lock then + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_ID; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + use System.Task_Info; + + Attributes : aliased pthread_attr_t; + Sched_Param : aliased struct_sched_param; + Adjusted_Stack_Size : Interfaces.C.size_t; + Result : Interfaces.C.int; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + function To_Int is new Unchecked_Conversion + (System.Task_Info.Thread_Scheduling_Scope, Interfaces.C.int); + function To_Int is new Unchecked_Conversion + (System.Task_Info.Thread_Scheduling_Inheritance, Interfaces.C.int); + function To_Int is new Unchecked_Conversion + (System.Task_Info.Thread_Scheduling_Policy, Interfaces.C.int); + + begin + if Stack_Size = System.Parameters.Unspecified_Size then + Adjusted_Stack_Size := + Interfaces.C.size_t (System.Program_Info.Default_Task_Stack); + + elsif Stack_Size < Size_Type (Minimum_Stack_Size) then + Adjusted_Stack_Size := + Interfaces.C.size_t (Minimum_Stack_Size); + + else + Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); + end if; + + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); + pragma Assert (Result = 0); + + Result := pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); + pragma Assert (Result = 0); + + if T.Common.Task_Info /= null then + Result := pthread_attr_setscope + (Attributes'Access, To_Int (T.Common.Task_Info.Scope)); + pragma Assert (Result = 0); + + Result := pthread_attr_setinheritsched + (Attributes'Access, To_Int (T.Common.Task_Info.Inheritance)); + pragma Assert (Result = 0); + + Result := pthread_attr_setschedpolicy + (Attributes'Access, To_Int (T.Common.Task_Info.Policy)); + pragma Assert (Result = 0); + + Sched_Param.sched_priority := + Interfaces.C.int (T.Common.Task_Info.Priority); + + Result := pthread_attr_setschedparam + (Attributes'Access, Sched_Param'Access); + pragma Assert (Result = 0); + end if; + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + Result := pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + + if Result /= 0 + and then T.Common.Task_Info /= null + and then T.Common.Task_Info.Scope = PTHREAD_SCOPE_SYSTEM + then + -- The pthread_create call may have failed because we + -- asked for a system scope pthread and none were + -- available (probably because the program was not executed + -- by the superuser). Let's try for a process scope pthread + -- instead of raising Tasking_Error. + + System.IO.Put_Line + ("Request for PTHREAD_SCOPE_SYSTEM in Task_Info pragma for task"); + System.IO.Put (""""); + System.IO.Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len)); + System.IO.Put_Line (""" could not be honored. "); + System.IO.Put_Line ("Scope changed to PTHREAD_SCOPE_PROCESS"); + + T.Common.Task_Info.Scope := PTHREAD_SCOPE_PROCESS; + Result := pthread_attr_setscope + (Attributes'Access, To_Int (T.Common.Task_Info.Scope)); + pragma Assert (Result = 0); + + Result := pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + end if; + + pragma Assert (Result = 0 or else Result = EAGAIN); + + Succeeded := Result = 0; + + -- The following needs significant commenting ??? + + if T.Common.Task_Info /= null then + T.Common.Base_Priority := T.Common.Task_Info.Priority; + Set_Priority (T, T.Common.Task_Info.Priority); + else + Set_Priority (T, Priority); + end if; + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_ID) is + Result : Interfaces.C.int; + Tmp : Task_ID := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); + + begin + if not Single_Lock then + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_ID) is + Result : Interfaces.C.int; + + begin + Result := pthread_kill (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + end Abort_Task; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_ID is + begin + return Environment_Task_ID; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) + return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + + begin + return False; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) + return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + + begin + return False; + end Resume_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + + function State (Int : System.Interrupt_Management.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: + + 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 + Environment_Task_ID := Environment_Task; + + -- Initialize the lock used to synchronize chain of all ATCBs. + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Specific.Initialize (Environment_Task); + + Enter_Task (Environment_Task); + + -- Install the abort-signal handler + + if State (System.Interrupt_Management.Abort_Task_Interrupt) + /= Default + then + act.sa_flags := 0; + act.sa_handler := Abort_Handler'Address; + + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction ( + Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + end if; + end Initialize; + +begin + declare + Result : Interfaces.C.int; + + begin + -- Mask Environment task for all signals. The original mask of the + -- Environment task will be recovered by Interrupt_Server task + -- during the elaboration of s-interr.adb. + + System.Interrupt_Management.Operations.Set_Interrupt_Mask + (System.Interrupt_Management.Operations.All_Tasks_Mask'Access); + + -- Prepare the set of signals that should unblocked in all tasks + + Result := sigemptyset (Unblocked_Signal_Mask'Access); + pragma Assert (Result = 0); + + for J in Interrupt_Management.Interrupt_ID loop + if System.Interrupt_Management.Keep_Unmasked (J) then + Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + + -- Pick the highest resolution Clock for Clock_Realtime + -- ??? This code currently doesn't work (see c94007[ab] for example) + -- + -- if syssgi (SGI_CYCLECNTR_SIZE) = 64 then + -- Real_Time_Clock_Id := CLOCK_SGI_CYCLE; + -- else + -- Real_Time_Clock_Id := CLOCK_REALTIME; + -- end if; + end; +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb new file mode 100644 index 00000000000..6ab670f9722 --- /dev/null +++ b/gcc/ada/s-taprop-linux.adb @@ -0,0 +1,1094 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 a GNU/Linux (GNU/LinuxThreads) version of this package + +-- This package contains all the GNULL primitives that interface directly +-- with the underlying OS. + +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.Tasking.Debug; +-- used for Known_Tasks + +with Interfaces.C; +-- used for int +-- size_t + +with System.Interrupt_Management; +-- used for Keep_Unmasked +-- Abort_Task_Interrupt +-- Interrupt_ID + +with System.Interrupt_Management.Operations; +-- used for Set_Interrupt_Mask +-- All_Tasks_Mask +pragma Elaborate_All (System.Interrupt_Management.Operations); + +with System.Parameters; +-- used for Size_Type + +with System.Tasking; +-- used for Ada_Task_Control_Block +-- Task_ID + +with Ada.Exceptions; +-- used for Raise_Exception +-- Raise_From_Signal_Handler +-- Exception_Id + +with System.Soft_Links; +-- used for Defer/Undefer_Abort + +-- Note that we do not use System.Tasking.Initialization directly since +-- this is a higher level package that we shouldn't depend on. For example +-- when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Initialization + +with System.OS_Primitives; +-- used for Delay_Modes + +with System.Soft_Links; +-- used for Get_Machine_State_Addr + +with Unchecked_Conversion; +with Unchecked_Deallocation; + +package body System.Task_Primitives.Operations is + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + + package SSL renames System.Soft_Links; + + ------------------ + -- Local Data -- + ------------------ + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_ID associated with a thread + + Environment_Task_ID : Task_ID; + -- A variable to hold Task_ID for the environment task. + + Unblocked_Signal_Mask : aliased sigset_t; + -- The set of signals that should unblocked in all tasks + + -- The followings are internal configuration constants needed. + Priority_Ceiling_Emulation : constant Boolean := True; + + Next_Serial_Number : Task_Serial_Number := 100; + -- We start at 100, to reserve some special values for + -- using in error checking. + -- The following are internal configuration constants needed. + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; + -- Indicates whether FIFO_Within_Priorities is set. + + -- The following are effectively constants, but they need to + -- be initialized by calling a pthread_ function. + + Mutex_Attr : aliased pthread_mutexattr_t; + Cond_Attr : aliased pthread_condattr_t; + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads). + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_ID); + pragma Inline (Initialize); + -- Initialize various data needed by this package. + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_ID); + pragma Inline (Set); + -- Set the self id for the current task. + + function Self return Task_ID; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task. + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific. + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; + -- Allocate and Initialize a new ATCB for the current Thread. + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_ID is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + subtype unsigned_long is Interfaces.C.unsigned_long; + + procedure Abort_Handler (signo : Signal); + + function To_pthread_t is new Unchecked_Conversion + (unsigned_long, System.OS_Interface.pthread_t); + + ------------------- + -- Abort_Handler -- + ------------------- + + procedure Abort_Handler (signo : Signal) is + pragma Unreferenced (signo); + + Self_Id : constant Task_ID := Self; + Result : Interfaces.C.int; + Old_Set : aliased sigset_t; + + begin + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + + if Self_Id.Deferral_Level = 0 + and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level + and then not Self_Id.Aborting + then + Self_Id.Aborting := True; + + -- Make sure signals used for RTS internal purpose are unmasked + + Result := pthread_sigmask (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ----------------- + -- Stack_Guard -- + ----------------- + + -- The underlying thread system extends the memory (up to 2MB) when needed + + procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Unreferenced (T); + pragma Unreferenced (On); + + begin + null; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID renames Specific.Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are + -- initialized in Initialize_TCB and the Storage_Error is + -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) + -- used in RTS is initialized before any status change of RTS. + -- Therefore rasing Storage_Error in the following routines + -- should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : access Lock) + is + Result : Interfaces.C.int; + + begin + if Priority_Ceiling_Emulation then + L.Ceiling := Prio; + end if; + + Result := pthread_mutex_init (L.L'Access, Mutex_Attr'Access); + + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Ada.Exceptions.Raise_Exception (Storage_Error'Identity, + "Failed to allocate a lock"); + end if; + end Initialize_Lock; + + procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + + Result : Interfaces.C.int; + + begin + Result := pthread_mutex_init (L, Mutex_Attr'Access); + + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : access Lock) is + Result : Interfaces.C.int; + + begin + Result := pthread_mutex_destroy (L.L'Access); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : access RTS_Lock) is + Result : Interfaces.C.int; + + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + Result : Interfaces.C.int; + + begin + if Priority_Ceiling_Emulation then + declare + Self_ID : constant Task_ID := Self; + + begin + if Self_ID.Common.LL.Active_Priority > L.Ceiling then + Ceiling_Violation := True; + return; + end if; + + L.Saved_Priority := Self_ID.Common.LL.Active_Priority; + + if Self_ID.Common.LL.Active_Priority < L.Ceiling then + Self_ID.Common.LL.Active_Priority := L.Ceiling; + end if; + + Result := pthread_mutex_lock (L.L'Access); + pragma Assert (Result = 0); + Ceiling_Violation := False; + end; + + else + Result := pthread_mutex_lock (L.L'Access); + Ceiling_Violation := Result = EINVAL; + + -- Assume the cause of EINVAL is a priority ceiling violation + + pragma Assert (Result = 0 or else Result = EINVAL); + end if; + end Write_Lock; + + procedure Write_Lock + (L : access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_ID) is + Result : Interfaces.C.int; + + begin + if not Single_Lock then + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : access Lock) is + Result : Interfaces.C.int; + + begin + if Priority_Ceiling_Emulation then + declare + Self_ID : constant Task_ID := Self; + + begin + Result := pthread_mutex_unlock (L.L'Access); + pragma Assert (Result = 0); + + if Self_ID.Common.LL.Active_Priority > L.Saved_Priority then + Self_ID.Common.LL.Active_Priority := L.Saved_Priority; + end if; + end; + + else + Result := pthread_mutex_unlock (L.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is + Result : Interfaces.C.int; + + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_ID) is + Result : Interfaces.C.int; + + begin + if not Single_Lock then + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_ID; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + + Result : Interfaces.C.int; + + begin + pragma Assert (Self_ID = Self); + + if Single_Lock then + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + else + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + end if; + + -- EINTR is not considered a failure. + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is + -- assumed to be already deferred, and the caller should be + -- holding its own ATCB lock. + + procedure Timed_Sleep + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Check_Time : constant Duration := Monotonic_Clock; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + Timedout := True; + Yielded := False; + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + end if; + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + or else Self_ID.Pending_Priority_Change; + + if Single_Lock then + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, + Request'Access); + + else + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, + Request'Access); + end if; + + exit when Abs_Time <= Monotonic_Clock; + + if Result = 0 or Result = EINTR then + -- somebody may have called Wakeup for us + Timedout := False; + exit; + end if; + + pragma Assert (Result = ETIMEDOUT); + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + -- This is for use in implementing delay statements, so + -- we assume the caller is abort-deferred but is holding + -- no locks. + + procedure Timed_Delay + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes) + is + Check_Time : constant Duration := Monotonic_Clock; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + begin + + -- Only the little window between deferring abort and + -- locking Self_ID is the reason we need to + -- check for pending abort and priority change below! :( + + SSL.Abort_Defer.all; + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + if Mode = Relative then + Abs_Time := Time + Check_Time; + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + end if; + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + Self_ID.Common.State := Delay_Sleep; + + loop + if Self_ID.Pending_Priority_Change then + Self_ID.Pending_Priority_Change := False; + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + end if; + + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + if Single_Lock then + Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, Request'Access); + else + Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, Request'Access); + end if; + + exit when Abs_Time <= Monotonic_Clock; + + pragma Assert (Result = 0 or else + Result = ETIMEDOUT or else + Result = EINTR); + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Result := sched_yield; + SSL.Abort_Undefer.all; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TV : aliased struct_timeval; + Result : Interfaces.C.int; + + begin + Result := gettimeofday (TV'Access, System.Null_Address); + pragma Assert (Result = 0); + return To_Duration (TV); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 10#1.0#E-6; + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin + if Do_Yield then + Result := sched_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_ID; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + pragma Unreferenced (Loss_Of_Inheritance); + + Result : Interfaces.C.int; + Param : aliased struct_sched_param; + + begin + T.Common.Current_Priority := Prio; + + if Priority_Ceiling_Emulation then + if T.Common.LL.Active_Priority < Prio then + T.Common.LL.Active_Priority := Prio; + end if; + end if; + + -- Priorities are in range 1 .. 99 on GNU/Linux, so we map + -- map 0 .. 31 to 1 .. 32 + + Param.sched_priority := Interfaces.C.int (Prio) + 1; + + if Time_Slice_Val > 0 then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); + + elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + + else + Param.sched_priority := 0; + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + end if; + + pragma Assert (Result = 0 or else Result = EPERM); + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_ID) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_ID) is + begin + Self_ID.Common.LL.Thread := pthread_self; + + Specific.Set (Self_ID); + + Lock_RTS; + + for J in Known_Tasks'Range loop + if Known_Tasks (J) = null then + Known_Tasks (J) := Self_ID; + Self_ID.Known_Tasks_Index := J; + exit; + end if; + end loop; + + Unlock_RTS; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is + Result : Interfaces.C.int; + + begin + -- Give the task a unique serial number. + + Self_ID.Serial_Number := Next_Serial_Number; + Next_Serial_Number := Next_Serial_Number + 1; + pragma Assert (Next_Serial_Number /= 0); + + Self_ID.Common.LL.Thread := To_pthread_t (-1); + + if not Single_Lock then + Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, + Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + end if; + + Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, + Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Succeeded := True; + else + if not Single_Lock then + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_ID; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Adjusted_Stack_Size : Interfaces.C.size_t; + + Attributes : aliased pthread_attr_t; + Result : Interfaces.C.int; + + begin + if Stack_Size = Unspecified_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size); + + elsif Stack_Size < Minimum_Stack_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); + + else + Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); + end if; + + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := + pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); + pragma Assert (Result = 0); + + Result := + pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); + pragma Assert (Result = 0); + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + Result := pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + pragma Assert (Result = 0 or else Result = EAGAIN); + + Succeeded := Result = 0; + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + + Set_Priority (T, Priority); + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_ID) is + Result : Interfaces.C.int; + Tmp : Task_ID := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); + + begin + if not Single_Lock then + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_ID) is + Result : Interfaces.C.int; + + begin + Result := pthread_kill (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + end Abort_Task; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_ID is + begin + return Environment_Task_ID; + end Environment_Task; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= Thread_Self then + return pthread_kill (T.Common.LL.Thread, SIGSTOP) = 0; + else + return True; + end if; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= Thread_Self then + return pthread_kill (T.Common.LL.Thread, SIGCONT) = 0; + else + return True; + end if; + end Resume_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + + function State (Int : System.Interrupt_Management.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: + + 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 + Environment_Task_ID := Environment_Task; + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + -- Initialize the global RTS lock + + Specific.Initialize (Environment_Task); + + Enter_Task (Environment_Task); + + -- Install the abort-signal handler + + if State (System.Interrupt_Management.Abort_Task_Interrupt) + /= Default + then + act.sa_flags := 0; + act.sa_handler := Abort_Handler'Address; + + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction + (Signal (Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + end if; + end Initialize; + +begin + declare + Result : Interfaces.C.int; + + begin + -- Mask Environment task for all signals. The original mask of the + -- Environment task will be recovered by Interrupt_Server task + -- during the elaboration of s-interr.adb. + + System.Interrupt_Management.Operations.Set_Interrupt_Mask + (System.Interrupt_Management.Operations.All_Tasks_Mask'Access); + + -- Prepare the set of signals that should unblocked in all tasks + + Result := sigemptyset (Unblocked_Signal_Mask'Access); + pragma Assert (Result = 0); + + for J in Interrupt_Management.Interrupt_ID loop + if System.Interrupt_Management.Keep_Unmasked (J) then + Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0); + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0); + end; +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-lynxos.adb b/gcc/ada/s-taprop-lynxos.adb new file mode 100644 index 00000000000..6276d7f5092 --- /dev/null +++ b/gcc/ada/s-taprop-lynxos.adb @@ -0,0 +1,1184 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 a LynxOS version of this file, adapted to make +-- SCHED_FIFO and ceiling locking (Annex D compliance) work properly + +-- This package contains all the GNULL primitives that interface directly +-- with the underlying OS. + +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.Tasking.Debug; +-- used for Known_Tasks + +with System.Task_Info; +-- used for Task_Info_Type + +with Interfaces.C; +-- used for int +-- size_t + +with System.Interrupt_Management; +-- used for Keep_Unmasked +-- Abort_Task_Interrupt +-- Interrupt_ID + +with System.Interrupt_Management.Operations; +-- used for Set_Interrupt_Mask +-- All_Tasks_Mask +pragma Elaborate_All (System.Interrupt_Management.Operations); + +with System.Parameters; +-- used for Size_Type + +with System.Tasking; +-- used for Ada_Task_Control_Block +-- Task_ID + +with System.Soft_Links; +-- used for Defer/Undefer_Abort + +-- Note that we do not use System.Tasking.Initialization directly since +-- this is a higher level package that we shouldn't depend on. For example +-- when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Initialization + +with System.OS_Primitives; +-- used for Delay_Modes + +with Unchecked_Deallocation; + +package body System.Task_Primitives.Operations is + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + + package SSL renames System.Soft_Links; + + ---------------- + -- Local Data -- + ---------------- + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_ID associated with a thread + + Environment_Task_ID : Task_ID; + -- A variable to hold Task_ID for the environment task. + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + -- Value of the pragma Locking_Policy: + -- 'C' for Ceiling_Locking + -- 'I' for Inherit_Locking + -- ' ' for none. + + Unblocked_Signal_Mask : aliased sigset_t; + -- The set of signals that should unblocked in all tasks + + -- The followings are internal configuration constants needed. + + Next_Serial_Number : Task_Serial_Number := 100; + -- We start at 100, to reserve some special values for + -- using in error checking. + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; + -- Indicates whether FIFO_Within_Priorities is set. + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads). + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_ID); + pragma Inline (Initialize); + -- Initialize various data needed by this package. + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does the current thread have an ATCB? + + procedure Set (Self_Id : Task_ID); + pragma Inline (Set); + -- Set the self id for the current task. + + function Self return Task_ID; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task. + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific. + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; + -- Allocate and Initialize a new ATCB for the current Thread. + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_ID is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Abort_Handler (Sig : Signal); + -- Signal handler used to implement asynchronous abort. + + procedure Set_OS_Priority (T : Task_ID; Prio : System.Any_Priority); + -- This procedure calls the scheduler of the OS to set thread's priority + + ------------------- + -- Abort_Handler -- + ------------------- + + procedure Abort_Handler (Sig : Signal) is + pragma Unreferenced (Sig); + + T : constant Task_ID := Self; + Result : Interfaces.C.int; + Old_Set : aliased sigset_t; + + begin + -- It is not safe to raise an exception when using ZCX and the GCC + -- exception handling mechanism. + + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + + if T.Deferral_Level = 0 + and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then + not T.Aborting + then + T.Aborting := True; + + -- Make sure signals used for RTS internal purpose are unmasked + + Result := + pthread_sigmask (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, + Old_Set'Unchecked_Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + ----------------- + -- Stack_Guard -- + ----------------- + + procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread); + Guard_Page_Address : Address; + + Res : Interfaces.C.int; + + begin + if Stack_Base_Available then + + -- Compute the guard page address + + Guard_Page_Address := + Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size; + + if On then + Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_ON); + else + Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_OFF); + end if; + + pragma Assert (Res = 0); + end if; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID renames Specific.Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : access Lock) + is + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + L.Ceiling := Prio; + end if; + + Result := pthread_mutex_init (L.Mutex'Access, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L.Mutex'Access); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + Result : Interfaces.C.int; + T : constant Task_ID := Self; + + begin + if Locking_Policy = 'C' then + if T.Common.Current_Priority > L.Ceiling then + Ceiling_Violation := True; + return; + end if; + + L.Saved_Priority := T.Common.Current_Priority; + + if T.Common.Current_Priority < L.Ceiling then + Set_OS_Priority (T, L.Ceiling); + end if; + end if; + + Result := pthread_mutex_lock (L.Mutex'Access); + + -- Assume that the cause of EINVAL is a priority ceiling violation + + Ceiling_Violation := (Result = EINVAL); + pragma Assert (Result = 0 or else Result = EINVAL); + end Write_Lock; + + -- No tricks on RTS_Locks + + procedure Write_Lock + (L : access RTS_Lock; Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_ID) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : access Lock) is + Result : Interfaces.C.int; + T : constant Task_ID := Self; + + begin + Result := pthread_mutex_unlock (L.Mutex'Access); + pragma Assert (Result = 0); + + if Locking_Policy = 'C' then + if T.Common.Current_Priority > L.Saved_Priority then + Set_OS_Priority (T, L.Saved_Priority); + end if; + end if; + end Unlock; + + procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_ID) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_ID; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + + begin + if Single_Lock then + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + else + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + end if; + + -- EINTR is not considered a failure + + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is + -- assumed to be already deferred, and the caller should be + -- holding its own ATCB lock. + + procedure Timed_Sleep + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Check_Time : constant Duration := Monotonic_Clock; + Rel_Time : Duration; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + Timedout := True; + Yielded := False; + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time); + end if; + + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); + end if; + end if; + + if Abs_Time > Check_Time then + if Relative_Timed_Wait then + Request := To_Timespec (Rel_Time); + else + Request := To_Timespec (Abs_Time); + end if; + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + or else Self_ID.Pending_Priority_Change; + + if Single_Lock then + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, + Request'Access); + + else + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, + Request'Access); + end if; + + exit when Abs_Time <= Monotonic_Clock; + + if Result = 0 or Result = EINTR then + + -- Somebody may have called Wakeup for us + + Timedout := False; + exit; + end if; + + pragma Assert (Result = ETIMEDOUT); + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + -- This is for use in implementing delay statements, so we assume + -- the caller is abort-deferred but is holding no locks. + + procedure Timed_Delay + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes) + is + Check_Time : constant Duration := Monotonic_Clock; + Abs_Time : Duration; + Rel_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + -- Only the little window between deferring abort and + -- locking Self_ID is the reason we need to + -- check for pending abort and priority change below! + + SSL.Abort_Defer.all; + + if Single_Lock then + Lock_RTS; + end if; + + -- Comments needed in code below ??? + + Write_Lock (Self_ID); + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time); + end if; + + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); + end if; + end if; + + if Abs_Time > Check_Time then + if Relative_Timed_Wait then + Request := To_Timespec (Rel_Time); + else + Request := To_Timespec (Abs_Time); + end if; + + Self_ID.Common.State := Delay_Sleep; + + loop + if Self_ID.Pending_Priority_Change then + Self_ID.Pending_Priority_Change := False; + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + end if; + + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + if Single_Lock then + Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, Request'Access); + else + Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, Request'Access); + end if; + + exit when Abs_Time <= Monotonic_Clock; + + pragma Assert (Result = 0 + or else Result = ETIMEDOUT + or else Result = EINTR); + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Result := sched_yield; + SSL.Abort_Undefer.all; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; + begin + Result := clock_gettime + (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (TS); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + Res : aliased timespec; + Result : Interfaces.C.int; + begin + Result := clock_getres + (clock_id => CLOCK_REALTIME, Res => Res'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (Res); + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin + if Do_Yield then + Result := sched_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_OS_Priority (T : Task_ID; Prio : System.Any_Priority) is + Result : Interfaces.C.int; + Param : aliased struct_sched_param; + + begin + Param.sched_priority := Interfaces.C.int (Prio); + + if Time_Slice_Supported and then Time_Slice_Val > 0 then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); + + elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + + else + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + end if; + + pragma Assert (Result = 0); + end Set_OS_Priority; + + type Prio_Array_Type is array (System.Any_Priority) of Integer; + pragma Atomic_Components (Prio_Array_Type); + Prio_Array : Prio_Array_Type; + -- Comments needed for these declarations ??? + + procedure Set_Priority + (T : Task_ID; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + Array_Item : Integer; + + begin + Set_OS_Priority (T, Prio); + + if Locking_Policy = 'C' then + -- Annex D requirements: loss of inheritance puts task at the + -- beginning of the queue for that prio; copied from 5ztaprop + -- (VxWorks) + + if Loss_Of_Inheritance + and then Prio < T.Common.Current_Priority then + + Array_Item := Prio_Array (T.Common.Base_Priority) + 1; + Prio_Array (T.Common.Base_Priority) := Array_Item; + + loop + Yield; + exit when Array_Item = Prio_Array (T.Common.Base_Priority) + or else Prio_Array (T.Common.Base_Priority) = 1; + end loop; + + Prio_Array (T.Common.Base_Priority) := + Prio_Array (T.Common.Base_Priority) - 1; + end if; + end if; + + T.Common.Current_Priority := Prio; + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_ID) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_ID) is + begin + Self_ID.Common.LL.Thread := pthread_self; + Self_ID.Common.LL.LWP := lwp_self; + + Specific.Set (Self_ID); + + Lock_RTS; + + for J in Known_Tasks'Range loop + if Known_Tasks (J) = null then + Known_Tasks (J) := Self_ID; + Self_ID.Known_Tasks_Index := J; + exit; + end if; + end loop; + + Unlock_RTS; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + + ---------------------- + -- Initialize_TCB -- + ---------------------- + + procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + + begin + -- Give the task a unique serial number. + + Self_ID.Serial_Number := Next_Serial_Number; + Next_Serial_Number := Next_Serial_Number + 1; + pragma Assert (Next_Serial_Number /= 0); + + if not Single_Lock then + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, + Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, + Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + else + if not Single_Lock then + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_ID; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Attributes : aliased pthread_attr_t; + Adjusted_Stack_Size : Interfaces.C.size_t; + Result : Interfaces.C.int; + + use System.Task_Info; + + begin + if Stack_Size = Unspecified_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size); + + elsif Stack_Size < Minimum_Stack_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); + + else + Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); + end if; + + if Stack_Base_Available then + + -- If Stack Checking is supported then allocate 2 additional pages: + -- + -- In the worst case, stack is allocated at something like + -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages + -- to be sure the effective stack size is greater than what + -- has been asked. + + Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Get_Page_Size; + end if; + + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); + pragma Assert (Result = 0); + + Result := pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); + pragma Assert (Result = 0); + + if T.Common.Task_Info /= Default_Scope then + + -- We are assuming that Scope_Type has the same values than the + -- corresponding C macros + + Result := pthread_attr_setscope + (Attributes'Access, Task_Info_Type'Pos (T.Common.Task_Info)); + pragma Assert (Result = 0); + end if; + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + Result := pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + pragma Assert (Result = 0 or else Result = EAGAIN); + + Succeeded := Result = 0; + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + + Set_Priority (T, Priority); + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_ID) is + Result : Interfaces.C.int; + Tmp : Task_ID := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); + + begin + if not Single_Lock then + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + + if Is_Self then + Result := st_setspecific (ATCB_Key, System.Null_Address); + pragma Assert (Result = 0); + end if; + + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_ID) is + Result : Interfaces.C.int; + begin + Result := pthread_kill (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + end Abort_Task; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy versions + + function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_ID is + begin + return Environment_Task_ID; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) + return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + begin + return False; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + begin + return False; + end Resume_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + + function State + (Int : System.Interrupt_Management.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: + + 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 + Environment_Task_ID := Environment_Task; + + -- Initialize the lock used to synchronize chain of all ATCBs. + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Specific.Initialize (Environment_Task); + + Enter_Task (Environment_Task); + + -- Install the abort-signal handler + + if State (System.Interrupt_Management.Abort_Task_Interrupt) + /= Default + then + act.sa_flags := 0; + act.sa_handler := Abort_Handler'Address; + + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction + (Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + + pragma Assert (Result = 0); + end if; + end Initialize; + +begin + declare + Result : Interfaces.C.int; + + begin + -- Mask Environment task for all signals. The original mask of the + -- Environment task will be recovered by Interrupt_Server task + -- during the elaboration of s-interr.adb. + + System.Interrupt_Management.Operations.Set_Interrupt_Mask + (System.Interrupt_Management.Operations.All_Tasks_Mask'Access); + + -- Prepare the set of signals that should unblocked in all tasks + + Result := sigemptyset (Unblocked_Signal_Mask'Access); + pragma Assert (Result = 0); + + for J in Interrupt_Management.Interrupt_ID loop + if System.Interrupt_Management.Keep_Unmasked (J) then + Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + end; +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb new file mode 100644 index 00000000000..1e24de0c6ec --- /dev/null +++ b/gcc/ada/s-taprop-mingw.adb @@ -0,0 +1,1106 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 a NT (native) version of this package + +-- This package contains all the GNULL primitives that interface directly +-- with the underlying OS. + +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.Tasking.Debug; +-- used for Known_Tasks + +with Interfaces.C; +-- used for int +-- size_t + +with Interfaces.C.Strings; +-- used for Null_Ptr + +with System.OS_Interface; +-- used for various type, constant, and operations + +with System.Parameters; +-- used for Size_Type + +with System.Tasking; +-- used for Ada_Task_Control_Block +-- Task_ID + +with System.Soft_Links; +-- used for Defer/Undefer_Abort +-- to initialize TSD for a C thread, in function Self + +-- Note that we do not use System.Tasking.Initialization directly since +-- this is a higher level package that we shouldn't depend on. For example +-- when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Initialization + +with System.OS_Primitives; +-- used for Delay_Modes + +with System.Task_Info; +-- used for Unspecified_Task_Info + +with Unchecked_Deallocation; + +package body System.Task_Primitives.Operations is + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use Interfaces.C.Strings; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + + pragma Link_With ("-Xlinker --stack=0x800000,0x1000"); + -- Change the stack size (8 MB) for tasking programs on Windows. This + -- permit to have more than 30 tasks running at the same time. Note that + -- we set the stack size for non tasking programs on System unit. + + package SSL renames System.Soft_Links; + + ---------------- + -- Local Data -- + ---------------- + + Environment_Task_ID : Task_ID; + -- A variable to hold Task_ID for the environment task. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; + -- Indicates whether FIFO_Within_Priorities is set. + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads). + + ------------------------------------ + -- The thread local storage index -- + ------------------------------------ + + TlsIndex : DWORD; + pragma Export (Ada, TlsIndex); + -- To ensure that this variable won't be local to this package, since + -- in some cases, inlining forces this variable to be global anyway. + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_ID); + pragma Inline (Set); + -- Set the self id for the current task. + + end Specific; + + package body Specific is + + function Is_Valid_Task return Boolean is + begin + return TlsGetValue (TlsIndex) /= System.Null_Address; + end Is_Valid_Task; + + procedure Set (Self_Id : Task_ID) is + Succeeded : BOOL; + begin + Succeeded := TlsSetValue (TlsIndex, To_Address (Self_Id)); + pragma Assert (Succeeded = True); + end Set; + + end Specific; + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; + -- Allocate and Initialize a new ATCB for the current Thread. + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_ID is separate; + + ---------------------------------- + -- Condition Variable Functions -- + ---------------------------------- + + procedure Initialize_Cond (Cond : access Condition_Variable); + -- Initialize given condition variable Cond + + procedure Finalize_Cond (Cond : access Condition_Variable); + -- Finalize given condition variable Cond. + + procedure Cond_Signal (Cond : access Condition_Variable); + -- Signal condition variable Cond + + procedure Cond_Wait + (Cond : access Condition_Variable; + L : access RTS_Lock); + -- Wait on conditional variable Cond, using lock L + + procedure Cond_Timed_Wait + (Cond : access Condition_Variable; + L : access RTS_Lock; + Rel_Time : Duration; + Timed_Out : out Boolean; + Status : out Integer); + -- Do timed wait on condition variable Cond using lock L. The duration + -- of the timed wait is given by Rel_Time. When the condition is + -- signalled, Timed_Out shows whether or not a time out occurred. + -- Status is only valid if Timed_Out is False, in which case it + -- shows whether Cond_Timed_Wait completed successfully. + + --------------------- + -- Initialize_Cond -- + --------------------- + + procedure Initialize_Cond (Cond : access Condition_Variable) is + hEvent : HANDLE; + + begin + hEvent := CreateEvent (null, True, False, Null_Ptr); + pragma Assert (hEvent /= 0); + Cond.all := Condition_Variable (hEvent); + end Initialize_Cond; + + ------------------- + -- Finalize_Cond -- + ------------------- + + -- No such problem here, DosCloseEventSem has been derived. + -- What does such refer to in above comment??? + + procedure Finalize_Cond (Cond : access Condition_Variable) is + Result : BOOL; + begin + Result := CloseHandle (HANDLE (Cond.all)); + pragma Assert (Result = True); + end Finalize_Cond; + + ----------------- + -- Cond_Signal -- + ----------------- + + procedure Cond_Signal (Cond : access Condition_Variable) is + Result : BOOL; + begin + Result := SetEvent (HANDLE (Cond.all)); + pragma Assert (Result = True); + end Cond_Signal; + + --------------- + -- Cond_Wait -- + --------------- + + -- Pre-assertion: Cond is posted + -- L is locked. + + -- Post-assertion: Cond is posted + -- L is locked. + + procedure Cond_Wait + (Cond : access Condition_Variable; + L : access RTS_Lock) + is + Result : DWORD; + Result_Bool : BOOL; + + begin + -- Must reset Cond BEFORE L is unlocked. + + Result_Bool := ResetEvent (HANDLE (Cond.all)); + pragma Assert (Result_Bool = True); + Unlock (L); + + -- No problem if we are interrupted here: if the condition is signaled, + -- WaitForSingleObject will simply not block + + Result := WaitForSingleObject (HANDLE (Cond.all), Wait_Infinite); + pragma Assert (Result = 0); + + Write_Lock (L); + end Cond_Wait; + + --------------------- + -- Cond_Timed_Wait -- + --------------------- + + -- Pre-assertion: Cond is posted + -- L is locked. + + -- Post-assertion: Cond is posted + -- L is locked. + + procedure Cond_Timed_Wait + (Cond : access Condition_Variable; + L : access RTS_Lock; + Rel_Time : Duration; + Timed_Out : out Boolean; + Status : out Integer) + is + Time_Out_Max : constant DWORD := 16#FFFF0000#; + -- NT 4 cannot handle timeout values that are too large, + -- e.g. DWORD'Last - 1 + + Time_Out : DWORD; + Result : BOOL; + Wait_Result : DWORD; + + begin + -- Must reset Cond BEFORE L is unlocked. + + Result := ResetEvent (HANDLE (Cond.all)); + pragma Assert (Result = True); + Unlock (L); + + -- No problem if we are interrupted here: if the condition is signaled, + -- WaitForSingleObject will simply not block + + if Rel_Time <= 0.0 then + Timed_Out := True; + Wait_Result := 0; + + else + if Rel_Time >= Duration (Time_Out_Max) / 1000 then + Time_Out := Time_Out_Max; + else + Time_Out := DWORD (Rel_Time * 1000); + end if; + + Wait_Result := WaitForSingleObject (HANDLE (Cond.all), Time_Out); + + if Wait_Result = WAIT_TIMEOUT then + Timed_Out := True; + Wait_Result := 0; + else + Timed_Out := False; + end if; + end if; + + Write_Lock (L); + + -- Ensure post-condition + + if Timed_Out then + Result := SetEvent (HANDLE (Cond.all)); + pragma Assert (Result = True); + end if; + + Status := Integer (Wait_Result); + end Cond_Timed_Wait; + + ------------------ + -- Stack_Guard -- + ------------------ + + -- The underlying thread system sets a guard page at the + -- bottom of a thread stack, so nothing is needed. + -- ??? Check the comment above + + procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Warnings (Off, T); + pragma Warnings (Off, On); + + begin + null; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID is + Self_Id : constant Task_ID := To_Task_ID (TlsGetValue (TlsIndex)); + begin + if Self_Id = null then + return Register_Foreign_Thread (GetCurrentThread); + else + return Self_Id; + end if; + end Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are + -- initialized in Intialize_TCB and the Storage_Error is handled. + -- Other mutexes (such as RTS_Lock, Memory_Lock...) used in + -- the RTS is initialized before any status change of RTS. + -- Therefore raising Storage_Error in the following routines + -- should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : access Lock) + is + begin + InitializeCriticalSection (L.Mutex'Access); + L.Owner_Priority := 0; + L.Priority := Prio; + end Initialize_Lock; + + procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + + begin + InitializeCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : access Lock) is + begin + DeleteCriticalSection (L.Mutex'Access); + end Finalize_Lock; + + procedure Finalize_Lock (L : access RTS_Lock) is + begin + DeleteCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + begin + L.Owner_Priority := Get_Priority (Self); + + if L.Priority < L.Owner_Priority then + Ceiling_Violation := True; + return; + end if; + + EnterCriticalSection (L.Mutex'Access); + + Ceiling_Violation := False; + end Write_Lock; + + procedure Write_Lock + (L : access RTS_Lock; + Global_Lock : Boolean := False) + is + begin + if not Single_Lock or else Global_Lock then + EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_ID) is + begin + if not Single_Lock then + EnterCriticalSection + (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : access Lock) is + begin + LeaveCriticalSection (L.Mutex'Access); + end Unlock; + + procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is + begin + if not Single_Lock or else Global_Lock then + LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access); + end if; + end Unlock; + + procedure Unlock (T : Task_ID) is + begin + if not Single_Lock then + LeaveCriticalSection + (CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access); + end if; + end Unlock; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_ID; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + + begin + pragma Assert (Self_ID = Self); + + if Single_Lock then + Cond_Wait (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + else + Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + end if; + + if Self_ID.Deferral_Level = 0 + and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + then + Unlock (Self_ID); + raise Standard'Abort_Signal; + end if; + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is + -- assumed to be already deferred, and the caller should be + -- holding its own ATCB lock. + + procedure Timed_Sleep + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + Check_Time : Duration := Monotonic_Clock; + Rel_Time : Duration; + Abs_Time : Duration; + Result : Integer; + + Local_Timedout : Boolean; + + begin + Timedout := True; + Yielded := False; + + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + or else Self_ID.Pending_Priority_Change; + + if Single_Lock then + Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, Rel_Time, Local_Timedout, Result); + else + Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result); + end if; + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time; + + if not Local_Timedout then + + -- Somebody may have called Wakeup for us + + Timedout := False; + exit; + end if; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes) + is + Check_Time : Duration := Monotonic_Clock; + Rel_Time : Duration; + Abs_Time : Duration; + Result : Integer; + Timedout : Boolean; + + begin + -- Only the little window between deferring abort and + -- locking Self_ID is the reason we need to + -- check for pending abort and priority change below! + + SSL.Abort_Defer.all; + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + 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 + Self_ID.Common.State := Delay_Sleep; + + loop + if Self_ID.Pending_Priority_Change then + Self_ID.Pending_Priority_Change := False; + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + end if; + + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + if Single_Lock then + Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, Rel_Time, Timedout, Result); + else + Cond_Timed_Wait (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result); + end if; + + Check_Time := Monotonic_Clock; + exit when Abs_Time <= Check_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Yield; + SSL.Abort_Undefer.all; + end Timed_Delay; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + + begin + Cond_Signal (T.Common.LL.CV'Access); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + begin + if Do_Yield then + Sleep (0); + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + type Prio_Array_Type is array (System.Any_Priority) of Integer; + pragma Atomic_Components (Prio_Array_Type); + + Prio_Array : Prio_Array_Type; + -- Global array containing the id of the currently running task for + -- each priority. + -- + -- Note: we assume that we are on a single processor with run-til-blocked + -- scheduling. + + procedure Set_Priority + (T : Task_ID; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + Res : BOOL; + Array_Item : Integer; + + begin + Res := SetThreadPriority + (T.Common.LL.Thread, Interfaces.C.int (Underlying_Priorities (Prio))); + pragma Assert (Res = True); + + if FIFO_Within_Priorities then + + -- Annex D requirement [RM D.2.2 par. 9]: + -- If the task drops its priority due to the loss of inherited + -- priority, it is added at the head of the ready queue for its + -- new active priority. + + if Loss_Of_Inheritance + and then Prio < T.Common.Current_Priority + then + Array_Item := Prio_Array (T.Common.Base_Priority) + 1; + Prio_Array (T.Common.Base_Priority) := Array_Item; + + loop + -- Let some processes a chance to arrive + + Yield; + + -- Then wait for our turn to proceed + + exit when Array_Item = Prio_Array (T.Common.Base_Priority) + or else Prio_Array (T.Common.Base_Priority) = 1; + end loop; + + Prio_Array (T.Common.Base_Priority) := + Prio_Array (T.Common.Base_Priority) - 1; + end if; + end if; + + T.Common.Current_Priority := Prio; + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_ID) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + -- There were two paths were we needed to call Enter_Task : + -- 1) from System.Task_Primitives.Operations.Initialize + -- 2) from System.Tasking.Stages.Task_Wrapper + -- + -- The thread initialisation has to be done only for the first case. + -- + -- This is because the GetCurrentThread NT call does not return the + -- real thread handler but only a "pseudo" one. It is not possible to + -- release the thread handle and free the system ressources from this + -- "pseudo" handle. So we really want to keep the real thread handle + -- set in System.Task_Primitives.Operations.Create_Task during the + -- thread creation. + + procedure Enter_Task (Self_ID : Task_ID) is + procedure Init_Float; + pragma Import (C, Init_Float, "__gnat_init_float"); + -- Properly initializes the FPU for x86 systems. + + begin + Specific.Set (Self_ID); + Init_Float; + + Self_ID.Common.LL.Thread_Id := GetCurrentThreadId; + + Lock_RTS; + + for J in Known_Tasks'Range loop + if Known_Tasks (J) = null then + Known_Tasks (J) := Self_ID; + Self_ID.Known_Tasks_Index := J; + exit; + end if; + end loop; + + Unlock_RTS; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (GetCurrentThread); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is + begin + -- Initialize thread ID to 0, this is needed to detect threads that + -- are not yet activated. + + Self_ID.Common.LL.Thread := 0; + + Initialize_Cond (Self_ID.Common.LL.CV'Access); + + if not Single_Lock then + Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); + end if; + + Succeeded := True; + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_ID; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + hTask : HANDLE; + TaskId : aliased DWORD; + pTaskParameter : System.OS_Interface.PVOID; + dwStackSize : DWORD; + Result : DWORD; + Entry_Point : PTHREAD_START_ROUTINE; + + begin + pTaskParameter := To_Address (T); + + if Stack_Size = Unspecified_Size then + dwStackSize := DWORD (Default_Stack_Size); + + elsif Stack_Size < Minimum_Stack_Size then + dwStackSize := DWORD (Minimum_Stack_Size); + + else + dwStackSize := DWORD (Stack_Size); + end if; + + Entry_Point := To_PTHREAD_START_ROUTINE (Wrapper); + + hTask := CreateThread + (null, + dwStackSize, + Entry_Point, + pTaskParameter, + DWORD (Create_Suspended), + TaskId'Unchecked_Access); + + -- Step 1: Create the thread in blocked mode + + if hTask = 0 then + raise Storage_Error; + end if; + + -- Step 2: set its TCB + + T.Common.LL.Thread := hTask; + + -- Step 3: set its priority (child has inherited priority from parent) + + Set_Priority (T, Priority); + + if Time_Slice_Val = 0 or else FIFO_Within_Priorities then + -- Here we need Annex E semantics so we disable the NT priority + -- boost. A priority boost is temporarily given by the system to a + -- thread when it is taken out of a wait state. + + SetThreadPriorityBoost (hTask, DisablePriorityBoost => True); + end if; + + -- Step 4: Now, start it for good: + + Result := ResumeThread (hTask); + pragma Assert (Result = 1); + + Succeeded := Result = 1; + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_ID) is + Self_ID : Task_ID := T; + Result : DWORD; + Succeeded : BOOL; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); + + begin + if not Single_Lock then + Finalize_Lock (T.Common.LL.L'Access); + end if; + + Finalize_Cond (T.Common.LL.CV'Access); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + if Self_ID.Common.LL.Thread /= 0 then + + -- This task has been activated. Wait for the thread to terminate + -- then close it. this is needed to release system ressources. + + Result := WaitForSingleObject (T.Common.LL.Thread, Wait_Infinite); + pragma Assert (Result /= WAIT_FAILED); + Succeeded := CloseHandle (T.Common.LL.Thread); + pragma Assert (Succeeded = True); + end if; + + Free (Self_ID); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_ID) is + pragma Unreferenced (T); + begin + null; + end Abort_Task; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_ID is + begin + return Environment_Task_ID; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + Discard : BOOL; + pragma Unreferenced (Discard); + + begin + Environment_Task_ID := Environment_Task; + + if Time_Slice_Val = 0 or else FIFO_Within_Priorities then + + -- Here we need Annex E semantics, switch the current process to the + -- High_Priority_Class. + + Discard := + OS_Interface.SetPriorityClass + (GetCurrentProcess, High_Priority_Class); + + -- ??? In theory it should be possible to use the priority class + -- Realtime_Prioriry_Class but we suspect a bug in the NT scheduler + -- which prevents (in some obscure cases) a thread to get on top of + -- the running queue by another thread of lower priority. For + -- example cxd8002 ACATS test freeze. + end if; + + TlsIndex := TlsAlloc; + + -- Initialize the lock used to synchronize chain of all ATCBs. + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Environment_Task.Common.LL.Thread := GetCurrentThread; + Enter_Task (Environment_Task); + end Initialize; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration + renames System.OS_Primitives.Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 0.000_001; -- 1 micro-second + end RT_Resolution; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy versions. The only currently working versions is for solaris + -- (native). + + function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + + begin + return True; + end Check_No_Locks; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= Thread_Self then + return SuspendThread (T.Common.LL.Thread) = NO_ERROR; + else + return True; + end if; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= Thread_Self then + return ResumeThread (T.Common.LL.Thread) = NO_ERROR; + else + return True; + end if; + end Resume_Task; + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-os2.adb b/gcc/ada/s-taprop-os2.adb new file mode 100644 index 00000000000..924f477bb67 --- /dev/null +++ b/gcc/ada/s-taprop-os2.adb @@ -0,0 +1,1157 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . O P E R A T I O N S -- +-- -- +-- 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 an OS/2 version of this package + +-- This package contains all the GNULL primitives that interface directly +-- with the underlying OS. + +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.Tasking.Debug; +-- used for Known_Tasks + +with Interfaces.C; +-- used for size_t + +with Interfaces.C.Strings; +-- used for Null_Ptr + +with Interfaces.OS2Lib.Errors; +with Interfaces.OS2Lib.Threads; +with Interfaces.OS2Lib.Synchronization; + +with System.Parameters; +-- used for Size_Type + +with System.Tasking; +-- used for Task_ID + +with System.Parameters; +-- used for Size_Type + +with System.Soft_Links; +-- used for Defer/Undefer_Abort + +-- Note that we do not use System.Tasking.Initialization directly since +-- this is a higher level package that we shouldn't depend on. For example +-- when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Initialization + +with System.OS_Primitives; +-- used for Delay_Modes +-- Clock + +with Unchecked_Conversion; +with Unchecked_Deallocation; + +package body System.Task_Primitives.Operations is + + package IC renames Interfaces.C; + package ICS renames Interfaces.C.Strings; + package OSP renames System.OS_Primitives; + package SSL renames System.Soft_Links; + + use Interfaces.OS2Lib; + use Interfaces.OS2Lib.Errors; + use Interfaces.OS2Lib.Threads; + use Interfaces.OS2Lib.Synchronization; + use System.Parameters; + use System.Tasking.Debug; + use System.Tasking; + use System.OS_Interface; + use Interfaces.C; + use System.OS_Primitives; + + --------------------- + -- Local Constants -- + --------------------- + + Max_Locks_Per_Task : constant := 100; + Suppress_Owner_Check : constant Boolean := False; + + ----------------- + -- Local Types -- + ----------------- + + subtype Lock_Range is Integer range 0 .. Max_Locks_Per_Task; + + ----------------- + -- Local Data -- + ----------------- + + -- The OS/2 DosAllocThreadLocalMemory API is used to allocate our TCB_Ptr. + + -- This API reserves a small range of virtual addresses that is backed + -- by different physical memory for each running thread. In this case we + -- create a pointer at a fixed address that points to the TCB_Ptr for the + -- running thread. So all threads will be able to query and update their + -- own TCB_Ptr without destroying the TCB_Ptr of other threads. + + type Thread_Local_Data is record + Self_ID : Task_ID; -- ID of the current thread + Lock_Prio_Level : Lock_Range; -- Nr of priority changes due to locks + + -- ... room for expansion here, if we decide to make access to + -- jump-buffer and exception stack more efficient in future + end record; + + type Access_Thread_Local_Data is access all Thread_Local_Data; + + -- Pointer to Thread Local Data + Thread_Local_Data_Ptr : aliased Access_Thread_Local_Data; + + type PPTLD is access all Access_Thread_Local_Data; + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + Environment_Task_ID : Task_ID; + -- A variable to hold Task_ID for the environment task. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function To_PPVOID is new Unchecked_Conversion (PPTLD, PPVOID); + function To_Address is new Unchecked_Conversion (Task_ID, System.Address); + function To_PFNTHREAD is + new Unchecked_Conversion (System.Address, PFNTHREAD); + + function To_MS (D : Duration) return ULONG; + + procedure Set_Temporary_Priority + (T : in Task_ID; + New_Priority : in System.Any_Priority); + + ----------- + -- To_MS -- + ----------- + + function To_MS (D : Duration) return ULONG is + begin + return ULONG (D * 1_000); + end To_MS; + + ----------- + -- Clock -- + ----------- + + function Monotonic_Clock return Duration renames OSP.Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 10#1.0#E-6; + end RT_Resolution; + + ------------------- + -- Abort_Handler -- + ------------------- + + -- OS/2 only has limited support for asynchronous signals. + -- It seems not to be possible to jump out of an exception + -- handler or to change the execution context of the thread. + -- So asynchonous transfer of control is not supported. + + ----------------- + -- Stack_Guard -- + ----------------- + + -- The underlying thread system sets a guard page at the + -- bottom of a thread stack, so nothing is needed. + -- ??? Check the comment above + + procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Unreferenced (T); + pragma Unreferenced (On); + + begin + null; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is + begin + return OSI.Thread_Id (T.Common.LL.Thread); + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID is + Self_ID : Task_ID renames Thread_Local_Data_Ptr.Self_ID; + begin + -- Check that the thread local data has been initialized. + + pragma Assert + ((Thread_Local_Data_Ptr /= null + and then Thread_Local_Data_Ptr.Self_ID /= null)); + + return Self_ID; + end Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : access Lock) + is + begin + if DosCreateMutexSem + (ICS.Null_Ptr, L.Mutex'Unchecked_Access, 0, False32) /= NO_ERROR + then + raise Storage_Error; + end if; + + pragma Assert (L.Mutex /= 0, "Error creating Mutex"); + L.Priority := Prio; + L.Owner_ID := Null_Address; + end Initialize_Lock; + + procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + + begin + if DosCreateMutexSem + (ICS.Null_Ptr, L.Mutex'Unchecked_Access, 0, False32) /= NO_ERROR + then + raise Storage_Error; + end if; + + pragma Assert (L.Mutex /= 0, "Error creating Mutex"); + + L.Priority := System.Any_Priority'Last; + L.Owner_ID := Null_Address; + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : access Lock) is + begin + Must_Not_Fail (DosCloseMutexSem (L.Mutex)); + end Finalize_Lock; + + procedure Finalize_Lock (L : access RTS_Lock) is + begin + Must_Not_Fail (DosCloseMutexSem (L.Mutex)); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID; + Old_Priority : constant Any_Priority := + Self_ID.Common.LL.Current_Priority; + + begin + if L.Priority < Old_Priority then + Ceiling_Violation := True; + return; + end if; + + Ceiling_Violation := False; + + -- Increase priority before getting the lock + -- to prevent priority inversion + + Thread_Local_Data_Ptr.Lock_Prio_Level := + Thread_Local_Data_Ptr.Lock_Prio_Level + 1; + if L.Priority > Old_Priority then + Set_Temporary_Priority (Self_ID, L.Priority); + end if; + + -- Request the lock and then update the lock owner data + + Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT)); + L.Owner_Priority := Old_Priority; + L.Owner_ID := Self_ID.all'Address; + end Write_Lock; + + procedure Write_Lock + (L : access RTS_Lock; + Global_Lock : Boolean := False) + is + Self_ID : Task_ID; + Old_Priority : Any_Priority; + + begin + if not Single_Lock or else Global_Lock then + Self_ID := Thread_Local_Data_Ptr.Self_ID; + Old_Priority := Self_ID.Common.LL.Current_Priority; + + -- Increase priority before getting the lock + -- to prevent priority inversion + + Thread_Local_Data_Ptr.Lock_Prio_Level := + Thread_Local_Data_Ptr.Lock_Prio_Level + 1; + + if L.Priority > Old_Priority then + Set_Temporary_Priority (Self_ID, L.Priority); + end if; + + -- Request the lock and then update the lock owner data + + Must_Not_Fail (DosRequestMutexSem (L.Mutex, SEM_INDEFINITE_WAIT)); + L.Owner_Priority := Old_Priority; + L.Owner_ID := Self_ID.all'Address; + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_ID) is + begin + if not Single_Lock then + + -- Request the lock and then update the lock owner data + + Must_Not_Fail + (DosRequestMutexSem (T.Common.LL.L.Mutex, SEM_INDEFINITE_WAIT)); + T.Common.LL.L.Owner_ID := Null_Address; + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock + (L : access Lock; Ceiling_Violation : out Boolean) renames Write_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : access Lock) is + Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID; + Old_Priority : constant Any_Priority := L.Owner_Priority; + + begin + -- Check that this task holds the lock + + pragma Assert (Suppress_Owner_Check + or else L.Owner_ID = Self_ID.all'Address); + + -- Upate the owner data + + L.Owner_ID := Null_Address; + + -- Do the actual unlocking. No more references + -- to owner data of L after this point. + + Must_Not_Fail (DosReleaseMutexSem (L.Mutex)); + + -- Reset priority after unlocking to avoid priority inversion + + Thread_Local_Data_Ptr.Lock_Prio_Level := + Thread_Local_Data_Ptr.Lock_Prio_Level - 1; + if L.Priority /= Old_Priority then + Set_Temporary_Priority (Self_ID, Old_Priority); + end if; + end Unlock; + + procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is + Self_ID : Task_ID; + Old_Priority : Any_Priority; + + begin + if not Single_Lock or else Global_Lock then + Self_ID := Thread_Local_Data_Ptr.Self_ID; + Old_Priority := L.Owner_Priority; + -- Check that this task holds the lock + + pragma Assert (Suppress_Owner_Check + or else L.Owner_ID = Self_ID.all'Address); + + -- Upate the owner data + + L.Owner_ID := Null_Address; + + -- Do the actual unlocking. No more references + -- to owner data of L after this point. + + Must_Not_Fail (DosReleaseMutexSem (L.Mutex)); + + -- Reset priority after unlocking to avoid priority inversion + + Thread_Local_Data_Ptr.Lock_Prio_Level := + Thread_Local_Data_Ptr.Lock_Prio_Level - 1; + + if L.Priority /= Old_Priority then + Set_Temporary_Priority (Self_ID, Old_Priority); + end if; + end if; + end Unlock; + + procedure Unlock (T : Task_ID) is + begin + if not Single_Lock then + + -- Check the owner data + + pragma Assert (Suppress_Owner_Check + or else T.Common.LL.L.Owner_ID = Null_Address); + + -- Do the actual unlocking. No more references + -- to owner data of T.Common.LL.L after this point. + + Must_Not_Fail (DosReleaseMutexSem (T.Common.LL.L.Mutex)); + end if; + end Unlock; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_ID; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + + Count : aliased ULONG; -- Used to store dummy result + + begin + -- Must reset Cond BEFORE L is unlocked. + + Sem_Must_Not_Fail + (DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access)); + + if Single_Lock then + Unlock_RTS; + else + Unlock (Self_ID); + end if; + + -- No problem if we are interrupted here. + -- If the condition is signaled, DosWaitEventSem will simply not block. + + Sem_Must_Not_Fail + (DosWaitEventSem (Self_ID.Common.LL.CV, SEM_INDEFINITE_WAIT)); + + -- Since L was previously accquired, lock operation should not fail. + + if Single_Lock then + Lock_RTS; + else + Write_Lock (Self_ID); + end if; + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is + -- assumed to be already deferred, and the caller should be + -- holding its own ATCB lock. + + -- Pre-assertion: Cond is posted + -- Self is locked. + + -- Post-assertion: Cond is posted + -- Self is locked. + + procedure Timed_Sleep + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Check_Time : constant Duration := OSP.Monotonic_Clock; + Rel_Time : Duration; + Abs_Time : Duration; + Time_Out : ULONG; + Result : APIRET; + Count : aliased ULONG; -- Used to store dummy result + + begin + -- Must reset Cond BEFORE Self_ID is unlocked. + + Sem_Must_Not_Fail + (DosResetEventSem (Self_ID.Common.LL.CV, + Count'Unchecked_Access)); + + if Single_Lock then + Unlock_RTS; + else + Unlock (Self_ID); + end if; + + Timedout := True; + Yielded := False; + + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + or else Self_ID.Pending_Priority_Change; + + Time_Out := To_MS (Rel_Time); + Result := DosWaitEventSem (Self_ID.Common.LL.CV, Time_Out); + pragma Assert + ((Result = NO_ERROR or Result = ERROR_TIMEOUT + or Result = ERROR_INTERRUPT)); + + -- ??? + -- What to do with error condition ERROR_NOT_ENOUGH_MEMORY? Can + -- we raise an exception here? And what about ERROR_INTERRUPT? + -- Should that be treated as a simple timeout? + -- For now, consider only ERROR_TIMEOUT to be a timeout. + + exit when Abs_Time <= OSP.Monotonic_Clock; + + if Result /= ERROR_TIMEOUT then + -- somebody may have called Wakeup for us + Timedout := False; + exit; + end if; + + Rel_Time := Abs_Time - OSP.Monotonic_Clock; + end loop; + end if; + + -- Ensure post-condition + + if Single_Lock then + Lock_RTS; + else + Write_Lock (Self_ID); + end if; + + if Timedout then + Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV)); + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes) + is + Check_Time : constant Duration := OSP.Monotonic_Clock; + Rel_Time : Duration; + Abs_Time : Duration; + Timedout : Boolean := True; + Time_Out : ULONG; + Result : APIRET; + Count : aliased ULONG; -- Used to store dummy result + + begin + -- Only the little window between deferring abort and + -- locking Self_ID is the reason we need to + -- check for pending abort and priority change below! :( + + SSL.Abort_Defer.all; + + if Single_Lock then + Lock_RTS; + else + Write_Lock (Self_ID); + end if; + + -- Must reset Cond BEFORE Self_ID is unlocked. + + Sem_Must_Not_Fail + (DosResetEventSem (Self_ID.Common.LL.CV, + Count'Unchecked_Access)); + + if Single_Lock then + Unlock_RTS; + else + Unlock (Self_ID); + end if; + + 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 + Self_ID.Common.State := Delay_Sleep; + + loop + if Self_ID.Pending_Priority_Change then + Self_ID.Pending_Priority_Change := False; + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + end if; + + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + Time_Out := To_MS (Rel_Time); + Result := DosWaitEventSem (Self_ID.Common.LL.CV, Time_Out); + + exit when Abs_Time <= OSP.Monotonic_Clock; + + Rel_Time := Abs_Time - OSP.Monotonic_Clock; + end loop; + + Self_ID.Common.State := Runnable; + Timedout := Result = ERROR_TIMEOUT; + end if; + + if Single_Lock then + Lock_RTS; + else + Write_Lock (Self_ID); + end if; + + if Timedout then + Sem_Must_Not_Fail (DosPostEventSem (Self_ID.Common.LL.CV)); + end if; + + if Single_Lock then + Unlock_RTS; + else + Unlock (Self_ID); + end if; + + System.OS_Interface.Yield; + SSL.Abort_Undefer.all; + end Timed_Delay; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + + begin + Sem_Must_Not_Fail (DosPostEventSem (T.Common.LL.CV)); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + begin + if Do_Yield then + System.OS_Interface.Yield; + end if; + end Yield; + + ---------------------------- + -- Set_Temporary_Priority -- + ---------------------------- + + procedure Set_Temporary_Priority + (T : Task_ID; + New_Priority : System.Any_Priority) + is + use Interfaces.C; + Delta_Priority : Integer; + + begin + -- When Lock_Prio_Level = 0, we always need to set the + -- Active_Priority. In this way we can make priority changes + -- due to locking independent of those caused by calling + -- Set_Priority. + + if Thread_Local_Data_Ptr.Lock_Prio_Level = 0 + or else New_Priority < T.Common.Current_Priority + then + Delta_Priority := T.Common.Current_Priority - + T.Common.LL.Current_Priority; + else + Delta_Priority := New_Priority - T.Common.LL.Current_Priority; + end if; + + if Delta_Priority /= 0 then + -- ??? There is a race-condition here + -- The TCB is updated before the system call to make + -- pre-emption in the critical section less likely. + + T.Common.LL.Current_Priority := + T.Common.LL.Current_Priority + Delta_Priority; + Must_Not_Fail + (DosSetPriority (Scope => PRTYS_THREAD, + Class => PRTYC_NOCHANGE, + Delta_P => IC.long (Delta_Priority), + PorTid => T.Common.LL.Thread)); + end if; + end Set_Temporary_Priority; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_ID; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + pragma Unreferenced (Loss_Of_Inheritance); + + begin + T.Common.Current_Priority := Prio; + Set_Temporary_Priority (T, Prio); + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_ID) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_ID) is + begin + -- Initialize thread local data. Must be done first. + + Thread_Local_Data_Ptr.Self_ID := Self_ID; + Thread_Local_Data_Ptr.Lock_Prio_Level := 0; + + Lock_RTS; + + for J in Known_Tasks'Range loop + if Known_Tasks (J) = null then + Known_Tasks (J) := Self_ID; + Self_ID.Known_Tasks_Index := J; + exit; + end if; + end loop; + + Unlock_RTS; + + -- For OS/2, we can set Self_ID.Common.LL.Thread in + -- Create_Task, since the thread is created suspended. + -- That is, there is no danger of the thread racing ahead + -- and trying to reference Self_ID.Common.LL.Thread before it + -- has been initialized. + + -- .... Do we need to do anything with signals for OS/2 ??? + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + begin + return False; + end Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + return null; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is + begin + if DosCreateEventSem (ICS.Null_Ptr, + Self_ID.Common.LL.CV'Unchecked_Access, 0, True32) = NO_ERROR + then + if not Single_Lock + and then DosCreateMutexSem + (ICS.Null_Ptr, + Self_ID.Common.LL.L.Mutex'Unchecked_Access, + 0, + False32) /= NO_ERROR + then + Succeeded := False; + Must_Not_Fail (DosCloseEventSem (Self_ID.Common.LL.CV)); + else + Succeeded := True; + end if; + + -- We now want to do the equivalent of: + + -- Initialize_Lock + -- (Self_ID.Common.LL.L'Unchecked_Access, ATCB_Level); + + -- But we avoid that because the Initialize_TCB routine has an + -- exception handler, and it is too early for us to deal with + -- installing handlers (see comment below), so we do our own + -- Initialize_Lock operation manually. + + Self_ID.Common.LL.L.Priority := System.Any_Priority'Last; + Self_ID.Common.LL.L.Owner_ID := Null_Address; + + else + Succeeded := False; + end if; + + -- Note: at one time we had an exception handler here, whose code + -- was as follows: + + -- exception + + -- Assumes any failure must be due to insufficient resources + + -- when Storage_Error => + -- Must_Not_Fail (DosCloseEventSem (Self_ID.Common.LL.CV)); + -- Succeeded := False; + + -- but that won't work with the old exception scheme, since it would + -- result in messing with Jmpbuf values too early. If and when we get + -- switched entirely to the new zero-cost exception scheme, we could + -- put this handler back in! + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_ID; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Result : aliased APIRET; + Adjusted_Stack_Size : System.Parameters.Size_Type; + use System.Parameters; + + begin + -- In OS/2 the allocated stack size should be based on the + -- amount of address space that should be reserved for the stack. + -- Actual memory will only be used when the stack is touched anyway. + + -- The new minimum size is 12 kB, although the EMX docs + -- recommend a minimum size of 32 kB. (The original was 4 kB) + -- Systems that use many tasks (say > 30) and require much + -- memory may run out of virtual address space, since OS/2 + -- has a per-proces limit of 512 MB, of which max. 300 MB is + -- usable in practise. + + if Stack_Size = Unspecified_Size then + Adjusted_Stack_Size := Default_Stack_Size; + + elsif Stack_Size < Minimum_Stack_Size then + Adjusted_Stack_Size := Minimum_Stack_Size; + + else + Adjusted_Stack_Size := Stack_Size; + end if; + + -- GB970222: + -- Because DosCreateThread is called directly here, the + -- C RTL doesn't get initialized for the new thead. EMX by + -- default uses per-thread local heaps in addition to the + -- global heap. There might be other effects of by-passing the + -- C library here. + + -- When using _beginthread the newly created thread is not + -- blocked initially. Does this matter or can I create the + -- thread running anyway? The LL.Thread variable will be set + -- anyway because the variable is passed by reference to OS/2. + + T.Common.LL.Wrapper := To_PFNTHREAD (Wrapper); + + -- The OS implicitly gives the new task the priority of this task. + + T.Common.LL.Current_Priority := Self.Common.LL.Current_Priority; + + -- If task was locked before activator task was + -- initialized, assume it has OS standard priority + + if T.Common.LL.L.Owner_Priority not in Any_Priority'Range then + T.Common.LL.L.Owner_Priority := 1; + end if; + + -- Create the thread, in blocked mode + + Result := DosCreateThread + (F_ptid => T.Common.LL.Thread'Unchecked_Access, + pfn => T.Common.LL.Wrapper, + param => To_Address (T), + flag => Block_Child + Commit_Stack, + cbStack => ULONG (Adjusted_Stack_Size)); + + Succeeded := (Result = NO_ERROR); + + if not Succeeded then + return; + end if; + + -- Set the new thread's priority + -- (child has inherited priority from parent) + + Set_Priority (T, Priority); + + -- Start the thread executing + + Must_Not_Fail (DosResumeThread (T.Common.LL.Thread)); + + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_ID) is + Tmp : Task_ID := T; + + procedure Free is new + Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); + + begin + Must_Not_Fail (DosCloseEventSem (T.Common.LL.CV)); + + if not Single_Lock then + Finalize_Lock (T.Common.LL.L'Unchecked_Access); + end if; + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + Thread_Local_Data_Ptr := null; + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_ID) is + pragma Unreferenced (T); + + begin + null; + + -- Task abortion not implemented yet. + -- Should perform other action ??? + + end Abort_Task; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + begin + return Check_No_Locks (Self_ID); + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + TLD : constant Access_Thread_Local_Data := Thread_Local_Data_Ptr; + + begin + return Self_ID = TLD.Self_ID + and then TLD.Lock_Prio_Level = 0; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_ID is + begin + return Environment_Task_ID; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) + return Boolean + is + begin + if Thread_Id (T.Common.LL.Thread) /= Thread_Self then + return DosSuspendThread (T.Common.LL.Thread) = NO_ERROR; + else + return True; + end if; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) + return Boolean + is + begin + if Thread_Id (T.Common.LL.Thread) /= Thread_Self then + return DosResumeThread (T.Common.LL.Thread) = NO_ERROR; + else + return True; + end if; + end Resume_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + Succeeded : Boolean; + begin + Environment_Task_ID := Environment_Task; + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + -- Initialize the lock used to synchronize chain of all ATCBs. + + -- Set ID of environment task. + + Thread_Local_Data_Ptr.Self_ID := Environment_Task; + Environment_Task.Common.LL.Thread := 1; -- By definition + + -- This priority is unknown in fact. + -- If actual current priority is different, + -- it will get synchronized later on anyway. + + Environment_Task.Common.LL.Current_Priority := + Environment_Task.Common.Current_Priority; + + -- Initialize TCB for this task. + -- This includes all the normal task-external initialization. + -- This is also done by Initialize_ATCB, why ??? + + Initialize_TCB (Environment_Task, Succeeded); + + -- Consider raising Storage_Error, + -- if propagation can be tolerated ??? + + pragma Assert (Succeeded); + + -- Do normal task-internal initialization, + -- which depends on an initialized TCB. + + Enter_Task (Environment_Task); + + -- Insert here any other special + -- initialization needed for the environment task. + end Initialize; + +begin + -- Initialize pointer to task local data. + -- This is done once, for all tasks. + + Must_Not_Fail (DosAllocThreadLocalMemory + ((Thread_Local_Data'Size + 31) / 32, -- nr of 32-bit words + To_PPVOID (Thread_Local_Data_Ptr'Access))); + + -- Initialize thread local data for main thread + + Thread_Local_Data_Ptr.Self_ID := null; + Thread_Local_Data_Ptr.Lock_Prio_Level := 0; +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb new file mode 100644 index 00000000000..f5bc6174ccb --- /dev/null +++ b/gcc/ada/s-taprop-posix.adb @@ -0,0 +1,1212 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 a POSIX-like version of this package + +-- This package contains all the GNULL primitives that interface directly +-- with the underlying OS. + +-- Note: this file can only be used for POSIX compliant systems that +-- implement SCHED_FIFO and Ceiling Locking correctly. + +-- For configurations where SCHED_FIFO and priority ceiling are not a +-- requirement, this file can also be used (e.g AiX threads) + +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.Tasking.Debug; +-- used for Known_Tasks + +with System.Task_Info; +-- used for Task_Info_Type + +with Interfaces.C; +-- used for int +-- size_t + +with System.Interrupt_Management; +-- used for Keep_Unmasked +-- Abort_Task_Interrupt +-- Interrupt_ID + +with System.Interrupt_Management.Operations; +-- used for Set_Interrupt_Mask +-- All_Tasks_Mask +pragma Elaborate_All (System.Interrupt_Management.Operations); + +with System.Parameters; +-- used for Size_Type + +with System.Tasking; +-- used for Ada_Task_Control_Block +-- Task_ID + +with System.Soft_Links; +-- used for Defer/Undefer_Abort + +-- Note that we do not use System.Tasking.Initialization directly since +-- this is a higher level package that we shouldn't depend on. For example +-- when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Initialization + +with System.OS_Primitives; +-- used for Delay_Modes + +with Unchecked_Conversion; +with Unchecked_Deallocation; + +package body System.Task_Primitives.Operations is + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + + package SSL renames System.Soft_Links; + + ---------------- + -- Local Data -- + ---------------- + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_ID associated with a thread + + Environment_Task_ID : Task_ID; + -- A variable to hold Task_ID for the environment task. + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + -- Value of the pragma Locking_Policy: + -- 'C' for Ceiling_Locking + -- 'I' for Inherit_Locking + -- ' ' for none. + + Unblocked_Signal_Mask : aliased sigset_t; + -- The set of signals that should unblocked in all tasks + + -- The followings are internal configuration constants needed. + + Next_Serial_Number : Task_Serial_Number := 100; + -- We start at 100, to reserve some special values for + -- using in error checking. + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; + -- Indicates whether FIFO_Within_Priorities is set. + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads). + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_ID); + pragma Inline (Initialize); + -- Initialize various data needed by this package. + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_ID); + pragma Inline (Set); + -- Set the self id for the current task. + + function Self return Task_ID; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task. + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific. + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; + -- Allocate and Initialize a new ATCB for the current Thread. + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_ID is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Abort_Handler (Sig : Signal); + -- Signal handler used to implement asynchronous abort. + -- See also comment before body, below. + + function To_Address is new Unchecked_Conversion (Task_ID, System.Address); + + ------------------- + -- Abort_Handler -- + ------------------- + + -- Target-dependent binding of inter-thread Abort signal to + -- the raising of the Abort_Signal exception. + + -- The technical issues and alternatives here are essentially + -- the same as for raising exceptions in response to other + -- signals (e.g. Storage_Error). See code and comments in + -- the package body System.Interrupt_Management. + + -- Some implementations may not allow an exception to be propagated + -- out of a handler, and others might leave the signal or + -- interrupt that invoked this handler masked after the exceptional + -- return to the application code. + + -- GNAT exceptions are originally implemented using setjmp()/longjmp(). + -- On most UNIX systems, this will allow transfer out of a signal handler, + -- which is usually the only mechanism available for implementing + -- asynchronous handlers of this kind. However, some + -- systems do not restore the signal mask on longjmp(), leaving the + -- abort signal masked. + + procedure Abort_Handler (Sig : Signal) is + pragma Warnings (Off, Sig); + + T : constant Task_ID := Self; + Result : Interfaces.C.int; + Old_Set : aliased sigset_t; + + begin + -- It is not safe to raise an exception when using ZCX and the GCC + -- exception handling mechanism. + + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + + if T.Deferral_Level = 0 + and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then + not T.Aborting + then + T.Aborting := True; + + -- Make sure signals used for RTS internal purpose are unmasked + + Result := pthread_sigmask (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + ----------------- + -- Stack_Guard -- + ----------------- + + procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + Stack_Base : constant Address := Get_Stack_Base (T.Common.LL.Thread); + Guard_Page_Address : Address; + + Res : Interfaces.C.int; + + begin + if Stack_Base_Available then + + -- Compute the guard page address + + Guard_Page_Address := + Stack_Base - (Stack_Base mod Get_Page_Size) + Get_Page_Size; + + if On then + Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_ON); + else + Res := mprotect (Guard_Page_Address, Get_Page_Size, PROT_OFF); + end if; + + pragma Assert (Res = 0); + end if; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID renames Specific.Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are + -- initialized in Intialize_TCB and the Storage_Error is + -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) + -- used in RTS is initialized before any status change of RTS. + -- Therefore rasing Storage_Error in the following routines + -- should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : access Lock) + is + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := pthread_mutexattr_setprioceiling + (Attributes'Access, Interfaces.C.int (Prio)); + pragma Assert (Result = 0); + + elsif Locking_Policy = 'I' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_INHERIT); + pragma Assert (Result = 0); + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Warnings (Off, Level); + + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := pthread_mutexattr_setprioceiling + (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); + pragma Assert (Result = 0); + + elsif Locking_Policy = 'I' then + Result := pthread_mutexattr_setprotocol + (Attributes'Access, PTHREAD_PRIO_INHERIT); + pragma Assert (Result = 0); + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : access Lock) is + Result : Interfaces.C.int; + + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : access RTS_Lock) is + Result : Interfaces.C.int; + + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + Result : Interfaces.C.int; + + begin + Result := pthread_mutex_lock (L); + + -- Assume that the cause of EINVAL is a priority ceiling violation + + Ceiling_Violation := (Result = EINVAL); + pragma Assert (Result = 0 or else Result = EINVAL); + end Write_Lock; + + procedure Write_Lock + (L : access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_ID) is + Result : Interfaces.C.int; + + begin + if not Single_Lock then + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : access Lock) is + Result : Interfaces.C.int; + + begin + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end Unlock; + + procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is + Result : Interfaces.C.int; + + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_ID) is + Result : Interfaces.C.int; + + begin + if not Single_Lock then + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_ID; + Reason : System.Tasking.Task_States) + is + pragma Warnings (Off, Reason); + + Result : Interfaces.C.int; + + begin + if Single_Lock then + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + else + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + end if; + + -- EINTR is not considered a failure. + + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is + -- assumed to be already deferred, and the caller should be + -- holding its own ATCB lock. + + procedure Timed_Sleep + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Warnings (Off, Reason); + + Check_Time : constant Duration := Monotonic_Clock; + Rel_Time : Duration; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + Timedout := True; + Yielded := False; + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time); + end if; + + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); + end if; + end if; + + if Abs_Time > Check_Time then + if Relative_Timed_Wait then + Request := To_Timespec (Rel_Time); + else + Request := To_Timespec (Abs_Time); + end if; + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + or else Self_ID.Pending_Priority_Change; + + if Single_Lock then + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access, + Request'Access); + + else + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access, + Request'Access); + end if; + + exit when Abs_Time <= Monotonic_Clock; + + if Result = 0 or Result = EINTR then + + -- Somebody may have called Wakeup for us + + Timedout := False; + exit; + end if; + + pragma Assert (Result = ETIMEDOUT); + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + -- This is for use in implementing delay statements, so + -- we assume the caller is abort-deferred but is holding + -- no locks. + + procedure Timed_Delay + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes) + is + Check_Time : constant Duration := Monotonic_Clock; + Abs_Time : Duration; + Rel_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + -- Only the little window between deferring abort and + -- locking Self_ID is the reason we need to + -- check for pending abort and priority change below! :( + + SSL.Abort_Defer.all; + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time); + end if; + + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + + if Relative_Timed_Wait then + Rel_Time := Duration'Min (Max_Sensible_Delay, Time - Check_Time); + end if; + end if; + + if Abs_Time > Check_Time then + if Relative_Timed_Wait then + Request := To_Timespec (Rel_Time); + else + Request := To_Timespec (Abs_Time); + end if; + + Self_ID.Common.State := Delay_Sleep; + + loop + if Self_ID.Pending_Priority_Change then + Self_ID.Pending_Priority_Change := False; + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + end if; + + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + if Single_Lock then + Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, Request'Access); + else + Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, Request'Access); + end if; + + exit when Abs_Time <= Monotonic_Clock; + + pragma Assert (Result = 0 + or else Result = ETIMEDOUT + or else Result = EINTR); + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Result := sched_yield; + SSL.Abort_Undefer.all; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; + + begin + Result := clock_gettime + (clock_id => CLOCK_REALTIME, tp => TS'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (TS); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 10#1.0#E-6; + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is + pragma Warnings (Off, Reason); + + Result : Interfaces.C.int; + + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin + if Do_Yield then + Result := sched_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_ID; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + pragma Warnings (Off, Loss_Of_Inheritance); + + Result : Interfaces.C.int; + Param : aliased struct_sched_param; + + begin + T.Common.Current_Priority := Prio; + Param.sched_priority := Interfaces.C.int (Prio); + + if Time_Slice_Supported and then Time_Slice_Val > 0 then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); + + elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + + else + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + end if; + + pragma Assert (Result = 0); + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_ID) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_ID) is + begin + Self_ID.Common.LL.Thread := pthread_self; + Self_ID.Common.LL.LWP := lwp_self; + + Specific.Set (Self_ID); + + Lock_RTS; + + for J in Known_Tasks'Range loop + if Known_Tasks (J) = null then + Known_Tasks (J) := Self_ID; + Self_ID.Known_Tasks_Index := J; + exit; + end if; + end loop; + + Unlock_RTS; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + + begin + -- Give the task a unique serial number. + + Self_ID.Serial_Number := Next_Serial_Number; + Next_Serial_Number := Next_Serial_Number + 1; + pragma Assert (Next_Serial_Number /= 0); + + if not Single_Lock then + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + if Locking_Policy = 'C' then + Result := pthread_mutexattr_setprotocol + (Mutex_Attr'Access, PTHREAD_PRIO_PROTECT); + pragma Assert (Result = 0); + + Result := pthread_mutexattr_setprioceiling + (Mutex_Attr'Access, + Interfaces.C.int (System.Any_Priority'Last)); + pragma Assert (Result = 0); + + elsif Locking_Policy = 'I' then + Result := pthread_mutexattr_setprotocol + (Mutex_Attr'Access, PTHREAD_PRIO_INHERIT); + pragma Assert (Result = 0); + end if; + + Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, + Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, + Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + else + if not Single_Lock then + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_ID; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Attributes : aliased pthread_attr_t; + Adjusted_Stack_Size : Interfaces.C.size_t; + Result : Interfaces.C.int; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + use System.Task_Info; + + begin + if Stack_Size = Unspecified_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size); + + elsif Stack_Size < Minimum_Stack_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); + + else + Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); + end if; + + if Stack_Base_Available then + -- If Stack Checking is supported then allocate 2 additional pages: + -- + -- In the worst case, stack is allocated at something like + -- N * Get_Page_Size - epsilon, we need to add the size for 2 pages + -- to be sure the effective stack size is greater than what + -- has been asked. + + Adjusted_Stack_Size := Adjusted_Stack_Size + 2 * Get_Page_Size; + end if; + + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); + pragma Assert (Result = 0); + + Result := pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); + pragma Assert (Result = 0); + + if T.Common.Task_Info /= Default_Scope then + + -- We are assuming that Scope_Type has the same values than the + -- corresponding C macros + + Result := pthread_attr_setscope + (Attributes'Access, Task_Info_Type'Pos (T.Common.Task_Info)); + pragma Assert (Result = 0); + end if; + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + Result := pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + pragma Assert (Result = 0 or else Result = EAGAIN); + + Succeeded := Result = 0; + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + + Set_Priority (T, Priority); + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_ID) is + Result : Interfaces.C.int; + Tmp : Task_ID := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); + + begin + if not Single_Lock then + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + -- Mark this task as unknown, so that if Self is called, it won't + -- return a dangling pointer. + + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_ID) is + Result : Interfaces.C.int; + + begin + Result := pthread_kill (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + end Abort_Task; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + pragma Warnings (Off, Self_ID); + + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + pragma Warnings (Off, Self_ID); + + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_ID is + begin + return Environment_Task_ID; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) + return Boolean + is + pragma Warnings (Off, T); + pragma Warnings (Off, Thread_Self); + + begin + return False; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) + return Boolean + is + pragma Warnings (Off, T); + pragma Warnings (Off, Thread_Self); + + begin + return False; + end Resume_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + + function State (Int : System.Interrupt_Management.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: + + 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 + Environment_Task_ID := Environment_Task; + + -- Initialize the lock used to synchronize chain of all ATCBs. + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Specific.Initialize (Environment_Task); + + Enter_Task (Environment_Task); + + -- Install the abort-signal handler + + if State (System.Interrupt_Management.Abort_Task_Interrupt) + /= Default + then + act.sa_flags := 0; + act.sa_handler := Abort_Handler'Address; + + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction + (Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + end if; + end Initialize; + +begin + declare + Result : Interfaces.C.int; + begin + -- Mask Environment task for all signals. The original mask of the + -- Environment task will be recovered by Interrupt_Server task + -- during the elaboration of s-interr.adb. + + System.Interrupt_Management.Operations.Set_Interrupt_Mask + (System.Interrupt_Management.Operations.All_Tasks_Mask'Access); + + -- Prepare the set of signals that should unblocked in all tasks + + Result := sigemptyset (Unblocked_Signal_Mask'Access); + pragma Assert (Result = 0); + + for J in Interrupt_Management.Interrupt_ID loop + if System.Interrupt_Management.Keep_Unmasked (J) then + Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + end; +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb new file mode 100644 index 00000000000..a264b029693 --- /dev/null +++ b/gcc/ada/s-taprop-solaris.adb @@ -0,0 +1,1815 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 a Solaris (native) version of this package + +-- This package contains all the GNULL primitives that interface directly +-- with the underlying OS. + +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.Tasking.Debug; +-- used for Known_Tasks + +with Ada.Exceptions; +-- used for Raise_Exception + +with GNAT.OS_Lib; +-- used for String_Access, Getenv + +with Interfaces.C; +-- used for int +-- size_t + +with System.Interrupt_Management; +-- used for Keep_Unmasked +-- Abort_Task_Interrupt +-- Interrupt_ID + +with System.Interrupt_Management.Operations; +-- used for Set_Interrupt_Mask +-- All_Tasks_Mask +pragma Elaborate_All (System.Interrupt_Management.Operations); + +with System.Parameters; +-- used for Size_Type + +with System.Tasking; +-- used for Ada_Task_Control_Block +-- Task_ID +-- ATCB components and types + +with System.Task_Info; +-- to initialize Task_Info for a C thread, in function Self + +with System.Soft_Links; +-- used for Defer/Undefer_Abort +-- to initialize TSD for a C thread, in function Self + +-- Note that we do not use System.Tasking.Initialization directly since +-- this is a higher level package that we shouldn't depend on. For example +-- when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Initialization + +with System.OS_Primitives; +-- used for Delay_Modes + +with Unchecked_Deallocation; + +package body System.Task_Primitives.Operations is + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use Ada.Exceptions; + use System.OS_Primitives; + + package SSL renames System.Soft_Links; + + ---------------- + -- Local Data -- + ---------------- + + -- The following are logically constants, but need to be initialized + -- at run time. + + Environment_Task_ID : Task_ID; + -- A variable to hold Task_ID for the environment task. + -- If we use this variable to get the Task_ID, we need the following + -- ATCB_Key only for non-Ada threads. + + Unblocked_Signal_Mask : aliased sigset_t; + -- The set of signals that should unblocked in all tasks + + ATCB_Key : aliased thread_key_t; + -- Key used to find the Ada Task_ID associated with a thread, + -- at least for C threads unknown to the Ada run-time system. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + Next_Serial_Number : Task_Serial_Number := 100; + -- We start at 100, to reserve some special values for + -- using in error checking. + -- The following are internal configuration constants needed. + + ---------------------- + -- Priority Support -- + ---------------------- + + Priority_Ceiling_Emulation : constant Boolean := True; + -- controls whether we emulate priority ceiling locking + + -- To get a scheduling close to annex D requirements, we use the real-time + -- class provided for LWP's and map each task/thread to a specific and + -- unique LWP (there is 1 thread per LWP, and 1 LWP per thread). + + -- The real time class can only be set when the process has root + -- priviledges, so in the other cases, we use the normal thread scheduling + -- and priority handling. + + Using_Real_Time_Class : Boolean := False; + -- indicates wether the real time class is being used (i.e the process + -- has root priviledges). + + Prio_Param : aliased struct_pcparms; + -- Hold priority info (Real_Time) initialized during the package + -- elaboration. + + ----------------------------------- + -- External Configuration Values -- + ----------------------------------- + + Time_Slice_Val : Interfaces.C.long; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads). + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function sysconf (name : System.OS_Interface.int) return processorid_t; + pragma Import (C, sysconf, "sysconf"); + + SC_NPROCESSORS_CONF : constant System.OS_Interface.int := 14; + + function Num_Procs + (name : System.OS_Interface.int := SC_NPROCESSORS_CONF) + return processorid_t renames sysconf; + + procedure Abort_Handler + (Sig : Signal; + Code : access siginfo_t; + Context : access ucontext_t); + -- Target-dependent binding of inter-thread Abort signal to + -- the raising of the Abort_Signal exception. + -- See also comments in 7staprop.adb + + ------------ + -- Checks -- + ------------ + + function Check_Initialize_Lock + (L : Lock_Ptr; + Level : Lock_Level) return Boolean; + pragma Inline (Check_Initialize_Lock); + + function Check_Lock (L : Lock_Ptr) return Boolean; + pragma Inline (Check_Lock); + + function Record_Lock (L : Lock_Ptr) return Boolean; + pragma Inline (Record_Lock); + + function Check_Sleep (Reason : Task_States) return Boolean; + pragma Inline (Check_Sleep); + + function Record_Wakeup + (L : Lock_Ptr; + Reason : Task_States) return Boolean; + pragma Inline (Record_Wakeup); + + function Check_Wakeup + (T : Task_ID; + Reason : Task_States) return Boolean; + pragma Inline (Check_Wakeup); + + function Check_Unlock (L : Lock_Ptr) return Boolean; + pragma Inline (Check_Unlock); + + function Check_Finalize_Lock (L : Lock_Ptr) return Boolean; + pragma Inline (Check_Finalize_Lock); + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_ID); + pragma Inline (Initialize); + -- Initialize various data needed by this package. + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_ID); + pragma Inline (Set); + -- Set the self id for the current task. + + function Self return Task_ID; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task. + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific. + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; + -- Allocate and Initialize a new ATCB for the current Thread. + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_ID is separate; + + ------------ + -- Checks -- + ------------ + + Check_Count : Integer := 0; + Lock_Count : Integer := 0; + Unlock_Count : Integer := 0; + + ------------------- + -- Abort_Handler -- + ------------------- + + procedure Abort_Handler + (Sig : Signal; + Code : access siginfo_t; + Context : access ucontext_t) + is + pragma Unreferenced (Sig); + pragma Unreferenced (Code); + pragma Unreferenced (Context); + + Self_ID : constant Task_ID := Self; + Old_Set : aliased sigset_t; + + Result : Interfaces.C.int; + pragma Unreferenced (Result); + + begin + -- It is not safe to raise an exception when using ZCX and the GCC + -- exception handling mechanism. + + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + + if Self_ID.Deferral_Level = 0 + and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + and then not Self_ID.Aborting + then + Self_ID.Aborting := True; + + -- Make sure signals used for RTS internal purpose are unmasked + + Result := thr_sigsetmask (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + ------------------- + -- Stack_Guard -- + ------------------- + + -- The underlying thread system sets a guard page at the + -- bottom of a thread stack, so nothing is needed. + + procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Unreferenced (T); + pragma Unreferenced (On); + + begin + null; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : ST.Task_ID) is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + + procedure Configure_Processors; + -- Processors configuration + -- The user can specify a processor which the program should run + -- on to emulate a single-processor system. This can be easily + -- done by setting environment variable GNAT_PROCESSOR to one of + -- the following : + -- + -- -2 : use the default configuration (run the program on all + -- available processors) - this is the same as having + -- GNAT_PROCESSOR unset + -- -1 : let the RTS choose one processor and run the program on + -- that processor + -- 0 .. Last_Proc : run the program on the specified processor + -- + -- Last_Proc is equal to the value of the system variable + -- _SC_NPROCESSORS_CONF, minus one. + + procedure Configure_Processors is + Proc_Acc : constant GNAT.OS_Lib.String_Access := + GNAT.OS_Lib.Getenv ("GNAT_PROCESSOR"); + Proc : aliased processorid_t; -- User processor # + Last_Proc : processorid_t; -- Last processor # + + begin + if Proc_Acc.all'Length /= 0 then + -- Environment variable is defined + + Last_Proc := Num_Procs - 1; + + if Last_Proc /= -1 then + Proc := processorid_t'Value (Proc_Acc.all); + + if Proc <= -2 or else Proc > Last_Proc then + -- Use the default configuration + null; + elsif Proc = -1 then + -- Choose a processor + + Result := 0; + + while Proc < Last_Proc loop + Proc := Proc + 1; + Result := p_online (Proc, PR_STATUS); + exit when Result = PR_ONLINE; + end loop; + + pragma Assert (Result = PR_ONLINE); + Result := processor_bind (P_PID, P_MYID, Proc, null); + pragma Assert (Result = 0); + + else + -- Use user processor + + Result := processor_bind (P_PID, P_MYID, Proc, null); + pragma Assert (Result = 0); + end if; + end if; + end if; + + exception + when Constraint_Error => + + -- Illegal environment variable GNAT_PROCESSOR - ignored + + null; + end Configure_Processors; + + function State (Int : System.Interrupt_Management.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: + + 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) + + -- Start of processing for Initialize + + begin + Environment_Task_ID := Environment_Task; + + -- This is done in Enter_Task, but this is too late for the + -- Environment Task, since we need to call Self in Check_Locks when + -- the run time is compiled with assertions on. + + Specific.Initialize (Environment_Task); + + -- Initialize the lock used to synchronize chain of all ATCBs. + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Enter_Task (Environment_Task); + + -- Install the abort-signal handler + + if State (System.Interrupt_Management.Abort_Task_Interrupt) + /= Default + then + -- Set sa_flags to SA_NODEFER so that during the handler execution + -- we do not change the Signal_Mask to be masked for the Abort_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. + -- In that case, this field should be changed back to 0. ??? + + act.sa_flags := 16; + + act.sa_handler := Abort_Handler'Address; + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction ( + Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + end if; + + Configure_Processors; + end Initialize; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are + -- initialized in Initialize_TCB and the Storage_Error is + -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) + -- used in RTS is initialized before any status change of RTS. + -- Therefore rasing Storage_Error in the following routines + -- should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : access Lock) + is + Result : Interfaces.C.int; + + begin + pragma Assert (Check_Initialize_Lock (Lock_Ptr (L), PO_Level)); + + if Priority_Ceiling_Emulation then + L.Ceiling := Prio; + end if; + + Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Raise_Exception (Storage_Error'Identity, "Failed to allocate a lock"); + end if; + end Initialize_Lock; + + procedure Initialize_Lock + (L : access RTS_Lock; + Level : Lock_Level) + is + Result : Interfaces.C.int; + + begin + pragma Assert (Check_Initialize_Lock + (To_Lock_Ptr (RTS_Lock_Ptr (L)), Level)); + Result := mutex_init (L.L'Access, USYNC_THREAD, System.Null_Address); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Raise_Exception (Storage_Error'Identity, "Failed to allocate a lock"); + end if; + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : access Lock) is + Result : Interfaces.C.int; + + begin + pragma Assert (Check_Finalize_Lock (Lock_Ptr (L))); + Result := mutex_destroy (L.L'Access); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : access RTS_Lock) is + Result : Interfaces.C.int; + + begin + pragma Assert (Check_Finalize_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); + Result := mutex_destroy (L.L'Access); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + Result : Interfaces.C.int; + + begin + pragma Assert (Check_Lock (Lock_Ptr (L))); + + if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then + declare + Self_Id : constant Task_ID := Self; + Saved_Priority : System.Any_Priority; + + begin + if Self_Id.Common.LL.Active_Priority > L.Ceiling then + Ceiling_Violation := True; + return; + end if; + + Saved_Priority := Self_Id.Common.LL.Active_Priority; + + if Self_Id.Common.LL.Active_Priority < L.Ceiling then + Set_Priority (Self_Id, L.Ceiling); + end if; + + Result := mutex_lock (L.L'Access); + pragma Assert (Result = 0); + Ceiling_Violation := False; + + L.Saved_Priority := Saved_Priority; + end; + + else + Result := mutex_lock (L.L'Access); + pragma Assert (Result = 0); + Ceiling_Violation := False; + end if; + + pragma Assert (Record_Lock (Lock_Ptr (L))); + end Write_Lock; + + procedure Write_Lock + (L : access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + + begin + if not Single_Lock or else Global_Lock then + pragma Assert (Check_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); + Result := mutex_lock (L.L'Access); + pragma Assert (Result = 0); + pragma Assert (Record_Lock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_ID) is + Result : Interfaces.C.int; + + begin + if not Single_Lock then + pragma Assert (Check_Lock (To_Lock_Ptr (T.Common.LL.L'Access))); + Result := mutex_lock (T.Common.LL.L.L'Access); + pragma Assert (Result = 0); + pragma Assert (Record_Lock (To_Lock_Ptr (T.Common.LL.L'Access))); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : access Lock) is + Result : Interfaces.C.int; + + begin + pragma Assert (Check_Unlock (Lock_Ptr (L))); + + if Priority_Ceiling_Emulation and then Locking_Policy = 'C' then + declare + Self_Id : constant Task_ID := Self; + + begin + Result := mutex_unlock (L.L'Access); + pragma Assert (Result = 0); + + if Self_Id.Common.LL.Active_Priority > L.Saved_Priority then + Set_Priority (Self_Id, L.Saved_Priority); + end if; + end; + else + Result := mutex_unlock (L.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is + Result : Interfaces.C.int; + + begin + if not Single_Lock or else Global_Lock then + pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L)))); + Result := mutex_unlock (L.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_ID) is + Result : Interfaces.C.int; + + begin + if not Single_Lock then + pragma Assert (Check_Unlock (To_Lock_Ptr (T.Common.LL.L'Access))); + Result := mutex_unlock (T.Common.LL.L.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + -- For the time delay implementation, we need to make sure we + -- achieve following criteria: + + -- 1) We have to delay at least for the amount requested. + -- 2) We have to give up CPU even though the actual delay does not + -- result in blocking. + -- 3) Except for restricted run-time systems that do not support + -- ATC or task abort, the delay must be interrupted by the + -- abort_task operation. + -- 4) The implementation has to be efficient so that the delay overhead + -- is relatively cheap. + -- (1)-(3) are Ada requirements. Even though (2) is an Annex-D + -- requirement we still want to provide the effect in all cases. + -- The reason is that users may want to use short delays to implement + -- their own scheduling effect in the absence of language provided + -- scheduling policies. + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; + + begin + Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (TS); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 10#1.0#E-6; + end RT_Resolution; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + begin + if Do_Yield then + System.OS_Interface.thr_yield; + end if; + end Yield; + + ----------- + -- Self --- + ----------- + + function Self return Task_ID renames Specific.Self; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_ID; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + pragma Unreferenced (Loss_Of_Inheritance); + + Result : Interfaces.C.int; + pragma Unreferenced (Result); + + Param : aliased struct_pcparms; + + use Task_Info; + + begin + T.Common.Current_Priority := Prio; + + if Priority_Ceiling_Emulation then + T.Common.LL.Active_Priority := Prio; + end if; + + if Using_Real_Time_Class then + Param.pc_cid := Prio_Param.pc_cid; + Param.rt_pri := pri_t (Prio); + Param.rt_tqsecs := Prio_Param.rt_tqsecs; + Param.rt_tqnsecs := Prio_Param.rt_tqnsecs; + + Result := Interfaces.C.int ( + priocntl (PC_VERSION, P_LWPID, T.Common.LL.LWP, PC_SETPARMS, + Param'Address)); + + else + if T.Common.Task_Info /= null + and then not T.Common.Task_Info.Bound_To_LWP + then + -- The task is not bound to a LWP, so use thr_setprio + + Result := + thr_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio)); + + else + + -- The task is bound to a LWP, use priocntl + -- ??? TBD + + null; + end if; + end if; + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_ID) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_ID) is + Result : Interfaces.C.int; + Proc : processorid_t; -- User processor # + Last_Proc : processorid_t; -- Last processor # + + use System.Task_Info; + begin + Self_ID.Common.LL.Thread := thr_self; + + Self_ID.Common.LL.LWP := lwp_self; + + if Self_ID.Common.Task_Info /= null then + if Self_ID.Common.Task_Info.New_LWP + and then Self_ID.Common.Task_Info.CPU /= CPU_UNCHANGED + then + Last_Proc := Num_Procs - 1; + + if Self_ID.Common.Task_Info.CPU = ANY_CPU then + Result := 0; + Proc := 0; + + while Proc < Last_Proc loop + Result := p_online (Proc, PR_STATUS); + exit when Result = PR_ONLINE; + Proc := Proc + 1; + end loop; + + Result := processor_bind (P_LWPID, P_MYID, Proc, null); + pragma Assert (Result = 0); + + else + -- Use specified processor + + if Self_ID.Common.Task_Info.CPU < 0 + or else Self_ID.Common.Task_Info.CPU > Last_Proc + then + raise Invalid_CPU_Number; + end if; + + Result := processor_bind + (P_LWPID, P_MYID, Self_ID.Common.Task_Info.CPU, null); + pragma Assert (Result = 0); + end if; + end if; + end if; + + Specific.Set (Self_ID); + + -- We need the above code even if we do direct fetch of Task_ID in Self + -- for the main task on Sun, x86 Solaris and for gcc 2.7.2. + + Lock_RTS; + + for J in Known_Tasks'Range loop + if Known_Tasks (J) = null then + Known_Tasks (J) := Self_ID; + Self_ID.Known_Tasks_Index := J; + exit; + end if; + end loop; + + Unlock_RTS; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (thr_self); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is + Result : Interfaces.C.int := 0; + + begin + -- Give the task a unique serial number. + + Self_ID.Serial_Number := Next_Serial_Number; + Next_Serial_Number := Next_Serial_Number + 1; + pragma Assert (Next_Serial_Number /= 0); + + Self_ID.Common.LL.Thread := To_thread_t (-1); + + if not Single_Lock then + Result := mutex_init + (Self_ID.Common.LL.L.L'Access, USYNC_THREAD, System.Null_Address); + Self_ID.Common.LL.L.Level := + Private_Task_Serial_Number (Self_ID.Serial_Number); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Result := cond_init (Self_ID.Common.LL.CV'Access, USYNC_THREAD, 0); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + else + if not Single_Lock then + Result := mutex_destroy (Self_ID.Common.LL.L.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_ID; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + pragma Unreferenced (Priority); + + Result : Interfaces.C.int; + Adjusted_Stack_Size : Interfaces.C.size_t; + Opts : Interfaces.C.int := THR_DETACHED; + + Page_Size : constant System.Parameters.Size_Type := 4096; + -- This constant is for reserving extra space at the + -- end of the stack, which can be used by the stack + -- checking as guard page. The idea is that we need + -- to have at least Stack_Size bytes available for + -- actual use. + + use System.Task_Info; + + begin + if Stack_Size = System.Parameters.Unspecified_Size then + Adjusted_Stack_Size := + Interfaces.C.size_t (Default_Stack_Size + Page_Size); + + elsif Stack_Size < Minimum_Stack_Size then + Adjusted_Stack_Size := + Interfaces.C.size_t (Minimum_Stack_Size + Page_Size); + + else + Adjusted_Stack_Size := + Interfaces.C.size_t (Stack_Size + Page_Size); + end if; + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + if T.Common.Task_Info /= null then + if T.Common.Task_Info.New_LWP then + Opts := Opts + THR_NEW_LWP; + end if; + + if T.Common.Task_Info.Bound_To_LWP then + Opts := Opts + THR_BOUND; + end if; + + else + Opts := THR_DETACHED + THR_BOUND; + end if; + + Result := thr_create + (System.Null_Address, + Adjusted_Stack_Size, + Thread_Body_Access (Wrapper), + To_Address (T), + Opts, + T.Common.LL.Thread'Access); + + Succeeded := Result = 0; + pragma Assert + (Result = 0 + or else Result = ENOMEM + or else Result = EAGAIN); + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_ID) is + Result : Interfaces.C.int; + Tmp : Task_ID := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); + + begin + T.Common.LL.Thread := To_thread_t (0); + + if not Single_Lock then + Result := mutex_destroy (T.Common.LL.L.L'Access); + pragma Assert (Result = 0); + end if; + + Result := cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + -- This procedure must be called with abort deferred. + -- It can no longer call Self or access + -- the current task's ATCB, since the ATCB has been deallocated. + + procedure Exit_Task is + begin + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_ID) is + Result : Interfaces.C.int; + begin + pragma Assert (T /= Self); + + Result := thr_kill (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + null; + + pragma Assert (Result = 0); + end Abort_Task; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_ID; + Reason : Task_States) + is + Result : Interfaces.C.int; + + begin + pragma Assert (Check_Sleep (Reason)); + + if Dynamic_Priority_Support + and then Self_ID.Pending_Priority_Change + then + Self_ID.Pending_Priority_Change := False; + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + end if; + + if Single_Lock then + Result := cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock.L'Access); + else + Result := cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access); + end if; + + pragma Assert (Record_Wakeup + (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason)); + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + -- Note that we are relying heaviliy here on the GNAT feature + -- that Calendar.Time, System.Real_Time.Time, Duration, and + -- System.Real_Time.Time_Span are all represented in the same + -- way, i.e., as a 64-bit count of nanoseconds. + + -- This allows us to always pass the timeout value as a Duration. + + -- ??? + -- We are taking liberties here with the semantics of the delays. + -- That is, we make no distinction between delays on the Calendar clock + -- and delays on the Real_Time clock. That is technically incorrect, if + -- the Calendar clock happens to be reset or adjusted. + -- To solve this defect will require modification to the compiler + -- interface, so that it can pass through more information, to tell + -- us here which clock to use! + + -- cond_timedwait will return if any of the following happens: + -- 1) some other task did cond_signal on this condition variable + -- In this case, the return value is 0 + -- 2) the call just returned, for no good reason + -- This is called a "spurious wakeup". + -- In this case, the return value may also be 0. + -- 3) the time delay expires + -- In this case, the return value is ETIME + -- 4) this task received a signal, which was handled by some + -- handler procedure, and now the thread is resuming execution + -- UNIX calls this an "interrupted" system call. + -- In this case, the return value is EINTR + + -- If the cond_timedwait returns 0 or EINTR, it is still + -- possible that the time has actually expired, and by chance + -- a signal or cond_signal occurred at around the same time. + + -- We have also observed that on some OS's the value ETIME + -- will be returned, but the clock will show that the full delay + -- has not yet expired. + + -- For these reasons, we need to check the clock after return + -- from cond_timedwait. If the time has expired, we will set + -- Timedout = True. + + -- This check might be omitted for systems on which the + -- cond_timedwait() never returns early or wakes up spuriously. + + -- Annex D requires that completion of a delay cause the task + -- to go to the end of its priority queue, regardless of whether + -- the task actually was suspended by the delay. Since + -- cond_timedwait does not do this on Solaris, we add a call + -- to thr_yield at the end. We might do this at the beginning, + -- instead, but then the round-robin effect would not be the + -- same; the delayed task would be ahead of other tasks of the + -- same priority that awoke while it was sleeping. + + -- For Timed_Sleep, we are expecting possible cond_signals + -- to indicate other events (e.g., completion of a RV or + -- completion of the abortable part of an async. select), + -- we want to always return if interrupted. The caller will + -- be responsible for checking the task state to see whether + -- the wakeup was spurious, and to go back to sleep again + -- in that case. We don't need to check for pending abort + -- or priority change on the way in our out; that is the + -- caller's responsibility. + + -- For Timed_Delay, we are not expecting any cond_signals or + -- other interruptions, except for priority changes and aborts. + -- Therefore, we don't want to return unless the delay has + -- actually expired, or the call has been aborted. In this + -- case, since we want to implement the entire delay statement + -- semantics, we do need to check for pending abort and priority + -- changes. We can quietly handle priority changes inside the + -- procedure, since there is no entry-queue reordering involved. + + ----------------- + -- Timed_Sleep -- + ----------------- + + procedure Timed_Sleep + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + Check_Time : constant Duration := Monotonic_Clock; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + pragma Assert (Check_Sleep (Reason)); + Timedout := True; + Yielded := False; + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + end if; + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + or else (Dynamic_Priority_Support and then + Self_ID.Pending_Priority_Change); + + if Single_Lock then + Result := cond_timedwait (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock.L'Access, Request'Access); + else + Result := cond_timedwait (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L.L'Access, Request'Access); + end if; + + Yielded := True; + + exit when Abs_Time <= Monotonic_Clock; + + if Result = 0 or Result = EINTR then + + -- Somebody may have called Wakeup for us + + Timedout := False; + exit; + end if; + + pragma Assert (Result = ETIME); + end loop; + end if; + + pragma Assert (Record_Wakeup + (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Reason)); + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes) + is + Check_Time : constant Duration := Monotonic_Clock; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + Yielded : Boolean := False; + + begin + -- Only the little window between deferring abort and + -- locking Self_ID is the reason we need to + -- check for pending abort and priority change below! + + SSL.Abort_Defer.all; + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + if Mode = Relative then + Abs_Time := Time + Check_Time; + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + end if; + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + Self_ID.Common.State := Delay_Sleep; + + pragma Assert (Check_Sleep (Delay_Sleep)); + + loop + if Dynamic_Priority_Support and then + Self_ID.Pending_Priority_Change then + Self_ID.Pending_Priority_Change := False; + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + end if; + + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + if Single_Lock then + Result := cond_timedwait (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock.L'Access, Request'Access); + else + Result := cond_timedwait (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L.L'Access, Request'Access); + end if; + + Yielded := True; + + exit when Abs_Time <= Monotonic_Clock; + + pragma Assert (Result = 0 or else + Result = ETIME or else + Result = EINTR); + end loop; + + pragma Assert (Record_Wakeup + (To_Lock_Ptr (Self_ID.Common.LL.L'Access), Delay_Sleep)); + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + if not Yielded then + thr_yield; + end if; + + SSL.Abort_Undefer.all; + end Timed_Delay; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup + (T : Task_ID; + Reason : Task_States) + is + Result : Interfaces.C.int; + + begin + pragma Assert (Check_Wakeup (T, Reason)); + Result := cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + --------------------------- + -- Check_Initialize_Lock -- + --------------------------- + + -- The following code is intended to check some of the invariant + -- assertions related to lock usage, on which we depend. + + function Check_Initialize_Lock + (L : Lock_Ptr; + Level : Lock_Level) return Boolean + is + Self_ID : constant Task_ID := Self; + + begin + -- Check that caller is abort-deferred + + if Self_ID.Deferral_Level <= 0 then + return False; + end if; + + -- Check that the lock is not yet initialized + + if L.Level /= 0 then + return False; + end if; + + L.Level := Lock_Level'Pos (Level) + 1; + return True; + end Check_Initialize_Lock; + + ---------------- + -- Check_Lock -- + ---------------- + + function Check_Lock (L : Lock_Ptr) return Boolean is + Self_ID : constant Task_ID := Self; + P : Lock_Ptr; + + begin + -- Check that the argument is not null + + if L = null then + return False; + end if; + + -- Check that L is not frozen + + if L.Frozen then + return False; + end if; + + -- Check that caller is abort-deferred + + if Self_ID.Deferral_Level <= 0 then + return False; + end if; + + -- Check that caller is not holding this lock already + + if L.Owner = To_Owner_ID (To_Address (Self_ID)) then + return False; + end if; + + if Single_Lock then + return True; + end if; + + -- Check that TCB lock order rules are satisfied + + P := Self_ID.Common.LL.Locks; + if P /= null then + if P.Level >= L.Level + and then (P.Level > 2 or else L.Level > 2) + then + return False; + end if; + end if; + + return True; + end Check_Lock; + + ----------------- + -- Record_Lock -- + ----------------- + + function Record_Lock (L : Lock_Ptr) return Boolean is + Self_ID : constant Task_ID := Self; + P : Lock_Ptr; + + begin + Lock_Count := Lock_Count + 1; + + -- There should be no owner for this lock at this point + + if L.Owner /= null then + return False; + end if; + + -- Record new owner + + L.Owner := To_Owner_ID (To_Address (Self_ID)); + + if Single_Lock then + return True; + end if; + + -- Check that TCB lock order rules are satisfied + + P := Self_ID.Common.LL.Locks; + + if P /= null then + L.Next := P; + end if; + + Self_ID.Common.LL.Locking := null; + Self_ID.Common.LL.Locks := L; + return True; + end Record_Lock; + + ----------------- + -- Check_Sleep -- + ----------------- + + function Check_Sleep (Reason : Task_States) return Boolean is + pragma Unreferenced (Reason); + + Self_ID : constant Task_ID := Self; + P : Lock_Ptr; + + begin + -- Check that caller is abort-deferred + + if Self_ID.Deferral_Level <= 0 then + return False; + end if; + + if Single_Lock then + return True; + end if; + + -- Check that caller is holding own lock, on top of list + + if Self_ID.Common.LL.Locks /= + To_Lock_Ptr (Self_ID.Common.LL.L'Access) + then + return False; + end if; + + -- Check that TCB lock order rules are satisfied + + if Self_ID.Common.LL.Locks.Next /= null then + return False; + end if; + + Self_ID.Common.LL.L.Owner := null; + P := Self_ID.Common.LL.Locks; + Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next; + P.Next := null; + return True; + end Check_Sleep; + + ------------------- + -- Record_Wakeup -- + ------------------- + + function Record_Wakeup + (L : Lock_Ptr; + Reason : Task_States) return Boolean + is + pragma Unreferenced (Reason); + + Self_ID : constant Task_ID := Self; + P : Lock_Ptr; + + begin + -- Record new owner + + L.Owner := To_Owner_ID (To_Address (Self_ID)); + + if Single_Lock then + return True; + end if; + + -- Check that TCB lock order rules are satisfied + + P := Self_ID.Common.LL.Locks; + + if P /= null then + L.Next := P; + end if; + + Self_ID.Common.LL.Locking := null; + Self_ID.Common.LL.Locks := L; + return True; + end Record_Wakeup; + + ------------------ + -- Check_Wakeup -- + ------------------ + + function Check_Wakeup + (T : Task_ID; + Reason : Task_States) return Boolean + is + Self_ID : constant Task_ID := Self; + + begin + -- Is caller holding T's lock? + + if T.Common.LL.L.Owner /= To_Owner_ID (To_Address (Self_ID)) then + return False; + end if; + + -- Are reasons for wakeup and sleep consistent? + + if T.Common.State /= Reason then + return False; + end if; + + return True; + end Check_Wakeup; + + ------------------ + -- Check_Unlock -- + ------------------ + + function Check_Unlock (L : Lock_Ptr) return Boolean is + Self_ID : constant Task_ID := Self; + P : Lock_Ptr; + + begin + Unlock_Count := Unlock_Count + 1; + + if L = null then + return False; + end if; + + if L.Buddy /= null then + return False; + end if; + + if L.Level = 4 then + Check_Count := Unlock_Count; + end if; + + if Unlock_Count - Check_Count > 1000 then + Check_Count := Unlock_Count; + end if; + + -- Check that caller is abort-deferred + + if Self_ID.Deferral_Level <= 0 then + return False; + end if; + + -- Check that caller is holding this lock, on top of list + + if Self_ID.Common.LL.Locks /= L then + return False; + end if; + + -- Record there is no owner now + + L.Owner := null; + P := Self_ID.Common.LL.Locks; + Self_ID.Common.LL.Locks := Self_ID.Common.LL.Locks.Next; + P.Next := null; + return True; + end Check_Unlock; + + -------------------- + -- Check_Finalize -- + -------------------- + + function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is + Self_ID : constant Task_ID := Self; + + begin + -- Check that caller is abort-deferred + + if Self_ID.Deferral_Level <= 0 then + return False; + end if; + + -- Check that no one is holding this lock + + if L.Owner /= null then + return False; + end if; + + L.Frozen := True; + return True; + end Check_Finalize_Lock; + + ---------------- + -- Check_Exit -- + ---------------- + + function Check_Exit (Self_ID : Task_ID) return Boolean is + begin + -- Check that caller is just holding Global_Task_Lock + -- and no other locks + + if Self_ID.Common.LL.Locks = null then + return False; + end if; + + -- 2 = Global_Task_Level + + if Self_ID.Common.LL.Locks.Level /= 2 then + return False; + end if; + + if Self_ID.Common.LL.Locks.Next /= null then + return False; + end if; + + -- Check that caller is abort-deferred + + if Self_ID.Deferral_Level <= 0 then + return False; + end if; + + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : Task_ID) return Boolean is + begin + return Self_ID.Common.LL.Locks = null; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_ID is + begin + return Environment_Task_ID; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= Thread_Self then + return thr_suspend (T.Common.LL.Thread) = 0; + else + return True; + end if; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) return Boolean + is + begin + if T.Common.LL.Thread /= Thread_Self then + return thr_continue (T.Common.LL.Thread) = 0; + else + return True; + end if; + end Resume_Task; + +-- Package elaboration + +begin + declare + Result : Interfaces.C.int; + + begin + -- Mask Environment task for all signals. The original mask of the + -- Environment task will be recovered by Interrupt_Server task + -- during the elaboration of s-interr.adb. + + System.Interrupt_Management.Operations.Set_Interrupt_Mask + (System.Interrupt_Management.Operations.All_Tasks_Mask'Access); + + -- Prepare the set of signals that should unblocked in all tasks + + Result := sigemptyset (Unblocked_Signal_Mask'Access); + pragma Assert (Result = 0); + + for J in Interrupt_Management.Interrupt_ID loop + if System.Interrupt_Management.Keep_Unmasked (J) then + Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + + -- We need the following code to support automatic creation of fake + -- ATCB's for C threads that call the Ada run-time system, even if + -- we use a faster way of getting Self for real Ada tasks. + + Result := thr_keycreate (ATCB_Key'Access, System.Null_Address); + pragma Assert (Result = 0); + end; + + if Dispatching_Policy = 'F' then + declare + Result : Interfaces.C.long; + Class_Info : aliased struct_pcinfo; + Secs, Nsecs : Interfaces.C.long; + + begin + -- If a pragma Time_Slice is specified, takes the value in account. + + if Time_Slice_Val > 0 then + -- Convert Time_Slice_Val (microseconds) into seconds and + -- nanoseconds + + Secs := Time_Slice_Val / 1_000_000; + Nsecs := (Time_Slice_Val rem 1_000_000) * 1_000; + + -- Otherwise, default to no time slicing (i.e run until blocked) + + else + Secs := RT_TQINF; + Nsecs := RT_TQINF; + end if; + + -- Get the real time class id. + + Class_Info.pc_clname (1) := 'R'; + Class_Info.pc_clname (2) := 'T'; + Class_Info.pc_clname (3) := ASCII.NUL; + + Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_GETCID, + Class_Info'Address); + + -- Request the real time class + + Prio_Param.pc_cid := Class_Info.pc_cid; + Prio_Param.rt_pri := pri_t (Class_Info.rt_maxpri); + Prio_Param.rt_tqsecs := Secs; + Prio_Param.rt_tqnsecs := Nsecs; + + Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_SETPARMS, + Prio_Param'Address); + + Using_Real_Time_Class := Result /= -1; + end; + end if; +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb new file mode 100644 index 00000000000..1fa1c22fa4b --- /dev/null +++ b/gcc/ada/s-taprop-tru64.adb @@ -0,0 +1,1136 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 a DEC Unix 4.0d version of this package + +-- This package contains all the GNULL primitives that interface directly +-- with the underlying OS. + +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.Tasking.Debug; +-- used for Known_Tasks + +with System.Task_Info; +-- used for Task_Info_Type + +with Interfaces; +-- used for Shift_Left + +with Interfaces.C; +-- used for int +-- size_t + +with System.Interrupt_Management; +-- used for Keep_Unmasked +-- Abort_Task_Interrupt +-- Interrupt_ID + +with System.Interrupt_Management.Operations; +-- used for Set_Interrupt_Mask +-- All_Tasks_Mask +pragma Elaborate_All (System.Interrupt_Management.Operations); + +with System.Parameters; +-- used for Size_Type + +with System.Tasking; +-- used for Ada_Task_Control_Block +-- Task_ID +-- ATCB components and types + +with System.Soft_Links; +-- used for Defer/Undefer_Abort + +-- Note that we do not use System.Tasking.Initialization directly since +-- this is a higher level package that we shouldn't depend on. For example +-- when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Initialization + +with System.OS_Primitives; +-- used for Delay_Modes + +with Unchecked_Deallocation; + +package body System.Task_Primitives.Operations is + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + + package SSL renames System.Soft_Links; + + ---------------- + -- Local Data -- + ---------------- + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_ID associated with a thread + + Environment_Task_ID : Task_ID; + -- A variable to hold Task_ID for the environment task. + + Unblocked_Signal_Mask : aliased sigset_t; + -- The set of signals that should unblocked in all tasks + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; + -- Indicates whether FIFO_Within_Priorities is set. + + Curpid : pid_t; + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads). + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_ID); + pragma Inline (Initialize); + -- Initialize various data needed by this package. + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_ID); + pragma Inline (Set); + -- Set the self id for the current task. + + function Self return Task_ID; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task. + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific. + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; + -- Allocate and Initialize a new ATCB for the current Thread. + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_ID is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Abort_Handler (Sig : Signal); + -- Signal handler used to implement asynchronous abortion. + + ------------------- + -- Abort_Handler -- + ------------------- + + procedure Abort_Handler (Sig : Signal) is + pragma Unreferenced (Sig); + + T : constant Task_ID := Self; + Result : Interfaces.C.int; + Old_Set : aliased sigset_t; + + begin + -- It is not safe to raise an exception when using ZCX and the GCC + -- exception handling mechanism. + + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + + if T.Deferral_Level = 0 + and then T.Pending_ATC_Level < T.ATC_Nesting_Level and then + not T.Aborting + then + T.Aborting := True; + + -- Make sure signals used for RTS internal purpose are unmasked + + Result := pthread_sigmask (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + ------------------ + -- Stack_Guard -- + ------------------ + + -- The underlying thread system sets a guard page at the + -- bottom of a thread stack, so nothing is needed. + + procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Unreferenced (T); + pragma Unreferenced (On); + + begin + null; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID renames Specific.Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are + -- initialized in Initialize_TCB and the Storage_Error is + -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) + -- used in RTS is initialized before any status change of RTS. + -- Therefore rasing Storage_Error in the following routines + -- should be able to be handled safely. + + procedure Initialize_Lock + (Prio : System.Any_Priority; + L : access Lock) + is + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + if Locking_Policy = 'C' then + L.Ceiling := Interfaces.C.int (Prio); + end if; + + Result := pthread_mutex_init (L.L'Access, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutex_init (L, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + Result := pthread_mutexattr_destroy (Attributes'Access); + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L.L'Access); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + Result : Interfaces.C.int; + Self_ID : Task_ID; + All_Tasks_Link : Task_ID; + Current_Prio : System.Any_Priority; + + begin + -- Perform ceiling checks only when this is the locking policy in use. + + if Locking_Policy = 'C' then + Self_ID := Self; + All_Tasks_Link := Self_ID.Common.All_Tasks_Link; + Current_Prio := Get_Priority (Self_ID); + + -- If there is no other task, no need to check priorities + + if All_Tasks_Link /= Null_Task + and then L.Ceiling < Interfaces.C.int (Current_Prio) + then + Ceiling_Violation := True; + return; + end if; + end if; + + Result := pthread_mutex_lock (L.L'Access); + pragma Assert (Result = 0); + + Ceiling_Violation := False; + end Write_Lock; + + procedure Write_Lock + (L : access RTS_Lock; Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_ID) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_unlock (L.L'Access); + pragma Assert (Result = 0); + end Unlock; + + procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_ID) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_ID; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + + Result : Interfaces.C.int; + + begin + if Single_Lock then + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + else + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + end if; + + -- EINTR is not considered a failure. + + pragma Assert (Result = 0 or else Result = EINTR); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is + -- assumed to be already deferred, and the caller should be + -- holding its own ATCB lock. + + procedure Timed_Sleep + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Check_Time : constant Duration := Monotonic_Clock; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + Timedout := True; + Yielded := False; + + if Mode = Relative then + Abs_Time := Duration'Min (Time, Max_Sensible_Delay) + Check_Time; + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + end if; + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + + loop + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + or else Self_ID.Pending_Priority_Change; + + if Single_Lock then + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, + Request'Access); + + else + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, + Request'Access); + end if; + + exit when Abs_Time <= Monotonic_Clock; + + if Result = 0 or Result = EINTR then + + -- Somebody may have called Wakeup for us + + Timedout := False; + exit; + end if; + + pragma Assert (Result = ETIMEDOUT); + end loop; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + -- This is for use in implementing delay statements, so + -- we assume the caller is abort-deferred but is holding + -- no locks. + + procedure Timed_Delay + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes) + is + Check_Time : constant Duration := Monotonic_Clock; + Abs_Time : Duration; + Request : aliased timespec; + Result : Interfaces.C.int; + + begin + -- Only the little window between deferring abort and + -- locking Self_ID is the reason we need to + -- check for pending abort and priority change below! :( + + SSL.Abort_Defer.all; + + if Single_Lock then + Lock_RTS; + end if; + + Write_Lock (Self_ID); + + if Mode = Relative then + Abs_Time := Time + Check_Time; + else + Abs_Time := Duration'Min (Check_Time + Max_Sensible_Delay, Time); + end if; + + if Abs_Time > Check_Time then + Request := To_Timespec (Abs_Time); + Self_ID.Common.State := Delay_Sleep; + + loop + if Self_ID.Pending_Priority_Change then + Self_ID.Pending_Priority_Change := False; + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + end if; + + exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + if Single_Lock then + Result := pthread_cond_timedwait + (Self_ID.Common.LL.CV'Access, + Single_RTS_Lock'Access, + Request'Access); + else + Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access, + Self_ID.Common.LL.L'Access, Request'Access); + end if; + + exit when Abs_Time <= Monotonic_Clock; + + pragma Assert (Result = 0 or else + Result = ETIMEDOUT or else + Result = EINTR); + end loop; + + Self_ID.Common.State := Runnable; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + Yield; + SSL.Abort_Undefer.all; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + Result : Interfaces.C.int; + + begin + Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (TS); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 1.0 / 1024.0; -- Clock on DEC Alpha ticks at 1024 Hz + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin + if Do_Yield then + Result := sched_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_ID; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + pragma Unreferenced (Loss_Of_Inheritance); + + Result : Interfaces.C.int; + Param : aliased struct_sched_param; + + begin + T.Common.Current_Priority := Prio; + Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); + + if Time_Slice_Val > 0 then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); + + elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + + else + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + end if; + + pragma Assert (Result = 0); + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_ID) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_ID) is + begin + Self_ID.Common.LL.Thread := pthread_self; + Specific.Set (Self_ID); + + Lock_RTS; + + for J in Known_Tasks'Range loop + if Known_Tasks (J) = null then + Known_Tasks (J) := Self_ID; + Self_ID.Known_Tasks_Index := J; + exit; + end if; + end loop; + + Unlock_RTS; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + + begin + if not Single_Lock then + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := pthread_mutex_init + (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := pthread_cond_init + (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + else + if not Single_Lock then + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_ID; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Attributes : aliased pthread_attr_t; + Adjusted_Stack_Size : Interfaces.C.size_t; + Result : Interfaces.C.int; + Param : aliased System.OS_Interface.struct_sched_param; + + use System.Task_Info; + + begin + if Stack_Size = Unspecified_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size); + + elsif Stack_Size < Minimum_Stack_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); + + else + Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); + end if; + + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); + pragma Assert (Result = 0); + + Result := pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); + pragma Assert (Result = 0); + + Param.sched_priority := + Interfaces.C.int (Underlying_Priorities (Priority)); + Result := pthread_attr_setschedparam + (Attributes'Access, Param'Access); + pragma Assert (Result = 0); + + if Time_Slice_Val > 0 then + Result := pthread_attr_setschedpolicy + (Attributes'Access, System.OS_Interface.SCHED_RR); + + elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then + Result := pthread_attr_setschedpolicy + (Attributes'Access, System.OS_Interface.SCHED_FIFO); + + else + Result := pthread_attr_setschedpolicy + (Attributes'Access, System.OS_Interface.SCHED_OTHER); + end if; + + pragma Assert (Result = 0); + + -- Set the scheduling parameters explicitly, since this is the + -- only way to force the OS to take e.g. the sched policy and scope + -- attributes into account. + + Result := pthread_attr_setinheritsched + (Attributes'Access, PTHREAD_EXPLICIT_SCHED); + pragma Assert (Result = 0); + + T.Common.Current_Priority := Priority; + + if T.Common.Task_Info /= null then + case T.Common.Task_Info.Contention_Scope is + when System.Task_Info.Process_Scope => + Result := pthread_attr_setscope + (Attributes'Access, PTHREAD_SCOPE_PROCESS); + + when System.Task_Info.System_Scope => + Result := pthread_attr_setscope + (Attributes'Access, PTHREAD_SCOPE_SYSTEM); + + when System.Task_Info.Default_Scope => + Result := 0; + end case; + + pragma Assert (Result = 0); + end if; + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + Result := pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + pragma Assert (Result = 0 or else Result = EAGAIN); + + Succeeded := Result = 0; + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + + if T.Common.Task_Info /= null then + -- ??? We're using a process-wide function to implement a task + -- specific characteristic. + + if T.Common.Task_Info.Bind_To_Cpu_Number = 0 then + Result := bind_to_cpu (Curpid, 0); + elsif T.Common.Task_Info.Bind_To_Cpu_Number > 0 then + Result := bind_to_cpu + (Curpid, + Interfaces.C.unsigned_long ( + Interfaces.Shift_Left + (Interfaces.Unsigned_64'(1), + T.Common.Task_Info.Bind_To_Cpu_Number - 1))); + pragma Assert (Result = 0); + end if; + end if; + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_ID) is + Result : Interfaces.C.int; + Tmp : Task_ID := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); + + begin + if not Single_Lock then + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_ID) is + Result : Interfaces.C.int; + begin + Result := + pthread_kill + (T.Common.LL.Thread, + Signal (System.Interrupt_Management.Abort_Task_Interrupt)); + pragma Assert (Result = 0); + end Abort_Task; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_ID is + begin + return Environment_Task_ID; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) return Boolean + is + pragma Warnings (Off, T); + pragma Warnings (Off, Thread_Self); + + begin + return False; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) return Boolean + is + pragma Warnings (Off, T); + pragma Warnings (Off, Thread_Self); + + begin + return False; + end Resume_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : Interfaces.C.int; + + function State + (Int : System.Interrupt_Management.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: + + 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 + Environment_Task_ID := Environment_Task; + + -- Initialize the lock used to synchronize chain of all ATCBs. + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Specific.Initialize (Environment_Task); + + Enter_Task (Environment_Task); + + -- Install the abort-signal handler + + if State (System.Interrupt_Management.Abort_Task_Interrupt) + /= Default + then + act.sa_flags := 0; + act.sa_handler := Abort_Handler'Address; + + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction + (Signal (System.Interrupt_Management.Abort_Task_Interrupt), + act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + end if; + end Initialize; + +begin + declare + Result : Interfaces.C.int; + + begin + -- Mask Environment task for all signals. The original mask of the + -- Environment task will be recovered by Interrupt_Server task + -- during the elaboration of s-interr.adb. + + System.Interrupt_Management.Operations.Set_Interrupt_Mask + (System.Interrupt_Management.Operations.All_Tasks_Mask'Access); + + -- Prepare the set of signals that should unblocked in all tasks + + Result := sigemptyset (Unblocked_Signal_Mask'Access); + pragma Assert (Result = 0); + + for J in Interrupt_Management.Interrupt_ID loop + if System.Interrupt_Management.Keep_Unmasked (J) then + Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + end; + + Curpid := getpid; +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb new file mode 100644 index 00000000000..5a7739d3abc --- /dev/null +++ b/gcc/ada/s-taprop-vms.adb @@ -0,0 +1,1005 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 a OpenVMS/Alpha version of this package + +-- This package contains all the GNULL primitives that interface directly +-- with the underlying OS. + +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.Tasking.Debug; +-- used for Known_Tasks + +with Interfaces.C; +-- used for int +-- size_t + +with System.Parameters; +-- used for Size_Type + +with System.Tasking; +-- used for Ada_Task_Control_Block +-- Task_ID + +with System.Soft_Links; +-- used for Defer/Undefer_Abort +-- Set_Exc_Stack_Addr + +-- Note that we do not use System.Tasking.Initialization directly since +-- this is a higher level package that we shouldn't depend on. For example +-- when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Initialization + +with System.OS_Primitives; +-- used for Delay_Modes + +with Unchecked_Conversion; +with Unchecked_Deallocation; + +package body System.Task_Primitives.Operations is + + use System.Tasking.Debug; + use System.Tasking; + use Interfaces.C; + use System.OS_Interface; + use System.Parameters; + use System.OS_Primitives; + use type System.OS_Primitives.OS_Time; + + package SSL renames System.Soft_Links; + + ------------------ + -- Local Data -- + ------------------ + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + ATCB_Key : aliased pthread_key_t; + -- Key used to find the Ada Task_ID associated with a thread + + Environment_Task_ID : Task_ID; + -- A variable to hold Task_ID for the environment task. + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; + -- Indicates whether FIFO_Within_Priorities is set. + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads). + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + procedure Initialize (Environment_Task : Task_ID); + pragma Inline (Initialize); + -- Initialize various data needed by this package. + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_ID); + pragma Inline (Set); + -- Set the self id for the current task + + function Self return Task_ID; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific. + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; + -- Allocate and Initialize a new ATCB for the current Thread + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_ID is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID); + + function To_Address is new Unchecked_Conversion (Task_ID, System.Address); + + procedure Timer_Sleep_AST (ID : Address); + -- Signal the condition variable when AST fires. + + procedure Timer_Sleep_AST (ID : Address) is + Result : Interfaces.C.int; + Self_ID : constant Task_ID := To_Task_ID (ID); + begin + Self_ID.Common.LL.AST_Pending := False; + Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Timer_Sleep_AST; + + ----------------- + -- Stack_Guard -- + ----------------- + + -- The underlying thread system sets a guard page at the + -- bottom of a thread stack, so nothing is needed. + -- ??? Check the comment above + + procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Unreferenced (T); + pragma Unreferenced (On); + begin + null; + end Stack_Guard; + + -------------------- + -- Get_Thread_Id -- + -------------------- + + function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID renames Specific.Self; + + --------------------- + -- Initialize_Lock -- + --------------------- + + -- Note: mutexes and cond_variables needed per-task basis are + -- initialized in Initialize_TCB and the Storage_Error is + -- handled. Other mutexes (such as RTS_Lock, Memory_Lock...) + -- used in RTS is initialized before any status change of RTS. + -- Therefore rasing Storage_Error in the following routines + -- should be able to be handled safely. + + procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + L.Prio_Save := 0; + L.Prio := Interfaces.C.int (Prio); + + Result := pthread_mutex_init (L.L'Access, Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + + Attributes : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + + begin + Result := pthread_mutexattr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + +-- Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes??? +-- Result := pthread_mutexattr_settype_np +-- (Attributes'Access, PTHREAD_MUTEX_ERRORCHECK_NP); +-- pragma Assert (Result = 0); + +-- Result := pthread_mutexattr_setprotocol +-- (Attributes'Access, PTHREAD_PRIO_PROTECT); +-- pragma Assert (Result = 0); + +-- Result := pthread_mutexattr_setprioceiling +-- (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); +-- pragma Assert (Result = 0); + + Result := pthread_mutex_init (L, Attributes'Access); + + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = ENOMEM then + raise Storage_Error; + end if; + + Result := pthread_mutexattr_destroy (Attributes'Access); + pragma Assert (Result = 0); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L.L'Access); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : access RTS_Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_destroy (L); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + Self_ID : constant Task_ID := Self; + All_Tasks_Link : constant Task_ID := Self.Common.All_Tasks_Link; + Current_Prio : System.Any_Priority; + Result : Interfaces.C.int; + + begin + Current_Prio := Get_Priority (Self_ID); + + -- If there is no other tasks, no need to check priorities + + if All_Tasks_Link /= Null_Task + and then L.Prio < Interfaces.C.int (Current_Prio) + then + Ceiling_Violation := True; + return; + end if; + + Result := pthread_mutex_lock (L.L'Access); + pragma Assert (Result = 0); + + Ceiling_Violation := False; +-- Why is this commented out ??? +-- L.Prio_Save := Interfaces.C.int (Current_Prio); +-- Set_Priority (Self_ID, System.Any_Priority (L.Prio)); + end Write_Lock; + + procedure Write_Lock + (L : access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_lock (L); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_ID) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_lock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : access Lock) is + Result : Interfaces.C.int; + begin + Result := pthread_mutex_unlock (L.L'Access); + pragma Assert (Result = 0); + end Unlock; + + procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is + Result : Interfaces.C.int; + begin + if not Single_Lock or else Global_Lock then + Result := pthread_mutex_unlock (L); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_ID) is + Result : Interfaces.C.int; + begin + if not Single_Lock then + Result := pthread_mutex_unlock (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep + (Self_ID : Task_ID; + Reason : System.Tasking.Task_States) + is + pragma Unreferenced (Reason); + Result : Interfaces.C.int; + + begin + if Single_Lock then + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + else + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + end if; + + -- EINTR is not considered a failure + + pragma Assert (Result = 0 or else Result = EINTR); + + if Self_ID.Deferral_Level = 0 + and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + then + Unlock (Self_ID); + raise Standard'Abort_Signal; + end if; + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + procedure Timed_Sleep + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Sleep_Time : OS_Time; + Result : Interfaces.C.int; + Status : Cond_Value_Type; + + -- The body below requires more comments ??? + + begin + Timedout := False; + Yielded := False; + + Sleep_Time := To_OS_Time (Time, Mode); + + if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + or else Self_ID.Pending_Priority_Change + then + return; + end if; + + Self_ID.Common.LL.AST_Pending := True; + + Sys_Setimr + (Status, 0, Sleep_Time, + Timer_Sleep_AST'Access, To_Address (Self_ID), 0); + + if (Status and 1) /= 1 then + raise Storage_Error; + end if; + + if Single_Lock then + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + pragma Assert (Result = 0); + + else + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Yielded := True; + + if not Self_ID.Common.LL.AST_Pending then + Timedout := True; + else + Sys_Cantim (Status, To_Address (Self_ID), 0); + pragma Assert ((Status and 1) = 1); + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes) + is + Sleep_Time : OS_Time; + Result : Interfaces.C.int; + Status : Cond_Value_Type; + Yielded : Boolean := False; + + begin + -- Only the little window between deferring abort and + -- locking Self_ID is the reason we need to + -- check for pending abort and priority change below! + + if Single_Lock then + Lock_RTS; + end if; + + -- More comments required in body below ??? + + SSL.Abort_Defer.all; + Write_Lock (Self_ID); + + if Time /= 0.0 or else Mode /= Relative then + Sleep_Time := To_OS_Time (Time, Mode); + + if Mode = Relative or else OS_Clock < Sleep_Time then + Self_ID.Common.State := Delay_Sleep; + Self_ID.Common.LL.AST_Pending := True; + + Sys_Setimr + (Status, 0, Sleep_Time, + Timer_Sleep_AST'Access, To_Address (Self_ID), 0); + + if (Status and 1) /= 1 then + raise Storage_Error; + end if; + + loop + if Self_ID.Pending_Priority_Change then + Self_ID.Pending_Priority_Change := False; + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + end if; + + if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then + Sys_Cantim (Status, To_Address (Self_ID), 0); + pragma Assert ((Status and 1) = 1); + exit; + end if; + + if Single_Lock then + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); + pragma Assert (Result = 0); + else + Result := pthread_cond_wait + (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Yielded := True; + + exit when not Self_ID.Common.LL.AST_Pending; + end loop; + + Self_ID.Common.State := Runnable; + end if; + end if; + + Unlock (Self_ID); + + if Single_Lock then + Unlock_RTS; + end if; + + if not Yielded then + Result := sched_yield; + pragma Assert (Result = 0); + end if; + + SSL.Abort_Undefer.all; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration + renames System.OS_Primitives.Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 10#1.0#E-3; + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + + Result : Interfaces.C.int; + + begin + Result := pthread_cond_signal (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + Result : Interfaces.C.int; + pragma Unreferenced (Result); + begin + if Do_Yield then + Result := sched_yield; + end if; + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + procedure Set_Priority + (T : Task_ID; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + pragma Unreferenced (Loss_Of_Inheritance); + + Result : Interfaces.C.int; + Param : aliased struct_sched_param; + + begin + T.Common.Current_Priority := Prio; + Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); + + if Time_Slice_Val > 0 then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_RR, Param'Access); + + elsif FIFO_Within_Priorities or else Time_Slice_Val = 0 then + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_FIFO, Param'Access); + + else + -- SCHED_OTHER priorities are restricted to the range 8 - 15. + -- Since the translation from Underlying priorities results + -- in a range of 16 - 31, dividing by 2 gives the correct result. + + Param.sched_priority := Param.sched_priority / 2; + Result := pthread_setschedparam + (T.Common.LL.Thread, SCHED_OTHER, Param'Access); + end if; + + pragma Assert (Result = 0); + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_ID) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_ID) is + begin + Self_ID.Common.LL.Thread := pthread_self; + + Specific.Set (Self_ID); + + Lock_RTS; + + for J in Known_Tasks'Range loop + if Known_Tasks (J) = null then + Known_Tasks (J) := Self_ID; + Self_ID.Known_Tasks_Index := J; + exit; + end if; + end loop; + + Unlock_RTS; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (pthread_self); + end if; + end Register_Foreign_Thread; + + ---------------------- + -- Initialize_TCB -- + ---------------------- + + procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is + Mutex_Attr : aliased pthread_mutexattr_t; + Result : Interfaces.C.int; + Cond_Attr : aliased pthread_condattr_t; + + begin + -- More comments required in body below ??? + + if not Single_Lock then + Result := pthread_mutexattr_init (Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := pthread_mutex_init (Self_ID.Common.LL.L'Access, + Mutex_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_mutexattr_destroy (Mutex_Attr'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_condattr_init (Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result = 0 then + Result := pthread_cond_init (Self_ID.Common.LL.CV'Access, + Cond_Attr'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + end if; + + if Result = 0 then + Succeeded := True; + Self_ID.Common.LL.Exc_Stack_Ptr := new Exc_Stack_T; + SSL.Set_Exc_Stack_Addr + (To_Address (Self_ID), + Self_ID.Common.LL.Exc_Stack_Ptr (Exc_Stack_T'Last)'Address); + + else + if not Single_Lock then + Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Succeeded := False; + end if; + + Result := pthread_condattr_destroy (Cond_Attr'Access); + pragma Assert (Result = 0); + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_ID; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Attributes : aliased pthread_attr_t; + Adjusted_Stack_Size : Interfaces.C.size_t; + Result : Interfaces.C.int; + + function Thread_Body_Access is new + Unchecked_Conversion (System.Address, Thread_Body); + + begin + if Stack_Size = Unspecified_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Default_Stack_Size); + + elsif Stack_Size < Minimum_Stack_Size then + Adjusted_Stack_Size := Interfaces.C.size_t (Minimum_Stack_Size); + + else + Adjusted_Stack_Size := Interfaces.C.size_t (Stack_Size); + end if; + + -- Since the initial signal mask of a thread is inherited from the + -- creator, we need to set our local signal mask mask all signals + -- during the creation operation, to make sure the new thread is + -- not disturbed by signals before it has set its own Task_ID. + + Result := pthread_attr_init (Attributes'Access); + pragma Assert (Result = 0 or else Result = ENOMEM); + + if Result /= 0 then + Succeeded := False; + return; + end if; + + Result := pthread_attr_setdetachstate + (Attributes'Access, PTHREAD_CREATE_DETACHED); + pragma Assert (Result = 0); + + Result := pthread_attr_setstacksize + (Attributes'Access, Adjusted_Stack_Size); + pragma Assert (Result = 0); + + -- This call may be unnecessary, not sure. ??? + + Result := + pthread_attr_setinheritsched + (Attributes'Access, PTHREAD_EXPLICIT_SCHED); + pragma Assert (Result = 0); + + Result := pthread_create + (T.Common.LL.Thread'Access, + Attributes'Access, + Thread_Body_Access (Wrapper), + To_Address (T)); + + -- ENOMEM is a valid run-time error. Don't shut down. + + pragma Assert (Result = 0 + or else Result = EAGAIN or else Result = ENOMEM); + + Succeeded := Result = 0; + + Result := pthread_attr_destroy (Attributes'Access); + pragma Assert (Result = 0); + + if Succeeded then + Set_Priority (T, Priority); + end if; + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_ID) is + Result : Interfaces.C.int; + Tmp : Task_ID := T; + Is_Self : constant Boolean := T = Self; + + procedure Free is new + Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); + + procedure Free is new Unchecked_Deallocation + (Exc_Stack_T, Exc_Stack_Ptr_T); + + begin + if not Single_Lock then + Result := pthread_mutex_destroy (T.Common.LL.L'Access); + pragma Assert (Result = 0); + end if; + + Result := pthread_cond_destroy (T.Common.LL.CV'Access); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (T.Common.LL.Exc_Stack_Ptr); + + Free (Tmp); + + if Is_Self then + Specific.Set (null); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_ID) is + begin + -- Interrupt Server_Tasks may be waiting on an event flag + + if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then + Wakeup (T, Interrupt_Server_Blocked_On_Event_Flag); + end if; + end Abort_Task; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_ID is + begin + return Environment_Task_ID; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + + begin + return False; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) return Boolean + is + pragma Unreferenced (T); + pragma Unreferenced (Thread_Self); + begin + return False; + end Resume_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + begin + Environment_Task_ID := Environment_Task; + + -- Initialize the lock used to synchronize chain of all ATCBs + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Specific.Initialize (Environment_Task); + + Enter_Task (Environment_Task); + end Initialize; + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb new file mode 100644 index 00000000000..8bbbf0e13b0 --- /dev/null +++ b/gcc/ada/s-taprop-vxworks.adb @@ -0,0 +1,1144 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . O P E R A T I O N S -- +-- -- +-- 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 VxWorks version of this package + +-- This package contains all the GNULL primitives that interface directly +-- with the underlying OS. + +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.Tasking.Debug; +-- used for Known_Tasks + +with System.Interrupt_Management; +-- used for Keep_Unmasked +-- Abort_Task_Signal +-- Signal_ID +-- Initialize_Interrupts + +with System.Soft_Links; +-- used for Defer/Undefer_Abort + +-- Note that we do not use System.Tasking.Initialization directly since +-- this is a higher level package that we shouldn't depend on. For example +-- when using the restricted run time, it is replaced by +-- System.Tasking.Restricted.Initialization + +with System.OS_Interface; +-- used for various type, constant, and operations + +with System.Parameters; +-- used for Size_Type + +with System.Tasking; +-- used for Ada_Task_Control_Block +-- Task_ID +-- ATCB components and types + +with Interfaces.C; + +with Unchecked_Conversion; +with Unchecked_Deallocation; + +package body System.Task_Primitives.Operations is + + use System.Tasking.Debug; + use System.Tasking; + use System.OS_Interface; + use System.Parameters; + use type Interfaces.C.int; + + package SSL renames System.Soft_Links; + + subtype int is System.OS_Interface.int; + + Relative : constant := 0; + + ---------------- + -- Local Data -- + ---------------- + + -- The followings are logically constants, but need to be initialized + -- at run time. + + Single_RTS_Lock : aliased RTS_Lock; + -- This is a lock to allow only one thread of control in the RTS at + -- a time; it is used to execute in mutual exclusion from all other tasks. + -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List + + ATCB_Key : aliased System.Address := System.Null_Address; + -- Key used to find the Ada Task_ID associated with a thread + + ATCB_Key_Addr : System.Address := ATCB_Key'Address; + pragma Export (Ada, ATCB_Key_Addr, "__gnat_ATCB_key_addr"); + -- Exported to support the temporary AE653 task registration + -- implementation. This mechanism is used to minimize impact on other + -- targets. + + Environment_Task_ID : Task_ID; + -- A variable to hold Task_ID for the environment task. + + Unblocked_Signal_Mask : aliased sigset_t; + -- The set of signals that should unblocked in all tasks + + -- The followings are internal configuration constants needed. + + Time_Slice_Val : Integer; + pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); + + Locking_Policy : Character; + pragma Import (C, Locking_Policy, "__gl_locking_policy"); + + Dispatching_Policy : Character; + pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); + + FIFO_Within_Priorities : constant Boolean := Dispatching_Policy = 'F'; + -- Indicates whether FIFO_Within_Priorities is set. + + Mutex_Protocol : Priority_Type; + + Foreign_Task_Elaborated : aliased Boolean := True; + -- Used to identified fake tasks (i.e., non-Ada Threads). + + -------------------- + -- Local Packages -- + -------------------- + + package Specific is + + function Is_Valid_Task return Boolean; + pragma Inline (Is_Valid_Task); + -- Does executing thread have a TCB? + + procedure Set (Self_Id : Task_ID); + pragma Inline (Set); + -- Set the self id for the current task. + + function Self return Task_ID; + pragma Inline (Self); + -- Return a pointer to the Ada Task Control Block of the calling task. + + end Specific; + + package body Specific is separate; + -- The body of this package is target specific. + + --------------------------------- + -- Support for foreign threads -- + --------------------------------- + + function Register_Foreign_Thread (Thread : Thread_Id) return Task_ID; + -- Allocate and Initialize a new ATCB for the current Thread. + + function Register_Foreign_Thread + (Thread : Thread_Id) return Task_ID is separate; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Abort_Handler (signo : Signal); + -- Handler for the abort (SIGABRT) signal to handle asynchronous abortion. + + procedure Install_Signal_Handlers; + -- Install the default signal handlers for the current task + + function To_Address is new Unchecked_Conversion (Task_ID, System.Address); + + ------------------- + -- Abort_Handler -- + ------------------- + + procedure Abort_Handler (signo : Signal) is + pragma Unreferenced (signo); + + Self_ID : constant Task_ID := Self; + Result : int; + Old_Set : aliased sigset_t; + + begin + -- It is not safe to raise an exception when using ZCX and the GCC + -- exception handling mechanism. + + if ZCX_By_Default and then GCC_ZCX_Support then + return; + end if; + + if Self_ID.Deferral_Level = 0 + and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level + and then not Self_ID.Aborting + then + Self_ID.Aborting := True; + + -- Make sure signals used for RTS internal purpose are unmasked + + Result := pthread_sigmask (SIG_UNBLOCK, + Unblocked_Signal_Mask'Unchecked_Access, Old_Set'Unchecked_Access); + pragma Assert (Result = 0); + + raise Standard'Abort_Signal; + end if; + end Abort_Handler; + + ----------------- + -- Stack_Guard -- + ----------------- + + procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is + pragma Unreferenced (T); + pragma Unreferenced (On); + + begin + -- Nothing needed (why not???) + + null; + end Stack_Guard; + + ------------------- + -- Get_Thread_Id -- + ------------------- + + function Get_Thread_Id (T : ST.Task_ID) return OSI.Thread_Id is + begin + return T.Common.LL.Thread; + end Get_Thread_Id; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID renames Specific.Self; + + ----------------------------- + -- Install_Signal_Handlers -- + ----------------------------- + + procedure Install_Signal_Handlers is + act : aliased struct_sigaction; + old_act : aliased struct_sigaction; + Tmp_Set : aliased sigset_t; + Result : int; + + begin + act.sa_flags := 0; + act.sa_handler := Abort_Handler'Address; + + Result := sigemptyset (Tmp_Set'Access); + pragma Assert (Result = 0); + act.sa_mask := Tmp_Set; + + Result := + sigaction + (Signal (Interrupt_Management.Abort_Task_Signal), + act'Unchecked_Access, + old_act'Unchecked_Access); + pragma Assert (Result = 0); + + Interrupt_Management.Initialize_Interrupts; + end Install_Signal_Handlers; + + --------------------- + -- Initialize_Lock -- + --------------------- + + procedure Initialize_Lock (Prio : System.Any_Priority; L : access Lock) is + begin + L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); + L.Prio_Ceiling := int (Prio); + L.Protocol := Mutex_Protocol; + pragma Assert (L.Mutex /= 0); + end Initialize_Lock; + + procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is + pragma Unreferenced (Level); + + begin + L.Mutex := semMCreate (SEM_Q_PRIORITY + SEM_INVERSION_SAFE); + L.Prio_Ceiling := int (System.Any_Priority'Last); + L.Protocol := Mutex_Protocol; + pragma Assert (L.Mutex /= 0); + end Initialize_Lock; + + ------------------- + -- Finalize_Lock -- + ------------------- + + procedure Finalize_Lock (L : access Lock) is + Result : int; + + begin + Result := semDelete (L.Mutex); + pragma Assert (Result = 0); + end Finalize_Lock; + + procedure Finalize_Lock (L : access RTS_Lock) is + Result : int; + + begin + Result := semDelete (L.Mutex); + pragma Assert (Result = 0); + end Finalize_Lock; + + ---------------- + -- Write_Lock -- + ---------------- + + procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + Result : int; + + begin + if L.Protocol = Prio_Protect + and then int (Self.Common.Current_Priority) > L.Prio_Ceiling + then + Ceiling_Violation := True; + return; + else + Ceiling_Violation := False; + end if; + + Result := semTake (L.Mutex, WAIT_FOREVER); + pragma Assert (Result = 0); + end Write_Lock; + + procedure Write_Lock + (L : access RTS_Lock; + Global_Lock : Boolean := False) + is + Result : int; + + begin + if not Single_Lock or else Global_Lock then + Result := semTake (L.Mutex, WAIT_FOREVER); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + procedure Write_Lock (T : Task_ID) is + Result : int; + + begin + if not Single_Lock then + Result := semTake (T.Common.LL.L.Mutex, WAIT_FOREVER); + pragma Assert (Result = 0); + end if; + end Write_Lock; + + --------------- + -- Read_Lock -- + --------------- + + procedure Read_Lock (L : access Lock; Ceiling_Violation : out Boolean) is + begin + Write_Lock (L, Ceiling_Violation); + end Read_Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (L : access Lock) is + Result : int; + + begin + Result := semGive (L.Mutex); + pragma Assert (Result = 0); + end Unlock; + + procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is + Result : int; + + begin + if not Single_Lock or else Global_Lock then + Result := semGive (L.Mutex); + pragma Assert (Result = 0); + end if; + end Unlock; + + procedure Unlock (T : Task_ID) is + Result : int; + + begin + if not Single_Lock then + Result := semGive (T.Common.LL.L.Mutex); + pragma Assert (Result = 0); + end if; + end Unlock; + + ----------- + -- Sleep -- + ----------- + + procedure Sleep (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + + Result : int; + + begin + pragma Assert (Self_ID = Self); + + -- Release the mutex before sleeping. + if Single_Lock then + Result := semGive (Single_RTS_Lock.Mutex); + else + Result := semGive (Self_ID.Common.LL.L.Mutex); + end if; + + pragma Assert (Result = 0); + + -- Perform a blocking operation to take the CV semaphore. + -- Note that a blocking operation in VxWorks will reenable + -- task scheduling. When we are no longer blocked and control + -- is returned, task scheduling will again be disabled. + + Result := semTake (Self_ID.Common.LL.CV, WAIT_FOREVER); + pragma Assert (Result = 0); + + -- Take the mutex back. + if Single_Lock then + Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); + else + Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); + end if; + + pragma Assert (Result = 0); + end Sleep; + + ----------------- + -- Timed_Sleep -- + ----------------- + + -- This is for use within the run-time system, so abort is + -- assumed to be already deferred, and the caller should be + -- holding its own ATCB lock. + + procedure Timed_Sleep + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes; + Reason : System.Tasking.Task_States; + Timedout : out Boolean; + Yielded : out Boolean) + is + pragma Unreferenced (Reason); + + Orig : constant Duration := Monotonic_Clock; + Absolute : Duration; + Ticks : int; + Result : int; + Wakeup : Boolean := False; + + begin + Timedout := False; + Yielded := True; + + if Mode = Relative then + Absolute := Orig + Time; + + -- Systematically add one since the first tick will delay + -- *at most* 1 / Rate_Duration seconds, so we need to add one to + -- be on the safe side. + + Ticks := To_Clock_Ticks (Time); + + if Ticks > 0 and then Ticks < int'Last then + Ticks := Ticks + 1; + end if; + + else + Absolute := Time; + Ticks := To_Clock_Ticks (Time - Monotonic_Clock); + end if; + + if Ticks > 0 then + loop + -- Release the mutex before sleeping. + if Single_Lock then + Result := semGive (Single_RTS_Lock.Mutex); + else + Result := semGive (Self_ID.Common.LL.L.Mutex); + end if; + + pragma Assert (Result = 0); + + -- Perform a blocking operation to take the CV semaphore. + -- Note that a blocking operation in VxWorks will reenable + -- task scheduling. When we are no longer blocked and control + -- is returned, task scheduling will again be disabled. + + Result := semTake (Self_ID.Common.LL.CV, Ticks); + + if Result = 0 then + -- Somebody may have called Wakeup for us + + Wakeup := True; + + else + if errno /= S_objLib_OBJ_TIMEOUT then + Wakeup := True; + else + -- If Ticks = int'last, it was most probably truncated + -- so let's make another round after recomputing Ticks + -- from the the absolute time. + + if Ticks /= int'Last then + Timedout := True; + else + Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); + + if Ticks < 0 then + Timedout := True; + end if; + end if; + end if; + end if; + + -- Take the mutex back. + if Single_Lock then + Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); + else + Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); + end if; + + pragma Assert (Result = 0); + + exit when Timedout or Wakeup; + end loop; + + else + Timedout := True; + + -- Should never hold a lock while yielding. + if Single_Lock then + Result := semGive (Single_RTS_Lock.Mutex); + taskDelay (0); + Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); + + else + Result := semGive (Self_ID.Common.LL.L.Mutex); + taskDelay (0); + Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); + end if; + end if; + end Timed_Sleep; + + ----------------- + -- Timed_Delay -- + ----------------- + + -- This is for use in implementing delay statements, so + -- we assume the caller is holding no locks. + + procedure Timed_Delay + (Self_ID : Task_ID; + Time : Duration; + Mode : ST.Delay_Modes) + is + Orig : constant Duration := Monotonic_Clock; + Absolute : Duration; + Ticks : int; + Timedout : Boolean; + Result : int; + Aborted : Boolean := False; + + begin + SSL.Abort_Defer.all; + + if Mode = Relative then + Absolute := Orig + Time; + Ticks := To_Clock_Ticks (Time); + + if Ticks > 0 and then Ticks < int'Last then + + -- The first tick will delay anytime between 0 and + -- 1 / sysClkRateGet seconds, so we need to add one to + -- be on the safe side. + + Ticks := Ticks + 1; + end if; + + else + Absolute := Time; + Ticks := To_Clock_Ticks (Time - Orig); + end if; + + if Ticks > 0 then + -- Modifying State and Pending_Priority_Change, locking the TCB. + if Single_Lock then + Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); + else + Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); + end if; + + pragma Assert (Result = 0); + + Self_ID.Common.State := Delay_Sleep; + Timedout := False; + + loop + if Self_ID.Pending_Priority_Change then + Self_ID.Pending_Priority_Change := False; + Self_ID.Common.Base_Priority := Self_ID.New_Base_Priority; + Set_Priority (Self_ID, Self_ID.Common.Base_Priority); + end if; + + Aborted := Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level; + + -- Release the TCB before sleeping + + if Single_Lock then + Result := semGive (Single_RTS_Lock.Mutex); + else + Result := semGive (Self_ID.Common.LL.L.Mutex); + end if; + pragma Assert (Result = 0); + + exit when Aborted; + + Result := semTake (Self_ID.Common.LL.CV, Ticks); + + if Result /= 0 then + -- If Ticks = int'last, it was most probably truncated + -- so let's make another round after recomputing Ticks + -- from the the absolute time. + + if errno = S_objLib_OBJ_TIMEOUT and then Ticks /= int'Last then + Timedout := True; + else + Ticks := To_Clock_Ticks (Absolute - Monotonic_Clock); + + if Ticks < 0 then + Timedout := True; + end if; + end if; + end if; + + -- Take back the lock after having slept, to protect further + -- access to Self_ID + + if Single_Lock then + Result := semTake (Single_RTS_Lock.Mutex, WAIT_FOREVER); + else + Result := semTake (Self_ID.Common.LL.L.Mutex, WAIT_FOREVER); + end if; + + pragma Assert (Result = 0); + + exit when Timedout; + end loop; + + Self_ID.Common.State := Runnable; + + if Single_Lock then + Result := semGive (Single_RTS_Lock.Mutex); + else + Result := semGive (Self_ID.Common.LL.L.Mutex); + end if; + + else + taskDelay (0); + end if; + + SSL.Abort_Undefer.all; + end Timed_Delay; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + TS : aliased timespec; + Result : int; + + begin + Result := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access); + pragma Assert (Result = 0); + return To_Duration (TS); + end Monotonic_Clock; + + ------------------- + -- RT_Resolution -- + ------------------- + + function RT_Resolution return Duration is + begin + return 1.0 / Duration (sysClkRateGet); + end RT_Resolution; + + ------------ + -- Wakeup -- + ------------ + + procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is + pragma Unreferenced (Reason); + + Result : int; + + begin + Result := semGive (T.Common.LL.CV); + pragma Assert (Result = 0); + end Wakeup; + + ----------- + -- Yield -- + ----------- + + procedure Yield (Do_Yield : Boolean := True) is + pragma Unreferenced (Do_Yield); + Result : int; + pragma Unreferenced (Result); + begin + Result := taskDelay (0); + end Yield; + + ------------------ + -- Set_Priority -- + ------------------ + + type Prio_Array_Type is array (System.Any_Priority) of Integer; + pragma Atomic_Components (Prio_Array_Type); + + Prio_Array : Prio_Array_Type; + -- Global array containing the id of the currently running task for + -- each priority. Note that we assume that we are on a single processor + -- with run-till-blocked scheduling. + + procedure Set_Priority + (T : Task_ID; + Prio : System.Any_Priority; + Loss_Of_Inheritance : Boolean := False) + is + Array_Item : Integer; + Result : int; + + begin + Result := + taskPrioritySet + (T.Common.LL.Thread, To_VxWorks_Priority (int (Prio))); + pragma Assert (Result = 0); + + if FIFO_Within_Priorities then + + -- Annex D requirement [RM D.2.2 par. 9]: + -- If the task drops its priority due to the loss of inherited + -- priority, it is added at the head of the ready queue for its + -- new active priority. + + if Loss_Of_Inheritance + and then Prio < T.Common.Current_Priority + then + Array_Item := Prio_Array (T.Common.Base_Priority) + 1; + Prio_Array (T.Common.Base_Priority) := Array_Item; + + loop + -- Give some processes a chance to arrive + + taskDelay (0); + + -- Then wait for our turn to proceed + + exit when Array_Item = Prio_Array (T.Common.Base_Priority) + or else Prio_Array (T.Common.Base_Priority) = 1; + end loop; + + Prio_Array (T.Common.Base_Priority) := + Prio_Array (T.Common.Base_Priority) - 1; + end if; + end if; + + T.Common.Current_Priority := Prio; + end Set_Priority; + + ------------------ + -- Get_Priority -- + ------------------ + + function Get_Priority (T : Task_ID) return System.Any_Priority is + begin + return T.Common.Current_Priority; + end Get_Priority; + + ---------------- + -- Enter_Task -- + ---------------- + + procedure Enter_Task (Self_ID : Task_ID) is + procedure Init_Float; + pragma Import (C, Init_Float, "__gnat_init_float"); + -- Properly initializes the FPU for PPC/MIPS systems. + + begin + Self_ID.Common.LL.Thread := taskIdSelf; + Specific.Set (Self_ID); + + Init_Float; + + -- Install the signal handlers. + -- This is called for each task since there is no signal inheritance + -- between VxWorks tasks. + + Install_Signal_Handlers; + + Lock_RTS; + + for J in Known_Tasks'Range loop + if Known_Tasks (J) = null then + Known_Tasks (J) := Self_ID; + Self_ID.Known_Tasks_Index := J; + exit; + end if; + end loop; + + Unlock_RTS; + end Enter_Task; + + -------------- + -- New_ATCB -- + -------------- + + function New_ATCB (Entry_Num : Task_Entry_Index) return Task_ID is + begin + return new Ada_Task_Control_Block (Entry_Num); + end New_ATCB; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; + + ----------------------------- + -- Register_Foreign_Thread -- + ----------------------------- + + function Register_Foreign_Thread return Task_ID is + begin + if Is_Valid_Task then + return Self; + else + return Register_Foreign_Thread (taskIdSelf); + end if; + end Register_Foreign_Thread; + + -------------------- + -- Initialize_TCB -- + -------------------- + + procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is + begin + Self_ID.Common.LL.CV := semBCreate (SEM_Q_PRIORITY, SEM_EMPTY); + Self_ID.Common.LL.Thread := 0; + + if Self_ID.Common.LL.CV = 0 then + Succeeded := False; + else + Succeeded := True; + + if not Single_Lock then + Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level); + end if; + end if; + end Initialize_TCB; + + ----------------- + -- Create_Task -- + ----------------- + + procedure Create_Task + (T : Task_ID; + Wrapper : System.Address; + Stack_Size : System.Parameters.Size_Type; + Priority : System.Any_Priority; + Succeeded : out Boolean) + is + Adjusted_Stack_Size : size_t; + begin + if Stack_Size = Unspecified_Size then + Adjusted_Stack_Size := size_t (Default_Stack_Size); + + elsif Stack_Size < Minimum_Stack_Size then + Adjusted_Stack_Size := size_t (Minimum_Stack_Size); + + else + Adjusted_Stack_Size := size_t (Stack_Size); + end if; + + -- Ask for 4 extra bytes of stack space so that the ATCB + -- pointer can be stored below the stack limit, plus extra + -- space for the frame of Task_Wrapper. This is so the user + -- gets the amount of stack requested exclusive of the needs + -- of the runtime. + -- + -- We also have to allocate n more bytes for the task name + -- storage and enough space for the Wind Task Control Block + -- which is around 0x778 bytes. VxWorks also seems to carve out + -- additional space, so use 2048 as a nice round number. + -- We might want to increment to the nearest page size in + -- case we ever support VxVMI. + -- + -- XXX - we should come back and visit this so we can + -- set the task name to something appropriate. + + Adjusted_Stack_Size := Adjusted_Stack_Size + 2048; + + -- Since the initial signal mask of a thread is inherited from the + -- creator, and the Environment task has all its signals masked, we + -- do not need to manipulate caller's signal mask at this point. + -- All tasks in RTS will have All_Tasks_Mask initially. + + if T.Common.Task_Image_Len = 0 then + T.Common.LL.Thread := taskSpawn + (System.Null_Address, + To_VxWorks_Priority (int (Priority)), + VX_FP_TASK, + Adjusted_Stack_Size, + Wrapper, + To_Address (T)); + else + declare + Name : aliased String (1 .. T.Common.Task_Image_Len + 1); + begin + Name (1 .. Name'Last - 1) := + T.Common.Task_Image (1 .. T.Common.Task_Image_Len); + Name (Name'Last) := ASCII.NUL; + + T.Common.LL.Thread := taskSpawn + (Name'Address, + To_VxWorks_Priority (int (Priority)), + VX_FP_TASK, + Adjusted_Stack_Size, + Wrapper, + To_Address (T)); + end; + end if; + + if T.Common.LL.Thread = -1 then + Succeeded := False; + else + Succeeded := True; + end if; + + Task_Creation_Hook (T.Common.LL.Thread); + Set_Priority (T, Priority); + end Create_Task; + + ------------------ + -- Finalize_TCB -- + ------------------ + + procedure Finalize_TCB (T : Task_ID) is + Result : int; + Tmp : Task_ID := T; + Is_Self : constant Boolean := (T = Self); + + procedure Free is new + Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID); + + begin + if not Single_Lock then + Result := semDelete (T.Common.LL.L.Mutex); + pragma Assert (Result = 0); + end if; + + T.Common.LL.Thread := 0; + + Result := semDelete (T.Common.LL.CV); + pragma Assert (Result = 0); + + if T.Known_Tasks_Index /= -1 then + Known_Tasks (T.Known_Tasks_Index) := null; + end if; + + Free (Tmp); + + if Is_Self then + Result := taskVarDelete (taskIdSelf, ATCB_Key'Access); + pragma Assert (Result /= ERROR); + end if; + end Finalize_TCB; + + --------------- + -- Exit_Task -- + --------------- + + procedure Exit_Task is + begin + Specific.Set (null); + end Exit_Task; + + ---------------- + -- Abort_Task -- + ---------------- + + procedure Abort_Task (T : Task_ID) is + Result : int; + + begin + Result := kill (T.Common.LL.Thread, + Signal (Interrupt_Management.Abort_Task_Signal)); + pragma Assert (Result = 0); + end Abort_Task; + + ---------------- + -- Check_Exit -- + ---------------- + + -- Dummy version + + function Check_Exit (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + + begin + return True; + end Check_Exit; + + -------------------- + -- Check_No_Locks -- + -------------------- + + function Check_No_Locks (Self_ID : ST.Task_ID) return Boolean is + pragma Unreferenced (Self_ID); + + begin + return True; + end Check_No_Locks; + + ---------------------- + -- Environment_Task -- + ---------------------- + + function Environment_Task return Task_ID is + begin + return Environment_Task_ID; + end Environment_Task; + + -------------- + -- Lock_RTS -- + -------------- + + procedure Lock_RTS is + begin + Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); + end Lock_RTS; + + ---------------- + -- Unlock_RTS -- + ---------------- + + procedure Unlock_RTS is + begin + Unlock (Single_RTS_Lock'Access, Global_Lock => True); + end Unlock_RTS; + + ------------------ + -- Suspend_Task -- + ------------------ + + function Suspend_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) + return Boolean + is + begin + if T.Common.LL.Thread /= 0 + and then T.Common.LL.Thread /= Thread_Self + then + return taskSuspend (T.Common.LL.Thread) = 0; + else + return True; + end if; + end Suspend_Task; + + ----------------- + -- Resume_Task -- + ----------------- + + function Resume_Task + (T : ST.Task_ID; + Thread_Self : Thread_Id) + return Boolean + is + begin + if T.Common.LL.Thread /= 0 + and then T.Common.LL.Thread /= Thread_Self + then + return taskResume (T.Common.LL.Thread) = 0; + else + return True; + end if; + end Resume_Task; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + Result : int; + + begin + if Locking_Policy = 'C' then + Mutex_Protocol := Prio_Protect; + elsif Locking_Policy = 'I' then + Mutex_Protocol := Prio_Inherit; + else + Mutex_Protocol := Prio_None; + end if; + + if Time_Slice_Val > 0 then + Result := kernelTimeSlice + (To_Clock_Ticks + (Duration (Time_Slice_Val) / Duration (1_000_000.0))); + end if; + + Result := sigemptyset (Unblocked_Signal_Mask'Access); + pragma Assert (Result = 0); + + for J in Interrupt_Management.Signal_ID loop + if System.Interrupt_Management.Keep_Unmasked (J) then + Result := sigaddset (Unblocked_Signal_Mask'Access, Signal (J)); + pragma Assert (Result = 0); + end if; + end loop; + + Environment_Task_ID := Environment_Task; + + -- Initialize the lock used to synchronize chain of all ATCBs. + + Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + + Enter_Task (Environment_Task); + end Initialize; + +end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-tasinf-irix-athread.adb b/gcc/ada/s-tasinf-irix-athread.adb new file mode 100644 index 00000000000..5413ebf8830 --- /dev/null +++ b/gcc/ada/s-tasinf-irix-athread.adb @@ -0,0 +1,312 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 package body contains the routines associated with the implementation +-- of the Task_Info pragma. + +-- This is the SGI specific version of this module. + +with Interfaces.C; +with System.OS_Interface; +with System; +with Unchecked_Conversion; + +package body System.Task_Info is + + use System.OS_Interface; + use type Interfaces.C.int; + + function To_Resource_T is new + Unchecked_Conversion (Resource_Vector_T, resource_t); + + MP_NPROCS : constant := 1; + + function Sysmp (Cmd : Integer) return Integer; + pragma Import (C, Sysmp); + + function Num_Processors (Cmd : Integer := MP_NPROCS) return Integer + renames Sysmp; + + function Geteuid return Integer; + pragma Import (C, Geteuid); + + Locking_Map : constant array (Page_Locking) of Interfaces.C.int := + (NOLOCK => 0, + PROCLOCK => 1, + TXTLOCK => 2, + DATLOCK => 4); + + ------------------------------- + -- Resource_Vector_Functions -- + ------------------------------- + + package body Resource_Vector_Functions is + + --------- + -- "+" -- + --------- + + function "+" (R : Resource_T) return Resource_Vector_T is + Result : Resource_Vector_T := NO_RESOURCES; + begin + Result (Resource_T'Pos (R)) := True; + return Result; + end "+"; + + function "+" (R1, R2 : Resource_T) return Resource_Vector_T is + Result : Resource_Vector_T := NO_RESOURCES; + begin + Result (Resource_T'Pos (R1)) := True; + Result (Resource_T'Pos (R2)) := True; + return Result; + end "+"; + + function "+" + (R : Resource_T; + S : Resource_Vector_T) return Resource_Vector_T + is + Result : Resource_Vector_T := S; + begin + Result (Resource_T'Pos (R)) := True; + return Result; + end "+"; + + function "+" + (S : Resource_Vector_T; + R : Resource_T) return Resource_Vector_T + is + Result : Resource_Vector_T := S; + begin + Result (Resource_T'Pos (R)) := True; + return Result; + end "+"; + + function "+" (S1, S2 : Resource_Vector_T) return Resource_Vector_T is + Result : Resource_Vector_T; + begin + Result := S1 or S2; + return Result; + end "+"; + + function "-" + (S : Resource_Vector_T; + R : Resource_T) return Resource_Vector_T + is + Result : Resource_Vector_T := S; + begin + Result (Resource_T'Pos (R)) := False; + return Result; + end "-"; + + end Resource_Vector_Functions; + + --------------- + -- New_Sproc -- + --------------- + + function New_Sproc (Attr : Sproc_Attributes) return sproc_t is + Sproc_Attr : aliased sproc_attr_t; + Sproc : aliased sproc_t; + Status : int; + + begin + Status := sproc_attr_init (Sproc_Attr'Unrestricted_Access); + + if Status = 0 then + Status := sproc_attr_setresources + (Sproc_Attr'Unrestricted_Access, + To_Resource_T (Attr.Sproc_Resources)); + + if Attr.CPU /= ANY_CPU then + if Attr.CPU > Num_Processors then + raise Invalid_CPU_Number; + end if; + + Status := sproc_attr_setcpu + (Sproc_Attr'Unrestricted_Access, + int (Attr.CPU)); + end if; + + if Attr.Resident /= NOLOCK then + if Geteuid /= 0 then + raise Permission_Error; + end if; + + Status := sproc_attr_setresident + (Sproc_Attr'Unrestricted_Access, + Locking_Map (Attr.Resident)); + end if; + + if Attr.NDPRI /= NDP_NONE then + +-- ??? why is this commented out, should it be removed ? +-- if Geteuid /= 0 then +-- raise Permission_Error; +-- end if; + + Status := + sproc_attr_setprio + (Sproc_Attr'Unrestricted_Access, int (Attr.NDPRI)); + end if; + + Status := + sproc_create + (Sproc'Unrestricted_Access, + Sproc_Attr'Unrestricted_Access, + null, + System.Null_Address); + + if Status /= 0 then + Status := sproc_attr_destroy (Sproc_Attr'Unrestricted_Access); + raise Sproc_Create_Error; + end if; + + Status := sproc_attr_destroy (Sproc_Attr'Unrestricted_Access); + end if; + + if Status /= 0 then + raise Sproc_Create_Error; + end if; + + return Sproc; + end New_Sproc; + + --------------- + -- New_Sproc -- + --------------- + + function New_Sproc + (Sproc_Resources : Resource_Vector_T := NO_RESOURCES; + CPU : CPU_Number := ANY_CPU; + Resident : Page_Locking := NOLOCK; + NDPRI : Non_Degrading_Priority := NDP_NONE) return sproc_t + is + Attr : constant Sproc_Attributes := + (Sproc_Resources, CPU, Resident, NDPRI); + begin + return New_Sproc (Attr); + end New_Sproc; + + ------------------------------- + -- Unbound_Thread_Attributes -- + ------------------------------- + + function Unbound_Thread_Attributes + (Thread_Resources : Resource_Vector_T := NO_RESOURCES; + Thread_Timeslice : Duration := 0.0) return Thread_Attributes + is + begin + return (False, Thread_Resources, Thread_Timeslice); + end Unbound_Thread_Attributes; + + ----------------------------- + -- Bound_Thread_Attributes -- + ----------------------------- + + function Bound_Thread_Attributes + (Thread_Resources : Resource_Vector_T := NO_RESOURCES; + Thread_Timeslice : Duration := 0.0; + Sproc : sproc_t) + return Thread_Attributes + is + begin + return (True, Thread_Resources, Thread_Timeslice, Sproc); + end Bound_Thread_Attributes; + + ----------------------------- + -- Bound_Thread_Attributes -- + ----------------------------- + + function Bound_Thread_Attributes + (Thread_Resources : Resource_Vector_T := NO_RESOURCES; + Thread_Timeslice : Duration := 0.0; + Sproc_Resources : Resource_Vector_T := NO_RESOURCES; + CPU : CPU_Number := ANY_CPU; + Resident : Page_Locking := NOLOCK; + NDPRI : Non_Degrading_Priority := NDP_NONE) + return Thread_Attributes + is + Sproc : constant sproc_t := New_Sproc + (Sproc_Resources, CPU, Resident, NDPRI); + begin + return (True, Thread_Resources, Thread_Timeslice, Sproc); + end Bound_Thread_Attributes; + + ----------------------------------- + -- New_Unbound_Thread_Attributes -- + ----------------------------------- + + function New_Unbound_Thread_Attributes + (Thread_Resources : Resource_Vector_T := NO_RESOURCES; + Thread_Timeslice : Duration := 0.0) return Task_Info_Type + is + begin + return new Thread_Attributes' + (False, Thread_Resources, Thread_Timeslice); + end New_Unbound_Thread_Attributes; + + --------------------------------- + -- New_Bound_Thread_Attributes -- + --------------------------------- + + function New_Bound_Thread_Attributes + (Thread_Resources : Resource_Vector_T := NO_RESOURCES; + Thread_Timeslice : Duration := 0.0; + Sproc : sproc_t) return Task_Info_Type + is + begin + return new Thread_Attributes' + (True, Thread_Resources, Thread_Timeslice, Sproc); + end New_Bound_Thread_Attributes; + + --------------------------------- + -- New_Bound_Thread_Attributes -- + --------------------------------- + + function New_Bound_Thread_Attributes + (Thread_Resources : Resource_Vector_T := NO_RESOURCES; + Thread_Timeslice : Duration := 0.0; + Sproc_Resources : Resource_Vector_T := NO_RESOURCES; + CPU : CPU_Number := ANY_CPU; + Resident : Page_Locking := NOLOCK; + NDPRI : Non_Degrading_Priority := NDP_NONE) + return Task_Info_Type + is + Sproc : constant sproc_t := New_Sproc + (Sproc_Resources, CPU, Resident, NDPRI); + begin + return new Thread_Attributes' + (True, Thread_Resources, Thread_Timeslice, Sproc); + end New_Bound_Thread_Attributes; + +end System.Task_Info; diff --git a/gcc/ada/s-tasinf-irix-athread.ads b/gcc/ada/s-tasinf-irix-athread.ads new file mode 100644 index 00000000000..f986bf934af --- /dev/null +++ b/gcc/ada/s-tasinf-irix-athread.ads @@ -0,0 +1,274 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-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 package contains the definitions and routines associated with the +-- implementation and use of the Task_Info pragma. It is specialized +-- appropriately for targets that make use of this pragma. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- This unit may be used directly from an application program by providing +-- an appropriate WITH, and the interface can be expected to remain stable. + +-- This is the SGI (libathread) specific version of this module. + +with System.OS_Interface; + +package System.Task_Info is + pragma Elaborate_Body; + -- To ensure that a body is allowed + + --------------------------------------------------------- + -- Binding of Tasks to sprocs and sprocs to processors -- + --------------------------------------------------------- + + -- The SGI implementation of the GNU Low-Level Interface (GNULLI) + -- implements each Ada task as a Posix thread (Pthread). The SGI + -- Pthread library distributes threads across one or more processes + -- that are members of a common share group. Irix distributes + -- processes across the available CPUs on a given machine. The + -- pragma Task_Info provides the mechanism to control the distribution + -- of tasks to sprocs, and sprocs to processors. + + -- Each thread has a number of attributes that dictate it's scheduling. + -- These attributes are: + + -- Bound_To_Sproc: whether the thread is bound to a specific sproc + -- for its entire lifetime. + + -- Timeslice: Amount of time that a thread is allowed to execute + -- before the system yeilds control to another thread + -- of equal priority. + + -- Resource_Vector: A bitmask used to control the binding of threads + -- to sprocs. + -- + + -- Each share group process (sproc) + + -- The Task_Info pragma: + + -- pragma Task_Info (EXPRESSION); + + -- allows the specification on a task by task basis of a value of type + -- System.Task_Info.Task_Info_Type to be passed to a task when it is + -- created. The specification of this type, and the effect on the task + -- that is created is target dependent. + + -- The Task_Info pragma appears within a task definition (compare the + -- definition and implementation of pragma Priority). If no such pragma + -- appears, then the value Task_Info_Unspecified is passed. If a pragma + -- is present, then it supplies an alternative value. If the argument of + -- the pragma is a discriminant reference, then the value can be set on + -- a task by task basis by supplying the appropriate discriminant value. + + -- Note that this means that the type used for Task_Info_Type must be + -- suitable for use as a discriminant (i.e. a scalar or access type). + + ---------------------- + -- Resource Vectors -- + ---------------------- + + -- + + type Resource_Vector_T is array (0 .. 31) of Boolean; + pragma Pack (Resource_Vector_T); + + NO_RESOURCES : constant Resource_Vector_T := (others => False); + + generic + type Resource_T is (<>); + -- Discrete type up to 32 entries + + package Resource_Vector_Functions is + function "+" + (R : Resource_T) return Resource_Vector_T; + + function "+" + (R1 : Resource_T; + R2 : Resource_T) return Resource_Vector_T; + + function "+" + (R : Resource_T; + S : Resource_Vector_T) return Resource_Vector_T; + + function "+" + (S : Resource_Vector_T; + R : Resource_T) return Resource_Vector_T; + + function "+" + (S1 : Resource_Vector_T; + S2 : Resource_Vector_T) return Resource_Vector_T; + + function "-" + (S : Resource_Vector_T; + R : Resource_T) return Resource_Vector_T; + end Resource_Vector_Functions; + + ---------------------- + -- Sproc Attributes -- + ---------------------- + + subtype sproc_t is System.OS_Interface.sproc_t; + + subtype CPU_Number is Integer range -1 .. Integer'Last; + + ANY_CPU : constant CPU_Number := CPU_Number'First; + + type Non_Degrading_Priority is range 0 .. 255; + -- Specification of IRIX Non Degrading Priorities. + -- + -- WARNING: IRIX priorities have the reverse meaning of Ada priorities. + -- The lower the priority value, the greater the greater the + -- scheduling preference. + -- + -- See the schedctl(2) man page for a complete discussion of non-degrading + -- priorities. + + NDPHIMAX : constant Non_Degrading_Priority := 30; + NDPHIMIN : constant Non_Degrading_Priority := 39; + -- These priorities are higher than ALL normal user process priorities + + subtype NDP_High is Non_Degrading_Priority range NDPHIMAX .. NDPHIMIN; + + NDPNORMMAX : constant Non_Degrading_Priority := 40; + NDPNORMMIN : constant Non_Degrading_Priority := 127; + -- These priorities overlap normal user process priorities + + subtype NDP_Norm is Non_Degrading_Priority range NDPNORMMAX .. NDPNORMMIN; + + NDPLOMAX : constant Non_Degrading_Priority := 128; + NDPLOMIN : constant Non_Degrading_Priority := 254; + -- These priorities are below ALL normal user process priorities + + NDP_NONE : constant Non_Degrading_Priority := 255; + + subtype NDP_LOW is Non_Degrading_Priority range NDPLOMAX .. NDPLOMIN; + + type Page_Locking is + (NOLOCK, -- Do not lock pages in memory + PROCLOCK, -- Lock text and data segments into memory (process lock) + TXTLOCK, -- Lock text segment into memory (text lock) + DATLOCK -- Lock data segment into memory (data lock) + ); + + type Sproc_Attributes is record + Sproc_Resources : Resource_Vector_T := NO_RESOURCES; + CPU : CPU_Number := ANY_CPU; + Resident : Page_Locking := NOLOCK; + NDPRI : Non_Degrading_Priority := NDP_NONE; +-- ??? why is that commented out, should it be removed ? +-- Sproc_Slice : Duration := 0.0; +-- Deadline_Period : Duration := 0.0; +-- Deadline_Alloc : Duration := 0.0; + end record; + + Default_Sproc_Attributes : constant Sproc_Attributes := + (NO_RESOURCES, ANY_CPU, NOLOCK, NDP_NONE); + + function New_Sproc (Attr : Sproc_Attributes) return sproc_t; + function New_Sproc + (Sproc_Resources : Resource_Vector_T := NO_RESOURCES; + CPU : CPU_Number := ANY_CPU; + Resident : Page_Locking := NOLOCK; + NDPRI : Non_Degrading_Priority := NDP_NONE) return sproc_t; + -- Allocates a sproc_t control structure and creates the + -- corresponding sproc. + + Invalid_CPU_Number : exception; + Permission_Error : exception; + Sproc_Create_Error : exception; + + ----------------------- + -- Thread Attributes -- + ----------------------- + + type Thread_Attributes (Bound_To_Sproc : Boolean) is record + Thread_Resources : Resource_Vector_T := NO_RESOURCES; + + Thread_Timeslice : Duration := 0.0; + + case Bound_To_Sproc is + when False => + null; + when True => + Sproc : sproc_t; + end case; + end record; + + Default_Thread_Attributes : constant Thread_Attributes := + (False, NO_RESOURCES, 0.0); + + function Unbound_Thread_Attributes + (Thread_Resources : Resource_Vector_T := NO_RESOURCES; + Thread_Timeslice : Duration := 0.0) return Thread_Attributes; + + function Bound_Thread_Attributes + (Thread_Resources : Resource_Vector_T := NO_RESOURCES; + Thread_Timeslice : Duration := 0.0; + Sproc : sproc_t) return Thread_Attributes; + + function Bound_Thread_Attributes + (Thread_Resources : Resource_Vector_T := NO_RESOURCES; + Thread_Timeslice : Duration := 0.0; + Sproc_Resources : Resource_Vector_T := NO_RESOURCES; + CPU : CPU_Number := ANY_CPU; + Resident : Page_Locking := NOLOCK; + NDPRI : Non_Degrading_Priority := NDP_NONE) + return Thread_Attributes; + + type Task_Info_Type is access all Thread_Attributes; + + function New_Unbound_Thread_Attributes + (Thread_Resources : Resource_Vector_T := NO_RESOURCES; + Thread_Timeslice : Duration := 0.0) + return Task_Info_Type; + + function New_Bound_Thread_Attributes + (Thread_Resources : Resource_Vector_T := NO_RESOURCES; + Thread_Timeslice : Duration := 0.0; + Sproc : sproc_t) return Task_Info_Type; + + function New_Bound_Thread_Attributes + (Thread_Resources : Resource_Vector_T := NO_RESOURCES; + Thread_Timeslice : Duration := 0.0; + Sproc_Resources : Resource_Vector_T := NO_RESOURCES; + CPU : CPU_Number := ANY_CPU; + Resident : Page_Locking := NOLOCK; + NDPRI : Non_Degrading_Priority := NDP_NONE) + return Task_Info_Type; + + Unspecified_Task_Info : constant Task_Info_Type := null; + +end System.Task_Info; diff --git a/gcc/ada/s-tasinf-irix.ads b/gcc/ada/s-tasinf-irix.ads new file mode 100644 index 00000000000..2954f8ee66c --- /dev/null +++ b/gcc/ada/s-tasinf-irix.ads @@ -0,0 +1,136 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2003 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 contains the definitions and routines associated with the +-- implementation and use of the Task_Info pragma. It is specialized +-- appropriately for targets that make use of this pragma. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- This unit may be used directly from an application program by providing +-- an appropriate WITH, and the interface can be expected to remain stable. + +-- This is the IRIX (kernel threads) version of this package + +with Interfaces.C; +with System.OS_Interface; + +package System.Task_Info is + pragma Elaborate_Body; + -- To ensure that a body is allowed + + package OSI renames System.OS_Interface; + + ----------------------------------------- + -- Implementation of Task_Info Feature -- + ----------------------------------------- + + -- Pragma Task_Info allows an application to set the underlying + -- pthread scheduling attributes for a specific task. + + ------------------ + -- Declarations -- + ------------------ + + type Thread_Scheduling_Scope is + (PTHREAD_SCOPE_PROCESS, PTHREAD_SCOPE_SYSTEM); + + for Thread_Scheduling_Scope'Size use Interfaces.C.int'Size; + + type Thread_Scheduling_Inheritance is + (PTHREAD_EXPLICIT_SCHED, PTHREAD_INHERIT_SCHED); + + for Thread_Scheduling_Inheritance'Size use Interfaces.C.int'Size; + + type Thread_Scheduling_Policy is + (SCHED_FIFO, -- The first-in-first-out real-time policy + SCHED_RR, -- The round-robin real-time scheduling policy + SCHED_TS); -- The timeshare earnings based scheduling policy + + for Thread_Scheduling_Policy'Size use Interfaces.C.int'Size; + for Thread_Scheduling_Policy use + (SCHED_FIFO => 1, + SCHED_RR => 2, + SCHED_TS => 3); + + function SCHED_OTHER return Thread_Scheduling_Policy renames SCHED_TS; + + No_Specified_Priority : constant := -1; + + subtype Thread_Scheduling_Priority is Integer range + No_Specified_Priority .. 255; + + function Min (Policy : Interfaces.C.int) return Interfaces.C.int + renames OSI.sched_get_priority_min; + + function Max (Policy : Interfaces.C.int) return Interfaces.C.int + renames OSI.sched_get_priority_max; + + subtype FIFO_Priority is Thread_Scheduling_Priority range + Thread_Scheduling_Priority (Min (OSI.SCHED_FIFO)) .. + Thread_Scheduling_Priority (Max (OSI.SCHED_FIFO)); + + subtype RR_Priority is Thread_Scheduling_Priority range + Thread_Scheduling_Priority (Min (OSI.SCHED_RR)) .. + Thread_Scheduling_Priority (Max (OSI.SCHED_RR)); + + subtype TS_Priority is Thread_Scheduling_Priority range + Thread_Scheduling_Priority (Min (OSI.SCHED_TS)) .. + Thread_Scheduling_Priority (Max (OSI.SCHED_TS)); + + subtype OTHER_Priority is Thread_Scheduling_Priority range + Thread_Scheduling_Priority (Min (OSI.SCHED_OTHER)) .. + Thread_Scheduling_Priority (Max (OSI.SCHED_OTHER)); + + subtype CPU_Number is Integer range -1 .. Integer'Last; + ANY_CPU : constant CPU_Number := CPU_Number'First; + + type Thread_Attributes is record + Scope : Thread_Scheduling_Scope := PTHREAD_SCOPE_PROCESS; + Inheritance : Thread_Scheduling_Inheritance := PTHREAD_EXPLICIT_SCHED; + Policy : Thread_Scheduling_Policy := SCHED_RR; + Priority : Thread_Scheduling_Priority := No_Specified_Priority; + Runon_CPU : CPU_Number := ANY_CPU; + end record; + + Default_Thread_Attributes : constant Thread_Attributes := + (PTHREAD_SCOPE_PROCESS, PTHREAD_EXPLICIT_SCHED, SCHED_RR, + No_Specified_Priority, ANY_CPU); + + type Task_Info_Type is access all Thread_Attributes; + + Unspecified_Task_Info : constant Task_Info_Type := null; + -- Value passed to task in the absence of a Task_Info pragma + +end System.Task_Info; diff --git a/gcc/ada/s-tasinf-solaris.adb b/gcc/ada/s-tasinf-solaris.adb new file mode 100644 index 00000000000..859bcd082ec --- /dev/null +++ b/gcc/ada/s-tasinf-solaris.adb @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2002 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 body contains the routines associated with the implementation +-- of the Task_Info pragma. + +-- This is the Solaris (native) version of this module. + +package body System.Task_Info is + + function Unbound_Thread_Attributes return Thread_Attributes is + begin + return (False, False); + end Unbound_Thread_Attributes; + + function Bound_Thread_Attributes return Thread_Attributes is + begin + return (False, True); + end Bound_Thread_Attributes; + + function Bound_Thread_Attributes (CPU : CPU_Number) + return Thread_Attributes is + begin + return (True, True, CPU); + end Bound_Thread_Attributes; + + function New_Unbound_Thread_Attributes return Task_Info_Type is + begin + return new Thread_Attributes'(False, False); + end New_Unbound_Thread_Attributes; + + function New_Bound_Thread_Attributes return Task_Info_Type is + begin + return new Thread_Attributes'(False, True); + end New_Bound_Thread_Attributes; + + function New_Bound_Thread_Attributes (CPU : CPU_Number) + return Task_Info_Type is + begin + return new Thread_Attributes'(True, True, CPU); + end New_Bound_Thread_Attributes; + +end System.Task_Info; diff --git a/gcc/ada/s-tasinf-solaris.ads b/gcc/ada/s-tasinf-solaris.ads new file mode 100644 index 00000000000..ded456effa1 --- /dev/null +++ b/gcc/ada/s-tasinf-solaris.ads @@ -0,0 +1,142 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2003 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 contains the definitions and routines associated with the +-- implementation and use of the Task_Info pragma. It is specialized +-- appropriately for targets that make use of this pragma. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- This unit may be used directly from an application program by providing +-- an appropriate WITH, and the interface can be expected to remain stable. + +-- This is the Solaris (native) version of this module. + +with System.OS_Interface; + +package System.Task_Info is + pragma Elaborate_Body; + -- To ensure that a body is allowed + + ----------------------------------------------------- + -- Binding of Tasks to LWPs and LWPs to processors -- + ----------------------------------------------------- + + -- The Solaris implementation of the GNU Low-Level Interface (GNULLI) + -- implements each Ada task as a Solaris thread. The Solaris thread + -- library distributes threads across one or more LWPs (Light Weight + -- Process) that are members of the same process. Solaris distributes + -- processes and LWPs across the available CPUs on a given machine. The + -- pragma Task_Info provides the mechanism to control the distribution + -- of tasks to LWPs, and LWPs to processors. + + -- Each thread has a number of attributes that dictate it's scheduling. + -- These attributes are: + -- + -- New_LWP: whether a new LWP is created for this thread. + -- + -- Bound_To_LWP: whether the thread is bound to a specific LWP + -- for its entire lifetime. + -- + -- CPU: the CPU number associated to the LWP + -- + + -- The Task_Info pragma: + + -- pragma Task_Info (EXPRESSION); + + -- allows the specification on a task by task basis of a value of type + -- System.Task_Info.Task_Info_Type to be passed to a task when it is + -- created. The specification of this type, and the effect on the task + -- that is created is target dependent. + + -- The Task_Info pragma appears within a task definition (compare the + -- definition and implementation of pragma Priority). If no such pragma + -- appears, then the value Task_Info_Unspecified is passed. If a pragma + -- is present, then it supplies an alternative value. If the argument of + -- the pragma is a discriminant reference, then the value can be set on + -- a task by task basis by supplying the appropriate discriminant value. + + -- Note that this means that the type used for Task_Info_Type must be + -- suitable for use as a discriminant (i.e. a scalar or access type). + + ----------------------- + -- Thread Attributes -- + ----------------------- + + subtype CPU_Number is System.OS_Interface.processorid_t; + + CPU_UNCHANGED : constant CPU_Number := System.OS_Interface.PBIND_QUERY; + -- Do not bind the LWP to a specific processor + + ANY_CPU : constant CPU_Number := System.OS_Interface.PBIND_NONE; + -- Bind the LWP to any processor + + Invalid_CPU_Number : exception; + + type Thread_Attributes (New_LWP : Boolean) is record + Bound_To_LWP : Boolean := True; + case New_LWP is + when False => + null; + when True => + CPU : CPU_Number := CPU_UNCHANGED; + end case; + end record; + + Default_Thread_Attributes : constant Thread_Attributes := (False, True); + + function Unbound_Thread_Attributes + return Thread_Attributes; + + function Bound_Thread_Attributes + return Thread_Attributes; + + function Bound_Thread_Attributes (CPU : CPU_Number) + return Thread_Attributes; + + type Task_Info_Type is access all Thread_Attributes; + + function New_Unbound_Thread_Attributes + return Task_Info_Type; + + function New_Bound_Thread_Attributes + return Task_Info_Type; + + function New_Bound_Thread_Attributes (CPU : CPU_Number) + return Task_Info_Type; + + Unspecified_Task_Info : constant Task_Info_Type := null; + +end System.Task_Info; diff --git a/gcc/ada/s-tasinf-tru64.ads b/gcc/ada/s-tasinf-tru64.ads new file mode 100644 index 00000000000..179f469c37c --- /dev/null +++ b/gcc/ada/s-tasinf-tru64.ads @@ -0,0 +1,111 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ I N F O -- +-- -- +-- S p e c -- +-- (Compiler Interface) -- +-- -- +-- Copyright (C) 1998-2003 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 contains the definitions and routines associated with the +-- implementation and use of the Task_Info pragma. It is specialized +-- appropriately for targets that make use of this pragma. + +-- Note: the compiler generates direct calls to this interface, via Rtsfind. +-- Any changes to this interface may require corresponding compiler changes. + +-- This unit may be used directly from an application program by providing +-- an appropriate WITH, and the interface can be expected to remain stable. + +-- This is a DEC Unix 4.0d version of this package. + +package System.Task_Info is + pragma Elaborate_Body; + -- To ensure that a body is allowed + + ----------------------------------------- + -- Implementation of Task_Info Feature -- + ----------------------------------------- + + -- The Task_Info pragma: + + -- pragma Task_Info (EXPRESSION); + + -- allows the specification on a task by task basis of a value of type + -- System.Task_Info.Task_Info_Type to be passed to a task when it is + -- created. The specification of this type, and the effect on the task + -- that is created is target dependent. + + -- The Task_Info pragma appears within a task definition (compare the + -- definition and implementation of pragma Priority). If no such pragma + -- appears, then the value Task_Info_Unspecified is passed. If a pragma + -- is present, then it supplies an alternative value. If the argument of + -- the pragma is a discriminant reference, then the value can be set on + -- a task by task basis by supplying the appropriate discriminant value. + + -- Note that this means that the type used for Task_Info_Type must be + -- suitable for use as a discriminant (i.e. a scalar or access type). + + ------------------ + -- Declarations -- + ------------------ + + type Scope_Type is + (Process_Scope, + -- Contend only with threads in same process + + System_Scope, + -- Contend with all threads on same CPU + + Default_Scope); + + type Thread_Attributes is record + Bind_To_Cpu_Number : Integer; + -- -1: Do nothing + -- 0: Unbind + -- 1-N: Bind all unbound threads to this CPU + + Contention_Scope : Scope_Type; + end record; + + type Task_Info_Type is access all Thread_Attributes; + -- Type used for passing information to task create call, using the + -- Task_Info pragma. This type may be specialized for individual + -- implementations, but it must be a type that can be used as a + -- discriminant (i.e. a scalar or access type). + + Unspecified_Thread_Attribute : aliased Thread_Attributes := + Thread_Attributes'(-1, Default_Scope); + + Unspecified_Task_Info : constant Task_Info_Type := + Unspecified_Thread_Attribute'Access; + -- Value passed to task in the absence of a Task_Info pragma + -- Don't call new here because the tasking run time has not been + -- elaborated yet, so calling Task_Lock is unsafe. + +end System.Task_Info; diff --git a/gcc/ada/s-taspri-dummy.ads b/gcc/ada/s-taspri-dummy.ads new file mode 100644 index 00000000000..6e6025c589d --- /dev/null +++ b/gcc/ada/s-taspri-dummy.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2000 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a no tasking 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. + +package System.Task_Primitives is + pragma Preelaborate; + + type Lock is new Integer; + + type RTS_Lock is new Integer; + + type Task_Body_Access is access procedure; + + type Private_Data is record + Thread : aliased Integer; + CV : aliased Integer; + L : aliased RTS_Lock; + end record; + +end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-hpux-dce.ads b/gcc/ada/s-taspri-hpux-dce.ads new file mode 100644 index 00000000000..4f422c24271 --- /dev/null +++ b/gcc/ada/s-taspri-hpux-dce.ads @@ -0,0 +1,89 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2000 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a HP-UX version of this package. + +-- This package provides low-level support for most tasking features. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with System.OS_Interface; +-- used for pthread_mutex_t +-- pthread_cond_t +-- pthread_t + +package System.Task_Primitives is + + type Lock is limited private; + -- Should be used for implementation of protected objects. + + type RTS_Lock is limited private; + -- Should be used inside the runtime system. + -- The difference between Lock and the RTS_Lock is that the later + -- one serves only as a semaphore so that do not check for + -- ceiling violations. + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper + -- declared local to the GNARL). + + type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task + -- basis. A component of this type is guaranteed to be included + -- in the Ada_Task_Control_Block. + +private + type Lock is record + L : aliased System.OS_Interface.pthread_mutex_t; + Priority : Integer; + Owner_Priority : Integer; + end record; + + type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + type Private_Data is record + Thread : aliased System.OS_Interface.pthread_t; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). + -- They put the same value (thr_self value). We do not want to + -- use lock on those operations and the only thing we have to + -- make sure is that they are updated in atomic fashion. + + CV : aliased System.OS_Interface.pthread_cond_t; + L : aliased RTS_Lock; + -- protection for all components is lock L + end record; + +end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-linux.ads b/gcc/ada/s-taspri-linux.ads new file mode 100644 index 00000000000..078ef3e0e8a --- /dev/null +++ b/gcc/ada/s-taspri-linux.ads @@ -0,0 +1,96 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2001 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the GNU/Linux (GNU/LinuxThreads) version of this package. + +-- This package provides low-level support for most tasking features. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with System.OS_Interface; +-- used for pthread_mutex_t +-- pthread_cond_t +-- pthread_t + +package System.Task_Primitives is + + type Lock is limited private; + -- Should be used for implementation of protected objects. + + type RTS_Lock is limited private; + -- Should be used inside the runtime system. + -- The difference between Lock and the RTS_Lock is that the later + -- one serves only as a semaphore so that do not check for + -- ceiling violations. + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper + -- declared local to the GNARL). + + type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task + -- basis. A component of this type is guaranteed to be included + -- in the Ada_Task_Control_Block. + +private + + type Prio_Array_Type is array (System.Any_Priority) of Integer; + + type Lock is record + L : aliased System.OS_Interface.pthread_mutex_t; + Ceiling : System.Any_Priority := System.Any_Priority'First; + Saved_Priority : System.Any_Priority := System.Any_Priority'First; + end record; + + type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + type Private_Data is record + Thread : aliased System.OS_Interface.pthread_t; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). + -- They put the same value (thr_self value). We do not want to + -- use lock on those operations and the only thing we have to + -- make sure is that they are updated in atomic fashion. + + CV : aliased System.OS_Interface.pthread_cond_t; + L : aliased RTS_Lock; + -- protection for all components is lock L + + Active_Priority : System.Any_Priority := System.Any_Priority'First; + -- Simulated active priority, + -- used only if Priority_Ceiling_Support is True. + end record; + +end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-lynxos.ads b/gcc/ada/s-taspri-lynxos.ads new file mode 100644 index 00000000000..bf079fd34a3 --- /dev/null +++ b/gcc/ada/s-taspri-lynxos.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 LynxOS version of this package, derived from +-- 7staspri.ads + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with System.OS_Interface; +-- used for pthread_mutex_t +-- pthread_cond_t +-- pthread_t + +package System.Task_Primitives is + + type Lock is limited private; + -- Should be used for implementation of protected objects. + + type RTS_Lock is limited private; + -- Should be used inside the runtime system. + -- The difference between Lock and the RTS_Lock is that the later + -- one serves only as a semaphore so that do not check for + -- ceiling violations. + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper + -- declared local to the GNARL). + + type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task + -- basis. A component of this type is guaranteed to be included + -- in the Ada_Task_Control_Block. + +private + + type Lock is record + Mutex : aliased System.OS_Interface.pthread_mutex_t; + Ceiling : System.Any_Priority; + Saved_Priority : System.Any_Priority; + end record; + + type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + + type Private_Data is record + Thread : aliased System.OS_Interface.pthread_t; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). + -- They put the same value (thr_self value). We do not want to + -- use lock on those operations and the only thing we have to + -- make sure is that they are updated in atomic fashion. + + 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; diff --git a/gcc/ada/s-taspri-mingw.ads b/gcc/ada/s-taspri-mingw.ads new file mode 100644 index 00000000000..01cde2c6910 --- /dev/null +++ b/gcc/ada/s-taspri-mingw.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-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 a NT (native) version of this package. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with System.OS_Interface; +-- used for pthread_mutex_t +-- pthread_cond_t +-- pthread_t + +package System.Task_Primitives is + + type Lock is limited private; + -- Should be used for implementation of protected objects. + + type RTS_Lock is limited private; + -- Should be used inside the runtime system. + -- The difference between Lock and the RTS_Lock is that the later + -- one serves only as a semaphore so that do not check for + -- ceiling violations. + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper + -- declared local to the GNARL). + + type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task + -- basis. A component of this type is guaranteed to be included + -- in the Ada_Task_Control_Block. + +private + + type Lock is record + Mutex : aliased System.OS_Interface.CRITICAL_SECTION; + Priority : Integer; + Owner_Priority : Integer; + end record; + + type Condition_Variable is new System.OS_Interface.HANDLE; + + type RTS_Lock is new System.OS_Interface.CRITICAL_SECTION; + + type Private_Data is record + Thread : aliased System.OS_Interface.HANDLE; + 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. + + Thread_Id : aliased System.OS_Interface.DWORD; + -- The purpose of this field is to provide a better tasking support + -- in gdb. + + CV : aliased Condition_Variable; + -- Condition Variable used to implement Sleep/Wakeup + + L : aliased RTS_Lock; + -- Protection for all components is lock L + end record; + +end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-os2.ads b/gcc/ada/s-taspri-os2.ads new file mode 100644 index 00000000000..cb5b0295b13 --- /dev/null +++ b/gcc/ada/s-taspri-os2.ads @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 an OS/2 version of this package. + +-- This package provides low-level support for most tasking features. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Interfaces.OS2Lib.Threads; +with Interfaces.OS2Lib.Synchronization; + +package System.Task_Primitives is + + pragma Preelaborate; + +-- type Lock is limited private; + -- Should be used for implementation of protected objects. + +-- type RTS_Lock is limited private; + -- Should be used inside the runtime system. + -- The difference between Lock and the RTS_Lock is that the later + -- one serves only as a semaphore so that do not check for + -- ceiling violations. + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper + -- declared local to the GNARL). + +-- type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task + -- basis. A component of this type is guaranteed to be included + -- in the Ada_Task_Control_Block. + +-- private + + type Lock is record + Mutex : aliased Interfaces.OS2Lib.Synchronization.HMTX; + Priority : Integer; + Owner_Priority : Integer; + Owner_ID : Address; + end record; + + type RTS_Lock is new Lock; + + type Private_Data is record + Thread : aliased Interfaces.OS2Lib.Threads.TID; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). + -- They put the same value (thr_self value). We do not want to + -- use lock on those operations and the only thing we have to + -- make sure is that they are updated in atomic fashion. + + CV : aliased Interfaces.OS2Lib.Synchronization.HEV; + + L : aliased RTS_Lock; + -- Protection for all components is lock L + + Current_Priority : Integer := -1; + -- The Current_Priority is the actual priority of a thread. + -- This field is needed because it is only possible to set a + -- delta priority in OS/2. The only places where this field should + -- be set are Set_Priority, Create_Task and Initialize (Environment). + + Wrapper : Interfaces.OS2Lib.Threads.PFNTHREAD; + -- This is the original wrapper passed by Operations.Create_Task. + -- When installing an exception handler in a thread, the thread + -- starts executing the Exception_Wrapper which calls Wrapper + -- when the handler has been installed. The handler is removed when + -- wrapper returns. + end record; + +end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-posix.ads b/gcc/ada/s-taspri-posix.ads new file mode 100644 index 00000000000..1717cce47f5 --- /dev/null +++ b/gcc/ada/s-taspri-posix.ads @@ -0,0 +1,92 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-taspri-solaris.ads b/gcc/ada/s-taspri-solaris.ads new file mode 100644 index 00000000000..335079b7cec --- /dev/null +++ b/gcc/ada/s-taspri-solaris.ads @@ -0,0 +1,130 @@ +------------------------------------------------------------------------------ +-- -- +-- 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) 1992-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 a Solaris version of this package + +-- This package provides low-level support for most tasking features. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with System.OS_Interface; +-- used for mutex_t +-- cond_t +-- thread_t + +with Unchecked_Conversion; + +package System.Task_Primitives is + pragma Preelaborate; + + type Lock is limited private; + type Lock_Ptr is access all Lock; + -- Should be used for implementation of protected objects + + type RTS_Lock is limited private; + type RTS_Lock_Ptr is access all RTS_Lock; + -- 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. + + function To_Lock_Ptr is new Unchecked_Conversion (RTS_Lock_Ptr, Lock_Ptr); + + 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 Private_Task_Serial_Number is mod 2 ** 64; + -- Used to give each task a unique serial number. + + type Base_Lock is new System.OS_Interface.mutex_t; + + type Owner_Int is new Integer; + for Owner_Int'Alignment use Standard'Maximum_Alignment; + + type Owner_ID is access all Owner_Int; + + function To_Owner_ID is + new Unchecked_Conversion (System.Address, Owner_ID); + + type Lock is record + L : aliased Base_Lock; + Ceiling : System.Any_Priority := System.Any_Priority'First; + Saved_Priority : System.Any_Priority := System.Any_Priority'First; + Owner : Owner_ID; + Next : Lock_Ptr; + Level : Private_Task_Serial_Number := 0; + Buddy : Owner_ID; + Frozen : Boolean := False; + end record; + + type RTS_Lock is new Lock; + + -- Note that task support on gdb relies on the fact that the first + -- 2 fields of Private_Data are Thread and LWP. + + type Private_Data is record + Thread : aliased System.OS_Interface.thread_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 : System.OS_Interface.lwpid_t; + -- The LWP id of the thread. Set by self in Enter_Task. + + CV : aliased System.OS_Interface.cond_t; + L : aliased RTS_Lock; + -- Protection for all components is lock L + + Active_Priority : System.Any_Priority := System.Any_Priority'First; + -- Simulated active priority, + -- used only if Priority_Ceiling_Support is True. + + Locking : Lock_Ptr; + Locks : Lock_Ptr; + Wakeups : Natural := 0; + end record; + +end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-tru64.ads b/gcc/ada/s-taspri-tru64.ads new file mode 100644 index 00000000000..2caf54b5f25 --- /dev/null +++ b/gcc/ada/s-taspri-tru64.ads @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2000 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the DEC Unix 4.0 version of this package. + +-- This package provides low-level support for most tasking features. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Interfaces.C; +-- used for int +-- size_t + +with System.OS_Interface; +-- used for pthread_mutex_t +-- pthread_cond_t +-- pthread_t + +package System.Task_Primitives is + + type Lock is limited private; + -- Should be used for implementation of protected objects. + + type RTS_Lock is limited private; + -- Should be used inside the runtime system. + -- The difference between Lock and the RTS_Lock is that the later + -- one serves only as a semaphore so that do not check for + -- ceiling violations. + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper + -- declared local to the GNARL). + + type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task + -- basis. A component of this type is guaranteed to be included + -- in the Ada_Task_Control_Block. + +private + + type Lock is record + L : aliased System.OS_Interface.pthread_mutex_t; + Ceiling : Interfaces.C.int; + end record; + + type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + type Private_Data is record + Thread : aliased System.OS_Interface.pthread_t; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). + -- They put the same value (thr_self value). We do not want to + -- use lock on those operations and the only thing we have to + -- make sure is that they are updated in atomic fashion. + + CV : aliased System.OS_Interface.pthread_cond_t; + L : aliased RTS_Lock; + -- protection for all components is lock L + end record; + +end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-vms.ads b/gcc/ada/s-taspri-vms.ads new file mode 100644 index 00000000000..09179325c81 --- /dev/null +++ b/gcc/ada/s-taspri-vms.ads @@ -0,0 +1,105 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2000 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a OpenVMS/Alpha version of this package. + +-- This package provides low-level support for most tasking features. + +pragma Polling (Off); +-- Turn off polling, we do not want ATC polling to take place during +-- tasking operations. It causes infinite loops and other problems. + +with Interfaces.C; +-- used for int +-- size_t + +with System.OS_Interface; +-- used for pthread_mutex_t +-- pthread_cond_t +-- pthread_t + +package System.Task_Primitives is + + type Lock is limited private; + -- Should be used for implementation of protected objects. + + type RTS_Lock is limited private; + -- Should be used inside the runtime system. + -- The difference between Lock and the RTS_Lock is that the later + -- one serves only as a semaphore so that do not check for + -- ceiling violations. + + type Task_Body_Access is access procedure; + -- Pointer to the task body's entry point (or possibly a wrapper + -- declared local to the GNARL). + + type Private_Data is limited private; + -- Any information that the GNULLI needs maintained on a per-task + -- basis. A component of this type is guaranteed to be included + -- in the Ada_Task_Control_Block. + +private + + type Exc_Stack_T is array (0 .. 8192) of aliased Character; + for Exc_Stack_T'Alignment use Standard'Maximum_Alignment; + type Exc_Stack_Ptr_T is access all Exc_Stack_T; + + type Lock is record + L : aliased System.OS_Interface.pthread_mutex_t; + Prio : Interfaces.C.int; + Prio_Save : Interfaces.C.int; + end record; + + type RTS_Lock is new System.OS_Interface.pthread_mutex_t; + type Private_Data is record + Thread : aliased System.OS_Interface.pthread_t; + pragma Atomic (Thread); + -- Thread field may be updated by two different threads of control. + -- (See, Enter_Task and Create_Task in s-taprop.adb). + -- They put the same value (thr_self value). We do not want to + -- use lock on those operations and the only thing we have to + -- make sure is that they are updated in atomic fashion. + + CV : aliased System.OS_Interface.pthread_cond_t; + L : aliased RTS_Lock; + -- protection for all components is lock L + + Exc_Stack_Ptr : Exc_Stack_Ptr_T; + -- ??? This needs comments. + + AST_Pending : Boolean; + -- Used to detect delay and sleep timeouts + + end record; + +end System.Task_Primitives; diff --git a/gcc/ada/s-taspri-vxworks.ads b/gcc/ada/s-taspri-vxworks.ads new file mode 100644 index 00000000000..efd41ccd984 --- /dev/null +++ b/gcc/ada/s-taspri-vxworks.ads @@ -0,0 +1,95 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-tfsetr-default.adb b/gcc/ada/s-tfsetr-default.adb new file mode 100644 index 00000000000..a8e166d04ed --- /dev/null +++ b/gcc/ada/s-tfsetr-default.adb @@ -0,0 +1,313 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-tfsetr-vxworks.adb b/gcc/ada/s-tfsetr-vxworks.adb new file mode 100644 index 00000000000..0cd3d1b1107 --- /dev/null +++ b/gcc/ada/s-tfsetr-vxworks.adb @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-tpopde-vms.adb b/gcc/ada/s-tpopde-vms.adb new file mode 100644 index 00000000000..89db8240ad8 --- /dev/null +++ b/gcc/ada/s-tpopde-vms.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-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 package is for OpenVMS/Alpha + +with System.OS_Interface; +with System.Parameters; +with System.Tasking; +with Unchecked_Conversion; +with System.Soft_Links; + +package body System.Task_Primitives.Operations.DEC is + + use System.OS_Interface; + use System.Parameters; + use System.Tasking; + use System.Aux_DEC; + use type Interfaces.C.int; + + package SSL renames System.Soft_Links; + + -- The FAB_RAB_Type specifies where the context field (the calling + -- task) is stored. Other fields defined for FAB_RAB arent' need and + -- so are ignored. + + type FAB_RAB_Type is record + CTX : Unsigned_Longword; + end record; + + for FAB_RAB_Type use record + CTX at 24 range 0 .. 31; + end record; + + for FAB_RAB_Type'Size use 224; + + type FAB_RAB_Access_Type is access all FAB_RAB_Type; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function To_Unsigned_Longword is new + Unchecked_Conversion (Task_ID, Unsigned_Longword); + + function To_Task_Id is new + Unchecked_Conversion (Unsigned_Longword, Task_ID); + + function To_FAB_RAB is new + Unchecked_Conversion (Address, FAB_RAB_Access_Type); + + --------------------------- + -- Interrupt_AST_Handler -- + --------------------------- + + procedure Interrupt_AST_Handler (ID : Address) is + Result : Interfaces.C.int; + AST_Self_ID : constant Task_ID := To_Task_ID (ID); + begin + Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Interrupt_AST_Handler; + + --------------------- + -- RMS_AST_Handler -- + --------------------- + + procedure RMS_AST_Handler (ID : Address) is + AST_Self_ID : constant Task_ID := To_Task_Id (To_FAB_RAB (ID).CTX); + Result : Interfaces.C.int; + + begin + AST_Self_ID.Common.LL.AST_Pending := False; + Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); + pragma Assert (Result = 0); + end RMS_AST_Handler; + + ---------- + -- Self -- + ---------- + + function Self return Unsigned_Longword is + Self_ID : constant Task_ID := Self; + begin + Self_ID.Common.LL.AST_Pending := True; + return To_Unsigned_Longword (Self); + end Self; + + ------------------------- + -- Starlet_AST_Handler -- + ------------------------- + + procedure Starlet_AST_Handler (ID : Address) is + Result : Interfaces.C.int; + AST_Self_ID : constant Task_ID := To_Task_ID (ID); + begin + AST_Self_ID.Common.LL.AST_Pending := False; + Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); + pragma Assert (Result = 0); + end Starlet_AST_Handler; + + ---------------- + -- Task_Synch -- + ---------------- + + procedure Task_Synch is + Synch_Self_ID : constant Task_ID := Self; + + begin + if Single_Lock then + Lock_RTS; + else + Write_Lock (Synch_Self_ID); + end if; + + SSL.Abort_Defer.all; + Synch_Self_ID.Common.State := AST_Server_Sleep; + + while Synch_Self_ID.Common.LL.AST_Pending loop + Sleep (Synch_Self_ID, AST_Server_Sleep); + end loop; + + Synch_Self_ID.Common.State := Runnable; + + if Single_Lock then + Unlock_RTS; + else + Unlock (Synch_Self_ID); + end if; + + SSL.Abort_Undefer.all; + end Task_Synch; + +end System.Task_Primitives.Operations.DEC; diff --git a/gcc/ada/s-tpopde-vms.ads b/gcc/ada/s-tpopde-vms.ads new file mode 100644 index 00000000000..46d92470f0b --- /dev/null +++ b/gcc/ada/s-tpopde-vms.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-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 package is for OpenVMS/Alpha. +-- +with System.Aux_DEC; +package System.Task_Primitives.Operations.DEC is + + procedure Interrupt_AST_Handler (ID : Address); + -- Handles the AST for Ada95 Interrupts. + + procedure RMS_AST_Handler (ID : Address); + -- Handles the AST for RMS_Asynch_Operations. + + function Self return System.Aux_DEC.Unsigned_Longword; + -- Returns the task identification for the AST. + + procedure Starlet_AST_Handler (ID : Address); + -- Handles the AST for Starlet Tasking_Services. + + procedure Task_Synch; + -- Synchronizes the task after the system service completes. + +end System.Task_Primitives.Operations.DEC; diff --git a/gcc/ada/s-tpopsp-lynxos.adb b/gcc/ada/s-tpopsp-lynxos.adb new file mode 100644 index 00000000000..2673d0e30b6 --- /dev/null +++ b/gcc/ada/s-tpopsp-lynxos.adb @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 a LynxOS 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 := st_keycreate (null, ATCB_Key'Access); + pragma Assert (Result = 0); + end Initialize; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + Result : Interfaces.C.int; + Value : aliased System.Address; + begin + Result := st_getspecific (ATCB_Key, Value'Address); + pragma Assert (Result = 0); + return (Value /= System.Null_Address); + end Is_Valid_Task; + + --------- + -- Set -- + --------- + + procedure Set (Self_Id : Task_ID) is + Result : Interfaces.C.int; + + begin + Result := st_setspecific (ATCB_Key, To_Address (Self_Id)); + pragma Assert (Result = 0); + end Set; + + ---------- + -- Self -- + ---------- + + -- To make Ada tasks and C threads interoperate better, we have added some + -- functionality to Self. Suppose a C main program (with threads) calls an + -- Ada procedure and the Ada procedure calls the tasking runtime system. + -- Eventually, a call will be made to self. Since the call is not coming + -- from an Ada task, there will be no corresponding ATCB. + + -- What we do in Self is to catch references that do not come from + -- recognized Ada tasks, and create an ATCB for the calling thread. + + -- The new ATCB will be "detached" from the normal Ada task master + -- hierarchy, much like the existing implicitly created signal-server + -- tasks. + + function Self return Task_ID is + Value : aliased System.Address; + + Result : Interfaces.C.int; + pragma Unreferenced (Result); + + begin + Result := st_getspecific (ATCB_Key, Value'Address); + -- Is it OK not to check this result??? + + -- If the key value is Null, then it is a non-Ada task. + + if Value /= System.Null_Address then + return To_Task_ID (Value); + else + return Register_Foreign_Thread; + end if; + end Self; + +end Specific; diff --git a/gcc/ada/s-tpopsp-posix-foreign.adb b/gcc/ada/s-tpopsp-posix-foreign.adb new file mode 100644 index 00000000000..c1c0815c790 --- /dev/null +++ b/gcc/ada/s-tpopsp-posix-foreign.adb @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 a POSIX version of this package where foreign threads are +-- recognized. + +-- Currently, DEC Unix, SCO UnixWare, Solaris pthread, HPUX pthread and +-- GNU/Linux threads use this version. + +separate (System.Task_Primitives.Operations) +package body Specific is + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + pragma Warnings (Off, Environment_Task); + Result : Interfaces.C.int; + + begin + Result := pthread_key_create (ATCB_Key'Access, null); + pragma Assert (Result = 0); + end Initialize; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + begin + return pthread_getspecific (ATCB_Key) /= System.Null_Address; + end Is_Valid_Task; + + --------- + -- Set -- + --------- + + procedure Set (Self_Id : Task_ID) is + Result : Interfaces.C.int; + begin + Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id)); + pragma Assert (Result = 0); + end Set; + + ---------- + -- Self -- + ---------- + + -- To make Ada tasks and C threads interoperate better, we have added some + -- functionality to Self. Suppose a C main program (with threads) calls an + -- Ada procedure and the Ada procedure calls the tasking runtime system. + -- Eventually, a call will be made to self. Since the call is not coming + -- from an Ada task, there will be no corresponding ATCB. + + -- What we do in Self is to catch references that do not come from + -- recognized Ada tasks, and create an ATCB for the calling thread. + + -- The new ATCB will be "detached" from the normal Ada task master + -- hierarchy, much like the existing implicitly created signal-server + -- tasks. + + function Self return Task_ID is + Result : System.Address; + + begin + Result := pthread_getspecific (ATCB_Key); + + -- If the key value is Null, then it is a non-Ada task. + + if Result /= System.Null_Address then + return To_Task_ID (Result); + else + return Register_Foreign_Thread; + end if; + end Self; + +end Specific; diff --git a/gcc/ada/s-tpopsp-posix.adb b/gcc/ada/s-tpopsp-posix.adb new file mode 100644 index 00000000000..f7a67a074ca --- /dev/null +++ b/gcc/ada/s-tpopsp-posix.adb @@ -0,0 +1,80 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-tpopsp-solaris.adb b/gcc/ada/s-tpopsp-solaris.adb new file mode 100644 index 00000000000..eb32dd2cb81 --- /dev/null +++ b/gcc/ada/s-tpopsp-solaris.adb @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- +-- -- +-- 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 a version for Solaris native threads + +separate (System.Task_Primitives.Operations) +package body Specific is + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Environment_Task : Task_ID) is + Result : Interfaces.C.int; + begin + Result := thr_setspecific (ATCB_Key, To_Address (Environment_Task)); + pragma Assert (Result = 0); + end Initialize; + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + Unknown_Task : aliased System.Address; + Result : Interfaces.C.int; + begin + Result := thr_getspecific (ATCB_Key, Unknown_Task'Unchecked_Access); + pragma Assert (Result = 0); + return Unknown_Task /= System.Null_Address; + end Is_Valid_Task; + + --------- + -- Set -- + --------- + + procedure Set (Self_Id : Task_ID) is + Result : Interfaces.C.int; + begin + Result := thr_setspecific (ATCB_Key, To_Address (Self_Id)); + pragma Assert (Result = 0); + end Set; + + ---------- + -- Self -- + ---------- + + -- To make Ada tasks and C threads interoperate better, we have + -- added some functionality to Self. Suppose a C main program + -- (with threads) calls an Ada procedure and the Ada procedure + -- calls the tasking run-time system. Eventually, a call will be + -- made to self. Since the call is not coming from an Ada task, + -- there will be no corresponding ATCB. + + -- What we do in Self is to catch references that do not come + -- from recognized Ada tasks, and create an ATCB for the calling + -- thread. + + -- The new ATCB will be "detached" from the normal Ada task + -- master hierarchy, much like the existing implicitly created + -- signal-server tasks. + + function Self return Task_ID is + Result : Interfaces.C.int; + Self_Id : aliased System.Address; + begin + Result := thr_getspecific (ATCB_Key, Self_Id'Unchecked_Access); + pragma Assert (Result = 0); + + if Self_Id = System.Null_Address then + return Register_Foreign_Thread; + else + return To_Task_ID (Self_Id); + end if; + end Self; + +end Specific; diff --git a/gcc/ada/s-tpopsp-vxworks.adb b/gcc/ada/s-tpopsp-vxworks.adb new file mode 100644 index 00000000000..02983287d2c --- /dev/null +++ b/gcc/ada/s-tpopsp-vxworks.adb @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-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 a VxWorks version of this package where foreign threads are +-- recognized. + +separate (System.Task_Primitives.Operations) +package body Specific is + + ------------------- + -- Is_Valid_Task -- + ------------------- + + function Is_Valid_Task return Boolean is + begin + return taskVarGet (taskIdSelf, ATCB_Key'Access) /= ERROR; + end Is_Valid_Task; + + --------- + -- Set -- + --------- + + procedure Set (Self_Id : Task_ID) is + Result : STATUS; + + begin + if taskVarGet (0, ATCB_Key'Access) = ERROR then + Result := taskVarAdd (0, ATCB_Key'Access); + pragma Assert (Result = OK); + end if; + + ATCB_Key := To_Address (Self_Id); + end Set; + + ---------- + -- Self -- + ---------- + + function Self return Task_ID is + begin + return To_Task_ID (ATCB_Key); + end Self; + +end Specific; diff --git a/gcc/ada/s-traceb-hpux.adb b/gcc/ada/s-traceb-hpux.adb new file mode 100644 index 00000000000..dce251a05a9 --- /dev/null +++ b/gcc/ada/s-traceb-hpux.adb @@ -0,0 +1,600 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K -- +-- (HP/UX Version) -- +-- -- +-- 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. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +package body System.Traceback is + + -- This package implements the backtracing facility by way of a dedicated + -- HP library for stack unwinding described in the "Runtime Architecture + -- Document". + + pragma Linker_Options ("/usr/lib/libcl.a"); + + -- The library basically offers services to fetch information about a + -- "previous" frame based on information about a "current" one. + + type Current_Frame_Descriptor is record + cur_fsz : Address; -- Frame size of current routine. + cur_sp : Address; -- The current value of stack pointer. + cur_rls : Address; -- PC-space of the caller. + cur_rlo : Address; -- PC-offset of the caller. + cur_dp : Address; -- Data Pointer of the current routine. + top_rp : Address; -- Initial value of RP. + top_mrp : Address; -- Initial value of MRP. + top_sr0 : Address; -- Initial value of sr0. + top_sr4 : Address; -- Initial value of sr4. + top_r3 : Address; -- Initial value of gr3. + cur_r19 : Address; -- GR19 value of the calling routine. + top_r4 : Address; -- Initial value of gr4. + dummy : Address; -- Reserved. + out_rlo : Address; -- PC-offset of the caller after get_previous. + end record; + + type Previous_Frame_Descriptor is record + prev_fsz : Address; -- frame size of calling routine. + prev_sp : Address; -- SP of calling routine. + prev_rls : Address; -- PC_space of calling routine's caller. + prev_rlo : Address; -- PC_offset of calling routine's caller. + prev_dp : Address; -- DP of calling routine. + udescr0 : Address; -- low word of calling routine's unwind desc. + udescr1 : Address; -- high word of calling routine's unwind desc. + ustart : Address; -- start of the unwind region. + uend : Address; -- end of the unwind region. + uw_index : Address; -- index into the unwind table. + prev_r19 : Address; -- GR19 value of the caller's caller. + top_r3 : Address; -- Caller's initial gr3. + top_r4 : Address; -- Caller's initial gr4. + end record; + + -- Provide useful shortcuts for the names + + subtype CFD is Current_Frame_Descriptor; + subtype PFD is Previous_Frame_Descriptor; + + -- Frames with dynamic stack allocation are handled using the associated + -- frame pointer, but HP compilers and GCC setup this pointer differently. + -- HP compilers set it to point at the top (highest address) of the static + -- part of the frame, wheras GCC sets it to point at the bottom of this + -- region. We have to fake the unwinder to compensate for this difference, + -- for which we'll need to access some subprograms unwind descriptors. + + type Bits_2_Value is mod 2 ** 2; + for Bits_2_Value'Size use 2; + + type Bits_4_Value is mod 2 ** 4; + for Bits_4_Value'Size use 4; + + type Bits_5_Value is mod 2 ** 5; + for Bits_5_Value'Size use 5; + + type Bits_27_Value is mod 2 ** 27; + for Bits_27_Value'Size use 27; + + type Unwind_Descriptor is record + cannot_unwind : Boolean; + mcode : Boolean; + mcode_save_restore : Boolean; + region_desc : Bits_2_Value; + reserved0 : Boolean; + entry_sr : Boolean; + entry_fr : Bits_4_Value; + entry_gr : Bits_5_Value; + + args_stored : Boolean; + variable_frame : Boolean; + separate_package_body : Boolean; + frame_extension_mcode : Boolean; + + stack_overflow_check : Boolean; + two_steps_sp_adjust : Boolean; + sr4_export : Boolean; + cxx_info : Boolean; + + cxx_try_catch : Boolean; + sched_entry_seq : Boolean; + reserved1 : Boolean; + save_sp : Boolean; + + save_rp : Boolean; + save_mrp : Boolean; + save_r19 : Boolean; + cleanups : Boolean; + + hpe_interrupt_marker : Boolean; + hpux_interrupt_marker : Boolean; + large_frame : Boolean; + alloca_frame : Boolean; + + reserved2 : Boolean; + frame_size : Bits_27_Value; + end record; + + for Unwind_Descriptor'Size use 64; + + for Unwind_Descriptor use record + cannot_unwind at 0 range 0 .. 0; + mcode at 0 range 1 .. 1; + mcode_save_restore at 0 range 2 .. 2; + region_desc at 0 range 3 .. 4; + reserved0 at 0 range 5 .. 5; + entry_sr at 0 range 6 .. 6; + entry_fr at 0 range 7 .. 10; + + entry_gr at 1 range 3 .. 7; + + args_stored at 2 range 0 .. 0; + variable_frame at 2 range 1 .. 1; + separate_package_body at 2 range 2 .. 2; + frame_extension_mcode at 2 range 3 .. 3; + stack_overflow_check at 2 range 4 .. 4; + two_steps_sp_adjust at 2 range 5 .. 5; + sr4_export at 2 range 6 .. 6; + cxx_info at 2 range 7 .. 7; + + cxx_try_catch at 3 range 0 .. 0; + sched_entry_seq at 3 range 1 .. 1; + reserved1 at 3 range 2 .. 2; + save_sp at 3 range 3 .. 3; + save_rp at 3 range 4 .. 4; + save_mrp at 3 range 5 .. 5; + save_r19 at 3 range 6 .. 6; + cleanups at 3 range 7 .. 7; + + hpe_interrupt_marker at 4 range 0 .. 0; + hpux_interrupt_marker at 4 range 1 .. 1; + large_frame at 4 range 2 .. 2; + alloca_frame at 4 range 3 .. 3; + + reserved2 at 4 range 4 .. 4; + frame_size at 4 range 5 .. 31; + end record; + + subtype UWD is Unwind_Descriptor; + type UWD_Ptr is access all UWD; + + function To_UWD_Access is new Ada.Unchecked_Conversion (Address, UWD_Ptr); + + -- The descriptor associated with a given code location is retrieved + -- using functions imported from the HP library, requiring the definition + -- of additional structures. + + type Unwind_Table_Region is record + Table_Start : Address; + Table_End : Address; + end record; + -- An Unwind Table region, which is a memory area containing Unwind + -- Descriptors. + + subtype UWT is Unwind_Table_Region; + + -- The subprograms imported below are provided by the HP library + + function U_get_unwind_table return UWT; + pragma Import (C, U_get_unwind_table, "U_get_unwind_table"); + -- Get the unwind table region associated with the current executable. + -- This function is actually documented as having an argument, but which + -- is only used for the MPE/iX targets. + + function U_get_shLib_unwind_table (r19 : Address) return UWT; + pragma Import (C, U_get_shLib_unwind_table, "U_get_shLib_unw_tbl"); + -- Return the unwind table region associated with a possible shared + -- library, as determined by the provided r19 value. + + function U_get_shLib_text_addr (r19 : Address) return Address; + pragma Import (C, U_get_shLib_text_addr, "U_get_shLib_text_addr"); + -- Return the address at which the code for a shared library begins, or + -- -1 if the value provided for r19 does not identify shared library code. + + function U_get_unwind_entry + (Pc : Address; + Space : Address; + Table_Start : Address; + Table_End : Address) return Address; + pragma Import (C, U_get_unwind_entry, "U_get_unwind_entry"); + -- Given the bounds of an unwind table, return the address of the + -- unwind descriptor associated with a code location/space. In the case + -- of shared library code, the offset from the beginning of the library + -- is expected as Pc. + + procedure U_init_frame_record (Frame : access CFD); + pragma Import (C, U_init_frame_record, "U_init_frame_record"); + + procedure U_prep_frame_rec_for_unwind (Frame : access CFD); + pragma Import (C, U_prep_frame_rec_for_unwind, + "U_prep_frame_rec_for_unwind"); + + -- Fetch the description data of the frame in which these two procedures + -- are called. + + function U_get_u_rlo (Cur : access CFD; Prev : access PFD) return Integer; + pragma Import (C, U_get_u_rlo, "U_IS_STUB_OR_CALLX"); + -- From a complete current frame with a return location possibly located + -- into a linker generated stub, and basic information about the previous + -- frame, place the first non stub return location into the current frame. + -- Return -1 if something went wrong during the computation. + + function U_is_shared_pc (rlo : Address; r19 : Address) return Address; + pragma Import (C, U_is_shared_pc, "U_is_shared_pc"); + -- Return 0 if the provided return location does not correspond to code + -- in a shared library, or something non null otherwise. + + function U_get_previous_frame_x + (current_frame : access CFD; + previous_frame : access PFD; + previous_size : Integer) return Integer; + pragma Import (C, U_get_previous_frame_x, "U_get_previous_frame_x"); + -- Fetch the data describing the "previous" frame relatively to the + -- "current" one. "previous_size" should be the size of the "previous" + -- frame descriptor provided. + -- + -- The library provides a simpler interface without the size parameter + -- but it is not usable when frames with dynamically allocated space are + -- on the way. + + ------------------ + -- 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; + + ---------------- + -- 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 System.Address; + pragma Suppress_Initialization (Tracebacks_Array); + + -- The code location returned by the unwinder is a return location but + -- what we need is a call point. Under HP-UX call instructions are 4 + -- bytes long and the return point they specify is 4 bytes beyond the + -- next instruction because of the delay slot. + + Call_Size : constant := 4; + DSlot_Size : constant := 4; + Rlo_Offset : constant := Call_Size + DSlot_Size; + + -- Moreover, the return point is passed via a register which two least + -- significant bits specify a privilege level that we will have to mask. + + Priv_Mask : constant := 16#00000003#; + + Frame : aliased CFD; + Code : System.Address; + J : Natural := 1; + Pop_Success : Boolean; + Trace : Tracebacks_Array; + for Trace'Address use Traceback; + + -- The backtracing process needs a set of subprograms : + + function UWD_For_RLO_Of (Frame : access CFD) return UWD_Ptr; + -- Return an access to the unwind descriptor for the caller of + -- a given frame, using only the provided return location. + + function UWD_For_Caller_Of (Frame : access CFD) return UWD_Ptr; + -- Return an access to the unwind descriptor for the user code caller + -- of a given frame, or null if the information is not available. + + function Pop_Frame (Frame : access CFD) return Boolean; + -- Update the provided machine state structure so that it reflects + -- the state one call frame "above" the initial one. + -- + -- Return True if the operation has been successful, False otherwise. + -- Failure typically occurs when the top of the call stack has been + -- reached. + + function Prepare_For_Unwind_Of (Frame : access CFD) return Boolean; + -- Perform the necessary adaptations to the machine state before + -- calling the unwinder. Currently used for the specific case of + -- dynamically sized previous frames. + -- + -- Return True if everything went fine, or False otherwise. + + Program_UWT : constant UWT := U_get_unwind_table; + + --------------- + -- Pop_Frame -- + --------------- + + function Pop_Frame (Frame : access CFD) return Boolean is + Up_Frame : aliased PFD; + State_Ready : Boolean; + + begin + -- Check/adapt the state before calling the unwinder and return + -- if anything went wrong. + + State_Ready := Prepare_For_Unwind_Of (Frame); + + if not State_Ready then + return False; + end if; + + -- Now, safely call the unwinder and use the results. + + if U_get_previous_frame_x (Frame, + Up_Frame'Access, + Up_Frame'Size) /= 0 + then + return False; + end if; + + -- In case a stub is on the way, the usual previous return location + -- (the one in prev_rlo) is the one in the stub and the "real" one + -- is placed in the "current" record, so let's take this one into + -- account. + + Frame.out_rlo := Frame.cur_rlo; + + Frame.cur_fsz := Up_Frame.prev_fsz; + Frame.cur_sp := Up_Frame.prev_sp; + Frame.cur_rls := Up_Frame.prev_rls; + Frame.cur_rlo := Up_Frame.prev_rlo; + Frame.cur_dp := Up_Frame.prev_dp; + Frame.cur_r19 := Up_Frame.prev_r19; + Frame.top_r3 := Up_Frame.top_r3; + Frame.top_r4 := Up_Frame.top_r4; + + return True; + end Pop_Frame; + + --------------------------------- + -- Prepare_State_For_Unwind_Of -- + --------------------------------- + + function Prepare_For_Unwind_Of (Frame : access CFD) return Boolean + is + Caller_UWD : UWD_Ptr; + FP_Adjustment : Integer; + + begin + -- No need to bother doing anything if the stack is already fully + -- unwound. + + if Frame.cur_rlo = 0 then + return False; + end if; + + -- When ALLOCA_FRAME is set in an unwind descriptor, the unwinder + -- uses the value provided in current.top_r3 or current.top_r4 as + -- a frame pointer to compute the size of the frame. What decides + -- between r3 or r4 is the unwind descriptor LARGE_FRAME bit, with + -- r4 chosen if the bit is set. + + -- The size computed by the unwinder is STATIC_PART + (SP - FP), + -- which is correct with HP's frame pointer convention, but not + -- with GCC's one since we end up with the static part accounted + -- for twice. + + -- We have to compute r4 when it is required because the unwinder + -- has looked for it at a place where it was not if we went through + -- GCC frames. + + -- The size of the static part of a frame can be found in the + -- associated unwind descriptor. + + Caller_UWD := UWD_For_Caller_Of (Frame); + + -- If we cannot get it, we are unable to compute the potentially + -- necessary adjustments. We'd better not try to go on then. + + if Caller_UWD = null then + return False; + end if; + + -- If the caller frame is a GCC one, r3 is its frame pointer and + -- points to the bottom of the frame. The value to provide for r4 + -- can then be computed directly from the one of r3, compensating + -- for the static part of the frame. + + -- If the caller frame is an HP one, r3 is used to locate the + -- previous frame marker, that is it also points to the bottom of + -- the frame (this is why r3 cannot be used as the frame pointer in + -- the HP sense for large frames). The value to provide for r4 can + -- then also be computed from the one of r3 with the compensation + -- for the static part of the frame. + + FP_Adjustment := Integer (Caller_UWD.frame_size * 8); + Frame.top_r4 := Address (Integer (Frame.top_r3) + FP_Adjustment); + + return True; + end Prepare_For_Unwind_Of; + + ----------------------- + -- UWD_For_Caller_Of -- + ----------------------- + + function UWD_For_Caller_Of (Frame : access CFD) return UWD_Ptr + is + UWD_Access : UWD_Ptr; + + begin + -- First try the most direct path, using the return location data + -- associated with the frame. + + UWD_Access := UWD_For_RLO_Of (Frame); + + if UWD_Access /= null then + return UWD_Access; + end if; + + -- If we did not get a result, we might face an in-stub return + -- address. In this case U_get_previous_frame can tell us what the + -- first not-in-stub return point is. We cannot call it directly, + -- though, because we haven't computed the potentially necessary + -- frame pointer adjustments, which might lead to SEGV in some + -- circumstances. Instead, we directly call the libcl routine which + -- is called by U_get_previous_frame and which only requires few + -- information. Take care, however, that the information is provided + -- in the "current" argument, so we need to work on a copy to avoid + -- disturbing our caller. + + declare + U_Current : aliased CFD := Frame.all; + U_Previous : aliased PFD; + + begin + U_Previous.prev_dp := U_Current.cur_dp; + U_Previous.prev_rls := U_Current.cur_rls; + U_Previous.prev_sp := U_Current.cur_sp - U_Current.cur_fsz; + + if U_get_u_rlo (U_Current'Access, U_Previous'Access) /= -1 then + UWD_Access := UWD_For_RLO_Of (U_Current'Access); + end if; + end; + + return UWD_Access; + end UWD_For_Caller_Of; + + -------------------- + -- UWD_For_RLO_Of -- + -------------------- + + function UWD_For_RLO_Of (Frame : access CFD) return UWD_Ptr + is + UWD_Address : Address; + + -- The addresses returned by the library point to full descriptors + -- including the frame information bits but also the applicable PC + -- range. We need to account for this. + + Frame_Info_Offset : constant := 8; + + begin + -- First try to locate the descriptor in the program's unwind table. + + UWD_Address := U_get_unwind_entry (Frame.cur_rlo, + Frame.cur_rls, + Program_UWT.Table_Start, + Program_UWT.Table_End); + + -- If we did not get it, we might have a frame from code in a + -- stub or shared library. For code in stub we would have to + -- compute the first non-stub return location but this is not + -- the role of this subprogram, so let's just try to see if we + -- can get a result from the tables in shared libraries. + + if UWD_Address = -1 + and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0 + then + declare + Shlib_UWT : constant UWT := + U_get_shLib_unwind_table (Frame.cur_r19); + Shlib_Start : constant Address := + U_get_shLib_text_addr (Frame.cur_r19); + Rlo_Offset : constant Address := + Frame.cur_rlo - Shlib_Start; + begin + UWD_Address := U_get_unwind_entry (Rlo_Offset, + Frame.cur_rls, + Shlib_UWT.Table_Start, + Shlib_UWT.Table_End); + end; + end if; + + if UWD_Address /= -1 then + return To_UWD_Access (UWD_Address + Frame_Info_Offset); + else + return null; + end if; + end UWD_For_RLO_Of; + + -- Start of processing for Call_Chain + + begin + -- Fetch the state for this subprogram's frame and pop it so that we + -- start with an initial out_rlo "here". + + U_init_frame_record (Frame'Access); + Frame.top_sr0 := 0; + Frame.top_sr4 := 0; + + U_prep_frame_rec_for_unwind (Frame'Access); + + Pop_Success := Pop_Frame (Frame'Access); + + -- Skip the requested number of frames. + + for I in 1 .. Skip_Frames loop + Pop_Success := Pop_Frame (Frame'Access); + end loop; + + -- Loop popping frames and storing locations until either a problem + -- occurs, or the top of the call chain is reached, or the provided + -- array is full. + + loop + -- We have to test some conditions against the return location + -- as it is returned, so get it as is first. + + Code := Frame.out_rlo; + + exit when not Pop_Success or else Code = 0 or else J = Max_Len + 1; + + -- Compute the call point from the retrieved return location : + -- Mask the privilege bits and account for the delta between the + -- call site and the return point. + + Code := (Code and not Priv_Mask) - Rlo_Offset; + + if Code < Exclude_Min or else Code > Exclude_Max then + Trace (J) := Code; + J := J + 1; + end if; + + Pop_Success := Pop_Frame (Frame'Access); + end loop; + + Len := J - 1; + end Call_Chain; + +end System.Traceback; diff --git a/gcc/ada/s-traceb-mastop.adb b/gcc/ada/s-traceb-mastop.adb new file mode 100644 index 00000000000..1811c5a603b --- /dev/null +++ b/gcc/ada/s-traceb-mastop.adb @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-traces-default.adb b/gcc/ada/s-traces-default.adb new file mode 100644 index 00000000000..46822242a40 --- /dev/null +++ b/gcc/ada/s-traces-default.adb @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-traent-vms.adb b/gcc/ada/s-traent-vms.adb new file mode 100644 index 00000000000..532acad6e32 --- /dev/null +++ b/gcc/ada/s-traent-vms.adb @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K _ E N T R I E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003 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 body System.Traceback_Entries is + + ------------ + -- PC_For -- + ------------ + + function PC_For (TB_Entry : Traceback_Entry) return System.Address is + begin + return TB_Entry.PC; + end PC_For; + + ------------ + -- PV_For -- + ------------ + + function PV_For (TB_Entry : Traceback_Entry) return System.Address is + begin + return TB_Entry.PV; + end PV_For; + + ------------------ + -- TB_Entry_For -- + ------------------ + + function TB_Entry_For (PC : System.Address) return Traceback_Entry is + begin + return (PC => PC, PV => System.Null_Address); + end TB_Entry_For; + +end System.Traceback_Entries; + diff --git a/gcc/ada/s-traent-vms.ads b/gcc/ada/s-traent-vms.ads new file mode 100644 index 00000000000..0d27c197fff --- /dev/null +++ b/gcc/ada/s-traent-vms.ads @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K _ E N T R I E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003 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. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Alpha/OpenVMS version of this package + +package System.Traceback_Entries is + + type Traceback_Entry is record + PC : System.Address; + PV : System.Address; + end record; + + pragma Suppress_Initialization (Traceback_Entry); + + Null_TB_Entry : constant Traceback_Entry := + (PC => System.Null_Address, + PV => System.Null_Address); + + function PC_For (TB_Entry : Traceback_Entry) return System.Address; + function PV_For (TB_Entry : Traceback_Entry) return System.Address; + + function TB_Entry_For (PC : System.Address) return Traceback_Entry; + +end System.Traceback_Entries; + diff --git a/gcc/ada/s-trafor-default.adb b/gcc/ada/s-trafor-default.adb new file mode 100644 index 00000000000..8aa564463ad --- /dev/null +++ b/gcc/ada/s-trafor-default.adb @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-trafor-default.ads b/gcc/ada/s-trafor-default.ads new file mode 100644 index 00000000000..fe232beeea8 --- /dev/null +++ b/gcc/ada/s-trafor-default.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-tratas-default.adb b/gcc/ada/s-tratas-default.adb new file mode 100644 index 00000000000..0e18aed2d96 --- /dev/null +++ b/gcc/ada/s-tratas-default.adb @@ -0,0 +1,367 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/s-vaflop-vms.adb b/gcc/ada/s-vaflop-vms.adb new file mode 100644 index 00000000000..8b1bf031fa4 --- /dev/null +++ b/gcc/ada/s-vaflop-vms.adb @@ -0,0 +1,621 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2000 Free Software Foundation, Inc. -- +-- (Version for Alpha OpenVMS) -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 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. -- +-- -- +------------------------------------------------------------------------------ + +with System.IO; use System.IO; +with System.Machine_Code; use System.Machine_Code; + +package body System.Vax_Float_Operations is + + -- Ensure this gets compiled with -O to avoid extra (and possibly + -- improper) memory stores. + + pragma Optimize (Time); + + -- Declare the functions that do the conversions between floating-point + -- formats. Call the operands IEEE float so they get passed in + -- FP registers. + + function Cvt_G_T (X : T) return T; + function Cvt_T_G (X : T) return T; + function Cvt_T_F (X : T) return S; + + pragma Import (C, Cvt_G_T, "OTS$CVT_FLOAT_G_T"); + pragma Import (C, Cvt_T_G, "OTS$CVT_FLOAT_T_G"); + pragma Import (C, Cvt_T_F, "OTS$CVT_FLOAT_T_F"); + + -- In each of the conversion routines that are done with OTS calls, + -- we define variables of the corresponding IEEE type so that they are + -- passed and kept in the proper register class. + + ------------ + -- D_To_G -- + ------------ + + function D_To_G (X : D) return G is + A, B : T; + C : G; + + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", A), D'Asm_Input ("m", X)); + Asm ("cvtdg %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A)); + Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B)); + return C; + end D_To_G; + + ------------ + -- F_To_G -- + ------------ + + function F_To_G (X : F) return G is + A : T; + B : G; + + begin + Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X)); + Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A)); + return B; + end F_To_G; + + ------------ + -- F_To_S -- + ------------ + + function F_To_S (X : F) return S is + A : T; + B : S; + + begin + -- Because converting to a wider FP format is a no-op, we say + -- A is 64-bit even though we are loading 32 bits into it. + Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X)); + + B := S (Cvt_G_T (A)); + return B; + end F_To_S; + + ------------ + -- G_To_D -- + ------------ + + function G_To_D (X : G) return D is + A, B : T; + C : D; + + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); + Asm ("cvtgd %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A)); + Asm ("stg %1,%0", D'Asm_Output ("=m", C), T'Asm_Input ("f", B)); + return C; + end G_To_D; + + ------------ + -- G_To_F -- + ------------ + + function G_To_F (X : G) return F is + A : T; + B : S; + C : F; + + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); + Asm ("cvtgf %1,%0", S'Asm_Output ("=f", B), T'Asm_Input ("f", A)); + Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B)); + return C; + end G_To_F; + + ------------ + -- G_To_Q -- + ------------ + + function G_To_Q (X : G) return Q is + A : T; + B : Q; + + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); + Asm ("cvtgq %1,%0", Q'Asm_Output ("=f", B), T'Asm_Input ("f", A)); + return B; + end G_To_Q; + + ------------ + -- G_To_T -- + ------------ + + function G_To_T (X : G) return T is + A, B : T; + + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); + B := Cvt_G_T (A); + return B; + end G_To_T; + + ------------ + -- F_To_Q -- + ------------ + + function F_To_Q (X : F) return Q is + begin + return G_To_Q (F_To_G (X)); + end F_To_Q; + + ------------ + -- Q_To_F -- + ------------ + + function Q_To_F (X : Q) return F is + A : S; + B : F; + + begin + Asm ("cvtqf %1,%0", S'Asm_Output ("=f", A), Q'Asm_Input ("f", X)); + Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A)); + return B; + end Q_To_F; + + ------------ + -- Q_To_G -- + ------------ + + function Q_To_G (X : Q) return G is + A : T; + B : G; + + begin + Asm ("cvtqg %1,%0", T'Asm_Output ("=f", A), Q'Asm_Input ("f", X)); + Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A)); + return B; + end Q_To_G; + + ------------ + -- S_To_F -- + ------------ + + function S_To_F (X : S) return F is + A : S; + B : F; + + begin + A := Cvt_T_F (T (X)); + Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A)); + return B; + end S_To_F; + + ------------ + -- T_To_D -- + ------------ + + function T_To_D (X : T) return D is + begin + return G_To_D (T_To_G (X)); + end T_To_D; + + ------------ + -- T_To_G -- + ------------ + + function T_To_G (X : T) return G is + A : T; + B : G; + + begin + A := Cvt_T_G (X); + Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A)); + return B; + end T_To_G; + + ----------- + -- Abs_F -- + ----------- + + function Abs_F (X : F) return F is + A, B : S; + C : F; + + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X)); + Asm ("cpys $f31,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A)); + Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B)); + return C; + end Abs_F; + + ----------- + -- Abs_G -- + ----------- + + function Abs_G (X : G) return G is + A, B : T; + C : G; + + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); + Asm ("cpys $f31,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A)); + Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B)); + return C; + end Abs_G; + + ----------- + -- Add_F -- + ----------- + + function Add_F (X, Y : F) return F is + X1, Y1, R : S; + R1 : F; + + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); + Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); + Asm ("addf %1,%2,%0", S'Asm_Output ("=f", R), + (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); + Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R)); + return R1; + end Add_F; + + ----------- + -- Add_G -- + ----------- + + function Add_G (X, Y : G) return G is + X1, Y1, R : T; + R1 : G; + + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); + Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); + Asm ("addg %1,%2,%0", T'Asm_Output ("=f", R), + (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); + Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R)); + return R1; + end Add_G; + + -------------------- + -- Debug_Output_D -- + -------------------- + + procedure Debug_Output_D (Arg : D) is + begin + Put (D'Image (Arg)); + end Debug_Output_D; + + -------------------- + -- Debug_Output_F -- + -------------------- + + procedure Debug_Output_F (Arg : F) is + begin + Put (F'Image (Arg)); + end Debug_Output_F; + + -------------------- + -- Debug_Output_G -- + -------------------- + + procedure Debug_Output_G (Arg : G) is + begin + Put (G'Image (Arg)); + end Debug_Output_G; + + -------------------- + -- Debug_String_D -- + -------------------- + + Debug_String_Buffer : String (1 .. 32); + -- Buffer used by all Debug_String_x routines for returning result + + function Debug_String_D (Arg : D) return System.Address is + Image_String : constant String := D'Image (Arg) & ASCII.NUL; + Image_Size : constant Integer := Image_String'Length; + + begin + Debug_String_Buffer (1 .. Image_Size) := Image_String; + return Debug_String_Buffer (1)'Address; + end Debug_String_D; + + -------------------- + -- Debug_String_F -- + -------------------- + + function Debug_String_F (Arg : F) return System.Address is + Image_String : constant String := F'Image (Arg) & ASCII.NUL; + Image_Size : constant Integer := Image_String'Length; + + begin + Debug_String_Buffer (1 .. Image_Size) := Image_String; + return Debug_String_Buffer (1)'Address; + end Debug_String_F; + + -------------------- + -- Debug_String_G -- + -------------------- + + function Debug_String_G (Arg : G) return System.Address is + Image_String : constant String := G'Image (Arg) & ASCII.NUL; + Image_Size : constant Integer := Image_String'Length; + + begin + Debug_String_Buffer (1 .. Image_Size) := Image_String; + return Debug_String_Buffer (1)'Address; + end Debug_String_G; + + ----------- + -- Div_F -- + ----------- + + function Div_F (X, Y : F) return F is + X1, Y1, R : S; + + R1 : F; + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); + Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); + Asm ("divf %1,%2,%0", S'Asm_Output ("=f", R), + (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); + Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R)); + return R1; + end Div_F; + + ----------- + -- Div_G -- + ----------- + + function Div_G (X, Y : G) return G is + X1, Y1, R : T; + R1 : G; + + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); + Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); + Asm ("divg %1,%2,%0", T'Asm_Output ("=f", R), + (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); + Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R)); + return R1; + end Div_G; + + ---------- + -- Eq_F -- + ---------- + + function Eq_F (X, Y : F) return Boolean is + X1, Y1, R : S; + + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); + Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); + Asm ("cmpgeq %1,%2,%0", S'Asm_Output ("=f", R), + (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); + return R /= 0.0; + end Eq_F; + + ---------- + -- Eq_G -- + ---------- + + function Eq_G (X, Y : G) return Boolean is + X1, Y1, R : T; + + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); + Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); + Asm ("cmpgeq %1,%2,%0", T'Asm_Output ("=f", R), + (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); + return R /= 0.0; + end Eq_G; + + ---------- + -- Le_F -- + ---------- + + function Le_F (X, Y : F) return Boolean is + X1, Y1, R : S; + + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); + Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); + Asm ("cmpgle %1,%2,%0", S'Asm_Output ("=f", R), + (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); + return R /= 0.0; + end Le_F; + + ---------- + -- Le_G -- + ---------- + + function Le_G (X, Y : G) return Boolean is + X1, Y1, R : T; + + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); + Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); + Asm ("cmpgle %1,%2,%0", T'Asm_Output ("=f", R), + (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); + return R /= 0.0; + end Le_G; + + ---------- + -- Lt_F -- + ---------- + + function Lt_F (X, Y : F) return Boolean is + X1, Y1, R : S; + + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); + Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); + Asm ("cmpglt %1,%2,%0", S'Asm_Output ("=f", R), + (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); + return R /= 0.0; + end Lt_F; + + ---------- + -- Lt_G -- + ---------- + + function Lt_G (X, Y : G) return Boolean is + X1, Y1, R : T; + + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); + Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); + Asm ("cmpglt %1,%2,%0", T'Asm_Output ("=f", R), + (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); + return R /= 0.0; + end Lt_G; + + ----------- + -- Mul_F -- + ----------- + + function Mul_F (X, Y : F) return F is + X1, Y1, R : S; + R1 : F; + + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); + Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); + Asm ("mulf %1,%2,%0", S'Asm_Output ("=f", R), + (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); + Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R)); + return R1; + end Mul_F; + + ----------- + -- Mul_G -- + ----------- + + function Mul_G (X, Y : G) return G is + X1, Y1, R : T; + R1 : G; + + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); + Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); + Asm ("mulg %1,%2,%0", T'Asm_Output ("=f", R), + (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); + Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R)); + return R1; + end Mul_G; + + ----------- + -- Neg_F -- + ----------- + + function Neg_F (X : F) return F is + A, B : S; + C : F; + + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X)); + Asm ("cpysn %1,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A)); + Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B)); + return C; + end Neg_F; + + ----------- + -- Neg_G -- + ----------- + + function Neg_G (X : G) return G is + A, B : T; + C : G; + + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); + Asm ("cpysn %1,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A)); + Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B)); + return C; + end Neg_G; + + -------- + -- pd -- + -------- + + procedure pd (Arg : D) is + begin + Put_Line (D'Image (Arg)); + end pd; + + -------- + -- pf -- + -------- + + procedure pf (Arg : F) is + begin + Put_Line (F'Image (Arg)); + end pf; + + -------- + -- pg -- + -------- + + procedure pg (Arg : G) is + begin + Put_Line (G'Image (Arg)); + end pg; + + ----------- + -- Sub_F -- + ----------- + + function Sub_F (X, Y : F) return F is + X1, Y1, R : S; + R1 : F; + + begin + Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); + Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); + Asm ("subf %1,%2,%0", S'Asm_Output ("=f", R), + (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); + Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R)); + return R1; + end Sub_F; + + ----------- + -- Sub_G -- + ----------- + + function Sub_G (X, Y : G) return G is + X1, Y1, R : T; + R1 : G; + + begin + Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); + Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); + Asm ("subg %1,%2,%0", T'Asm_Output ("=f", R), + (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); + Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R)); + return R1; + end Sub_G; + +end System.Vax_Float_Operations; diff --git a/gcc/ada/s-vxwork-alpha.ads b/gcc/ada/s-vxwork-alpha.ads new file mode 100644 index 00000000000..6d5e424a33c --- /dev/null +++ b/gcc/ada/s-vxwork-alpha.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Alpha VxWorks version of this package. + +with Interfaces.C; + +package System.VxWorks is + pragma Preelaborate (System.VxWorks); + + package IC renames Interfaces.C; + + -- Floating point context record. Alpha version + + FP_NUM_DREGS : constant := 32; + type Fpx_Array is array (1 .. FP_NUM_DREGS) of IC.double; + + type FP_CONTEXT is record + fpx : Fpx_Array; + fpcsr : IC.long; + end record; + pragma Convention (C, FP_CONTEXT); + + Num_HW_Interrupts : constant := 256; + -- Number of entries in hardware interrupt vector table. + +end System.VxWorks; diff --git a/gcc/ada/s-vxwork-m68k.ads b/gcc/ada/s-vxwork-m68k.ads new file mode 100644 index 00000000000..a0f10be72a0 --- /dev/null +++ b/gcc/ada/s-vxwork-m68k.ads @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the M68K VxWorks version of this package. + +with Interfaces.C; + +package System.VxWorks is + pragma Preelaborate (System.VxWorks); + + package IC renames Interfaces.C; + + -- Floating point context record. 68K version + + FP_NUM_DREGS : constant := 8; + FP_STATE_FRAME_SIZE : constant := 216; + + type DOUBLEX is array (1 .. 12) of Interfaces.Unsigned_8; + pragma Pack (DOUBLEX); + for DOUBLEX'Size use 12 * 8; + + type DOUBLEX_Array is array (1 .. FP_NUM_DREGS) of DOUBLEX; + pragma Pack (DOUBLEX_Array); + for DOUBLEX_Array'Size use FP_NUM_DREGS * 12 * 8; + + type FPREG_SET is record + fpcr : IC.int; + fpsr : IC.int; + fpiar : IC.int; + fpx : DOUBLEX_Array; + end record; + + type Fp_State_Frame_Array is array (1 .. FP_STATE_FRAME_SIZE) of IC.char; + pragma Pack (Fp_State_Frame_Array); + for Fp_State_Frame_Array'Size use 8 * FP_STATE_FRAME_SIZE; + + type FP_CONTEXT is record + fpRegSet : FPREG_SET; + stateFrame : Fp_State_Frame_Array; + end record; + pragma Convention (C, FP_CONTEXT); + + Num_HW_Interrupts : constant := 256; + -- Number of entries in the hardware interrupt vector table + +end System.VxWorks; diff --git a/gcc/ada/s-vxwork-mips.ads b/gcc/ada/s-vxwork-mips.ads new file mode 100644 index 00000000000..2e31d728aed --- /dev/null +++ b/gcc/ada/s-vxwork-mips.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the MIPS VxWorks version of this package. + +with Interfaces.C; + +package System.VxWorks is + pragma Preelaborate (System.VxWorks); + + package IC renames Interfaces.C; + + -- Floating point context record. MIPS version + + FP_NUM_DREGS : constant := 16; + type Fpx_Array is array (1 .. FP_NUM_DREGS) of IC.double; + + type FP_CONTEXT is record + fpx : Fpx_Array; + fpcsr : IC.int; + end record; + pragma Convention (C, FP_CONTEXT); + + Num_HW_Interrupts : constant := 256; + -- Number of entries in hardware interrupt vector table. + +end System.VxWorks; diff --git a/gcc/ada/s-vxwork-ppc.ads b/gcc/ada/s-vxwork-ppc.ads new file mode 100644 index 00000000000..17118681fc3 --- /dev/null +++ b/gcc/ada/s-vxwork-ppc.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2001 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the PPC VxWorks version of this package. + +with Interfaces.C; + +package System.VxWorks is + pragma Preelaborate (System.VxWorks); + + package IC renames Interfaces.C; + + -- Floating point context record. PPC version + + FP_NUM_DREGS : constant := 32; + type Fpr_Array is array (1 .. FP_NUM_DREGS) of IC.double; + + type FP_CONTEXT is record + fpr : Fpr_Array; + fpcsr : IC.int; + pad : IC.int; + end record; + pragma Convention (C, FP_CONTEXT); + + Num_HW_Interrupts : constant := 256; + +end System.VxWorks; diff --git a/gcc/ada/s-vxwork-sparcv9.ads b/gcc/ada/s-vxwork-sparcv9.ads new file mode 100644 index 00000000000..4fc9fd156e3 --- /dev/null +++ b/gcc/ada/s-vxwork-sparcv9.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-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 the Sparc64 VxWorks version of this package. + +with Interfaces; + +package System.VxWorks is + pragma Preelaborate (System.VxWorks); + + -- Floating point context record. SPARCV9 version + + FP_NUM_DREGS : constant := 32; + + type RType is new Interfaces.Unsigned_64; + for RType'Alignment use 8; + + type Fpd_Array is array (1 .. FP_NUM_DREGS) of RType; + for Fpd_Array'Alignment use 8; + + type FP_CONTEXT is record + fpd : Fpd_Array; + fsr : RType; + end record; + + for FP_CONTEXT'Alignment use 8; + pragma Convention (C, FP_CONTEXT); + + Num_HW_Interrupts : constant := 256; + -- Number of entries in hardware interrupt vector table. + +end System.VxWorks; diff --git a/gcc/ada/s-vxwork-xscale.ads b/gcc/ada/s-vxwork-xscale.ads new file mode 100644 index 00000000000..4183ee6bb1f --- /dev/null +++ b/gcc/ada/s-vxwork-xscale.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-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 the Xscale VxWorks version of this package. + +package System.VxWorks is + pragma Preelaborate (System.VxWorks); + + -- Floating point context record. Xscale version + + -- There is no floating point unit on Xscale. The record definition + -- below matches what arch/arm/fppArmLib.h says. + + type FP_CONTEXT is record + Dummy : Integer; + end record; + + for FP_CONTEXT'Alignment use 4; + pragma Convention (C, FP_CONTEXT); + + Num_HW_Interrupts : constant := 256; + -- Number of entries in hardware interrupt vector table. + +end System.VxWorks; diff --git a/gcc/ada/symbols-vms.adb b/gcc/ada/symbols-vms.adb new file mode 100644 index 00000000000..c623e42b383 --- /dev/null +++ b/gcc/ada/symbols-vms.adb @@ -0,0 +1,743 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y M B O L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003 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. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VMS version of this package + +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Sequential_IO; +with Ada.Text_IO; use Ada.Text_IO; + +package body Symbols is + + Case_Sensitive : constant String := "case_sensitive="; + Symbol_Vector : constant String := "SYMBOL_VECTOR=("; + Equal_Data : constant String := "=DATA)"; + Equal_Procedure : constant String := "=PROCEDURE)"; + Gsmatch : constant String := "gsmatch=equal,"; + + Symbol_File_Name : String_Access := null; + -- Name of the symbol file + + Sym_Policy : Policy := Autonomous; + -- The symbol policy. Set by Initialize + + Major_ID : Integer := 1; + -- The Major ID. May be modified by Initialize if Library_Version is + -- specified or if it is read from the reference symbol file. + + Soft_Major_ID : Boolean := True; + -- False if library version is specified in procedure Initialize. + -- When True, Major_ID may be modified if found in the reference symbol + -- file. + + Minor_ID : Natural := 0; + -- The Minor ID. May be modified if read from the reference symbol file + + Soft_Minor_ID : Boolean := True; + -- False if symbol policy is Autonomous, if library version is specified + -- in procedure Initialize and is not the same as the major ID read from + -- the reference symbol file. When True, Minor_ID may be increased in + -- Compliant symbol policy. + + subtype Byte is Character; + -- Object files are stream of bytes, but some of these bytes, those for + -- the names of the symbols, are ASCII characters. + + package Byte_IO is new Ada.Sequential_IO (Byte); + use Byte_IO; + + type Number is mod 2**16; + -- 16 bits unsigned number for number of characters + + GSD : constant Number := 10; + -- Code for the Global Symbol Definition section + + C_SYM : constant Number := 1; + -- Code for a Symbol subsection + + V_DEF_Mask : constant Number := 2**1; + V_NORM_Mask : constant Number := 2**6; + + File : Byte_IO.File_Type; + -- Each object file is read as a stream of bytes (characters) + + B : Byte; + + Number_Of_Characters : Natural := 0; + -- The number of characters of each section + + -- The following variables are used by procedure Process when reading an + -- object file. + + Code : Number := 0; + Length : Natural := 0; + + Dummy : Number; + + Nchars : Natural := 0; + Flags : Number := 0; + + Symbol : String (1 .. 255); + LSymb : Natural; + + function Equal (Left, Right : Symbol_Data) return Boolean; + -- Test for equality of symbols + + procedure Get (N : out Number); + -- Read two bytes from the object file LSB first as unsigned 16 bit number + + procedure Get (N : out Natural); + -- Read two bytes from the object file, LSByte first, as a Natural + + + function Image (N : Integer) return String; + -- Returns the image of N, without the initial space + + ----------- + -- Equal -- + ----------- + + function Equal (Left, Right : Symbol_Data) return Boolean is + begin + return Left.Name /= null and then + Right.Name /= null and then + Left.Name.all = Right.Name.all and then + Left.Kind = Right.Kind and then + Left.Present = Right.Present; + end Equal; + + --------- + -- Get -- + --------- + + procedure Get (N : out Number) is + C : Byte; + LSByte : Number; + begin + Read (File, C); + LSByte := Byte'Pos (C); + Read (File, C); + N := LSByte + (256 * Byte'Pos (C)); + end Get; + + procedure Get (N : out Natural) is + Result : Number; + begin + Get (Result); + N := Natural (Result); + end Get; + + ----------- + -- Image -- + ----------- + + function Image (N : Integer) return String is + Result : constant String := N'Img; + begin + if Result (Result'First) = ' ' then + return Result (Result'First + 1 .. Result'Last); + + else + return Result; + end if; + end Image; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Symbol_File : String; + Reference : String; + Symbol_Policy : Policy; + Quiet : Boolean; + Version : String; + Success : out Boolean) + is + File : Ada.Text_IO.File_Type; + Line : String (1 .. 1_000); + Last : Natural; + + begin + -- Record the symbol file name + + Symbol_File_Name := new String'(Symbol_File); + + -- Record the policy + + Sym_Policy := Symbol_Policy; + + -- Record the version (Major ID) + + if Version = "" then + Major_ID := 1; + Soft_Major_ID := True; + + else + begin + Major_ID := Integer'Value (Version); + Soft_Major_ID := False; + + if Major_ID <= 0 then + raise Constraint_Error; + end if; + + exception + when Constraint_Error => + if not Quiet then + Put_Line ("Version """ & Version & """ is illegal."); + Put_Line ("On VMS, version must be a positive number"); + end if; + + Success := False; + return; + end; + end if; + + Minor_ID := 0; + Soft_Minor_ID := Sym_Policy /= Autonomous; + + -- Empty the symbol tables + + Symbol_Table.Set_Last (Original_Symbols, 0); + Symbol_Table.Set_Last (Complete_Symbols, 0); + + -- Assume that everything will be fine + + Success := True; + + -- If policy is not autonomous, attempt to read the reference file + + if Sym_Policy /= Autonomous then + begin + Open (File, In_File, Reference); + + exception + when Ada.Text_IO.Name_Error => + return; + + when X : others => + if not Quiet then + Put_Line ("could not open """ & Reference & """"); + Put_Line (Exception_Message (X)); + end if; + + Success := False; + return; + end; + + -- Read line by line + + while not End_Of_File (File) loop + Get_Line (File, Line, Last); + + -- Ignore empty lines + + if Last = 0 then + null; + + -- Ignore lines starting with "case_sensitive=" + + elsif Last > Case_Sensitive'Length + and then Line (1 .. Case_Sensitive'Length) = Case_Sensitive + then + null; + + -- Line starting with "SYMBOL_VECTOR=(" + + elsif Last > Symbol_Vector'Length + and then Line (1 .. Symbol_Vector'Length) = Symbol_Vector + then + + -- SYMBOL_VECTOR=(=DATA) + + if Last > Symbol_Vector'Length + Equal_Data'Length and then + Line (Last - Equal_Data'Length + 1 .. Last) = Equal_Data + then + Symbol_Table.Increment_Last (Original_Symbols); + Original_Symbols.Table + (Symbol_Table.Last (Original_Symbols)) := + (Name => + new String'(Line (Symbol_Vector'Length + 1 .. + Last - Equal_Data'Length)), + Kind => Data, + Present => True); + + -- SYMBOL_VECTOR=(=PROCEDURE) + + elsif Last > Symbol_Vector'Length + Equal_Procedure'Length + and then + Line (Last - Equal_Procedure'Length + 1 .. Last) = + Equal_Procedure + then + Symbol_Table.Increment_Last (Original_Symbols); + Original_Symbols.Table + (Symbol_Table.Last (Original_Symbols)) := + (Name => + new String'(Line (Symbol_Vector'Length + 1 .. + Last - Equal_Procedure'Length)), + Kind => Proc, + Present => True); + + -- Anything else is incorrectly formatted + + else + if not Quiet then + Put_Line ("symbol file """ & Reference & + """ is incorrectly formatted:"); + Put_Line ("""" & Line (1 .. Last) & """"); + end if; + + Close (File); + Success := False; + return; + end if; + + -- Lines with "gsmatch=equal,, + + elsif Last > Gsmatch'Length + and then Line (1 .. Gsmatch'Length) = Gsmatch + then + declare + Start : Positive := Gsmatch'Length + 1; + Finish : Positive := Start; + OK : Boolean := True; + ID : Integer; + + begin + loop + if Line (Finish) not in '0' .. '9' + or else Finish >= Last - 1 + then + OK := False; + exit; + end if; + + exit when Line (Finish + 1) = ','; + + Finish := Finish + 1; + end loop; + + if OK then + ID := Integer'Value (Line (Start .. Finish)); + OK := ID /= 0; + + -- If Soft_Major_ID is True, it means that + -- Library_Version was not specified. + + if Soft_Major_ID then + Major_ID := ID; + + -- If the Major ID in the reference file is different + -- from the Library_Version, then the Minor ID will be 0 + -- because there is no point in taking the Minor ID in + -- the reference file, or incrementing it. So, we set + -- Soft_Minor_ID to False, so that we don't modify + -- the Minor_ID later. + + elsif Major_ID /= ID then + Soft_Minor_ID := False; + end if; + + Start := Finish + 2; + Finish := Start; + + loop + if Line (Finish) not in '0' .. '9' then + OK := False; + exit; + end if; + + exit when Finish = Last; + + Finish := Finish + 1; + end loop; + + -- Only set Minor_ID if Soft_Minor_ID is True (see above) + + if OK and then Soft_Minor_ID then + Minor_ID := Integer'Value (Line (Start .. Finish)); + end if; + end if; + + -- If OK is not True, that means the line is not correctly + -- formatted. + + if not OK then + if not Quiet then + Put_Line ("symbol file """ & Reference & + """ is incorrectly formatted"); + Put_Line ("""" & Line (1 .. Last) & """"); + end if; + + Close (File); + Success := False; + return; + end if; + end; + + -- Anything else is incorrectly formatted + + else + if not Quiet then + Put_Line ("unexpected line in symbol file """ & + Reference & """"); + Put_Line ("""" & Line (1 .. Last) & """"); + end if; + + Close (File); + Success := False; + return; + end if; + end loop; + + Close (File); + end if; + end Initialize; + + ------------- + -- Process -- + ------------- + + procedure Process + (Object_File : String; + Success : out Boolean) + is + begin + -- Open the object file with Byte_IO. Return with Success = False if + -- this fails. + + begin + Open (File, In_File, Object_File); + exception + when others => + Put_Line + ("*** Unable to open object file """ & Object_File & """"); + Success := False; + return; + end; + + -- Assume that the object file has a correct format + + Success := True; + + -- Get the different sections one by one from the object file + + while not End_Of_File (File) loop + + Get (Code); + Get (Number_Of_Characters); + Number_Of_Characters := Number_Of_Characters - 4; + + -- If this is not a Global Symbol Definition section, skip to the + -- next section. + + if Code /= GSD then + + for J in 1 .. Number_Of_Characters loop + Read (File, B); + end loop; + + else + + -- Skip over the next 4 bytes + + Get (Dummy); + Get (Dummy); + Number_Of_Characters := Number_Of_Characters - 4; + + -- Get each subsection in turn + + loop + Get (Code); + Get (Nchars); + Get (Dummy); + Get (Flags); + Number_Of_Characters := Number_Of_Characters - 8; + Nchars := Nchars - 8; + + -- If this is a symbol and the V_DEF flag is set, get the + -- symbol. + + if Code = C_SYM and then ((Flags and V_DEF_Mask) /= 0) then + -- First, reach the symbol length + + for J in 1 .. 25 loop + Read (File, B); + Nchars := Nchars - 1; + Number_Of_Characters := Number_Of_Characters - 1; + end loop; + + Length := Byte'Pos (B); + LSymb := 0; + + -- Get the symbol characters + + for J in 1 .. Nchars loop + Read (File, B); + Number_Of_Characters := Number_Of_Characters - 1; + if Length > 0 then + LSymb := LSymb + 1; + Symbol (LSymb) := B; + Length := Length - 1; + end if; + end loop; + + -- Create the new Symbol + + declare + S_Data : Symbol_Data; + begin + S_Data.Name := new String'(Symbol (1 .. LSymb)); + + -- The symbol kind (Data or Procedure) depends on the + -- V_NORM flag. + + if (Flags and V_NORM_Mask) = 0 then + S_Data.Kind := Data; + + else + S_Data.Kind := Proc; + end if; + + -- Put the new symbol in the table + + Symbol_Table.Increment_Last (Complete_Symbols); + Complete_Symbols.Table + (Symbol_Table.Last (Complete_Symbols)) := S_Data; + end; + + else + -- As it is not a symbol subsection, skip to the next + -- subsection. + + for J in 1 .. Nchars loop + Read (File, B); + Number_Of_Characters := Number_Of_Characters - 1; + end loop; + end if; + + -- Exit the GSD section when number of characters reaches 0 + + exit when Number_Of_Characters = 0; + end loop; + end if; + end loop; + + -- The object file has been processed, close it + + Close (File); + + exception + -- For any exception, output an error message, close the object file + -- and return with Success = False. + + when X : others => + Put_Line ("unexpected exception raised while processing """ + & Object_File & """"); + Put_Line (Exception_Information (X)); + Close (File); + Success := False; + end Process; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize + (Quiet : Boolean; + Success : out Boolean) + is + File : Ada.Text_IO.File_Type; + -- The symbol file + + S_Data : Symbol_Data; + -- A symbol + + Cur : Positive := 1; + -- Most probable index in the Complete_Symbols of the current symbol + -- in Original_Symbol. + + Found : Boolean; + + begin + -- Nothing to be done if Initialize has never been called + + if Symbol_File_Name = null then + Success := False; + + else + + -- First find if the symbols in the reference symbol file are also + -- in the object files. Note that this is not done if the policy is + -- Autonomous, because no reference symbol file has been read. + + -- Expect the first symbol in the symbol file to also be the first + -- in Complete_Symbols. + + Cur := 1; + + for Index_1 in 1 .. Symbol_Table.Last (Original_Symbols) loop + S_Data := Original_Symbols.Table (Index_1); + Found := False; + + First_Object_Loop : + for Index_2 in Cur .. Symbol_Table.Last (Complete_Symbols) loop + if Equal (S_Data, Complete_Symbols.Table (Index_2)) then + Cur := Index_2 + 1; + Complete_Symbols.Table (Index_2).Present := False; + Found := True; + exit First_Object_Loop; + end if; + end loop First_Object_Loop; + + -- If the symbol could not be found between Cur and Last, try + -- before Cur. + + if not Found then + Second_Object_Loop : + for Index_2 in 1 .. Cur - 1 loop + if Equal (S_Data, Complete_Symbols.Table (Index_2)) then + Cur := Index_2 + 1; + Complete_Symbols.Table (Index_2).Present := False; + Found := True; + exit Second_Object_Loop; + end if; + end loop Second_Object_Loop; + end if; + + -- If the symbol is not found, mark it as such in the table + + if not Found then + if (not Quiet) or else Sym_Policy = Controlled then + Put_Line ("symbol """ & S_Data.Name.all & + """ is no longer present in the object files"); + end if; + + if Sym_Policy = Controlled then + Success := False; + return; + + elsif Soft_Minor_ID then + Minor_ID := Minor_ID + 1; + Soft_Minor_ID := False; + end if; + + Original_Symbols.Table (Index_1).Present := False; + Free (Original_Symbols.Table (Index_1).Name); + + if Soft_Minor_ID then + Minor_ID := Minor_ID + 1; + Soft_Minor_ID := False; + end if; + end if; + end loop; + + -- Append additional symbols, if any, to the Original_Symbols table + + for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop + S_Data := Complete_Symbols.Table (Index); + + if S_Data.Present then + + if Sym_Policy = Controlled then + Put_Line ("symbol """ & S_Data.Name.all & + """ is not in the reference symbol file"); + Success := False; + return; + + elsif Soft_Minor_ID then + Minor_ID := Minor_ID + 1; + Soft_Minor_ID := False; + end if; + + Symbol_Table.Increment_Last (Original_Symbols); + Original_Symbols.Table (Symbol_Table.Last (Original_Symbols)) := + S_Data; + Complete_Symbols.Table (Index).Present := False; + end if; + end loop; + + -- Create the symbol file + + Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all); + + Put (File, Case_Sensitive); + Put_Line (File, "yes"); + + -- Put a line in the symbol file for each symbol in the symbol table + + for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop + if Original_Symbols.Table (Index).Present then + Put (File, Symbol_Vector); + Put (File, Original_Symbols.Table (Index).Name.all); + + if Original_Symbols.Table (Index).Kind = Data then + Put_Line (File, Equal_Data); + + else + Put_Line (File, Equal_Procedure); + end if; + + Free (Original_Symbols.Table (Index).Name); + end if; + end loop; + + Put (File, Case_Sensitive); + Put_Line (File, "NO"); + + -- Put the version IDs + + Put (File, Gsmatch); + Put (File, Image (Major_ID)); + Put (File, ','); + Put_Line (File, Image (Minor_ID)); + + -- And we are done + + Close (File); + + -- Reset both tables + + Symbol_Table.Set_Last (Original_Symbols, 0); + Symbol_Table.Set_Last (Complete_Symbols, 0); + + -- Clear the symbol file name + + Free (Symbol_File_Name); + + Success := True; + end if; + + exception + when X : others => + Put_Line ("unexpected exception raised while finalizing """ + & Symbol_File_Name.all & """"); + Put_Line (Exception_Information (X)); + Success := False; + end Finalize; + +end Symbols; diff --git a/gcc/ada/system-aix.ads b/gcc/ada/system-aix.ads new file mode 100644 index 00000000000..fa28445a423 --- /dev/null +++ b/gcc/ada/system-aix.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (AIX/PPC Version) -- +-- -- +-- 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 := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := False; + 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 := True; + +end System; diff --git a/gcc/ada/system-freebsd-x86.ads b/gcc/ada/system-freebsd-x86.ads new file mode 100644 index 00000000000..a7371a2d9a2 --- /dev/null +++ b/gcc/ada/system-freebsd-x86.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (FreeBSD/x86 Version) -- +-- -- +-- 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 := 0.000_001; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := False; + 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 := True; + +end System; diff --git a/gcc/ada/system-hpux.ads b/gcc/ada/system-hpux.ads new file mode 100644 index 00000000000..3b971a587f4 --- /dev/null +++ b/gcc/ada/system-hpux.ads @@ -0,0 +1,226 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (HP-UX Version) -- +-- -- +-- 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 := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := False; + 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 := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + 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; + + -------------------------- + -- Underlying Priorities -- + --------------------------- + + -- Important note: this section of the file must come AFTER the + -- definition of the system implementation parameters to ensure + -- that the value of these parameters is available for analysis + -- of the declarations here (using Rtsfind at compile time). + + -- The underlying priorities table provides a generalized mechanism + -- for mapping from Ada priorities to system priorities. In some + -- cases a 1-1 mapping is not the convenient or optimal choice. + + -- For HP/UX DCE Threads, we use the full range of 31 priorities + -- in the Ada model, but map them by compression onto the more limited + -- range of priorities available in HP/UX. + -- For POSIX Threads, this table is ignored. + + -- To replace the default values of the Underlying_Priorities mapping, + -- copy this source file into your build directory, edit the file to + -- reflect your desired behavior, and recompile with the command: + + -- $ gcc -c -O2 -gnatpgn system.ads + + -- then recompile the run-time parts that depend on this package: + + -- $ gnatmake -a -gnatn -O2 + + -- then force rebuilding your application if you need different options: + + -- $ gnatmake -f + + type Priorities_Mapping is array (Any_Priority) of Integer; + pragma Suppress_Initialization (Priorities_Mapping); + -- Suppress initialization in case gnat.adc specifies Normalize_Scalars + + Underlying_Priorities : constant Priorities_Mapping := + + (Priority'First => 16, + + 1 => 17, + 2 => 18, + 3 => 18, + 4 => 18, + 5 => 18, + 6 => 19, + 7 => 19, + 8 => 19, + 9 => 20, + 10 => 20, + 11 => 21, + 12 => 21, + 13 => 22, + 14 => 23, + + Default_Priority => 24, + + 16 => 25, + 17 => 25, + 18 => 25, + 19 => 26, + 20 => 26, + 21 => 26, + 22 => 27, + 23 => 27, + 24 => 27, + 25 => 28, + 26 => 28, + 27 => 29, + 28 => 29, + 29 => 30, + + Priority'Last => 30, + + Interrupt_Priority => 31); + +end System; diff --git a/gcc/ada/system-interix.ads b/gcc/ada/system-interix.ads new file mode 100644 index 00000000000..11058290e59 --- /dev/null +++ b/gcc/ada/system-interix.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (OpenNT/Interix Version) -- +-- -- +-- 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 := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := False; + 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 := True; + +end System; diff --git a/gcc/ada/system-irix-n32.ads b/gcc/ada/system-irix-n32.ads new file mode 100644 index 00000000000..398a355899f --- /dev/null +++ b/gcc/ada/system-irix-n32.ads @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (SGI Irix, n32 ABI) -- +-- -- +-- Copyright (C) 1992-2004 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 := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := False; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := True; + 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 := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + 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 := True; + + -- Note: Denorm is False because denormals are not supported on the + -- R10000, and we want the code to be valid for this processor. + +end System; diff --git a/gcc/ada/system-irix-o32.ads b/gcc/ada/system-irix-o32.ads new file mode 100644 index 00000000000..7ccbe6c65eb --- /dev/null +++ b/gcc/ada/system-irix-o32.ads @@ -0,0 +1,153 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (SGI Irix, o32 ABI) -- +-- -- +-- Copyright (C) 1992-2004 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 := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := False; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := True; + 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 := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + 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 := True; + + -- Note: Denorm is False because denormals are not supported on the + -- R10000, and we want the code to be valid for this processor. + +end System; diff --git a/gcc/ada/system-linux-x86.ads b/gcc/ada/system-linux-x86.ads new file mode 100644 index 00000000000..8bcf7808221 --- /dev/null +++ b/gcc/ada/system-linux-x86.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/x86 Version) -- +-- -- +-- 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 := 0.000_001; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + 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 := True; + +end System; diff --git a/gcc/ada/system-linux-x86_64.ads b/gcc/ada/system-linux-x86_64.ads new file mode 100644 index 00000000000..37a495d8870 --- /dev/null +++ b/gcc/ada/system-linux-x86_64.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/x86-64 Version) -- +-- -- +-- 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 := 0.000_001; + + -- 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) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +private + + 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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + 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 := True; + +end System; diff --git a/gcc/ada/system-lynxos-ppc.ads b/gcc/ada/system-lynxos-ppc.ads new file mode 100644 index 00000000000..caeae17a168 --- /dev/null +++ b/gcc/ada/system-lynxos-ppc.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (LynxOS PPC Version) -- +-- -- +-- 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 := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 254; + Max_Interrupt_Priority : constant Positive := 255; + + subtype Any_Priority is Integer range 0 .. 255; + subtype Priority is Any_Priority range 0 .. 254; + subtype Interrupt_Priority is Any_Priority range 255 .. 255; + + Default_Priority : constant Priority := 15; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := False; + 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 := True; + +end System; diff --git a/gcc/ada/system-lynxos-x86.ads b/gcc/ada/system-lynxos-x86.ads new file mode 100644 index 00000000000..130b5f0d451 --- /dev/null +++ b/gcc/ada/system-lynxos-x86.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (LynxOS x86 Version) -- +-- -- +-- 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 := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 254; + Max_Interrupt_Priority : constant Positive := 255; + + subtype Any_Priority is Integer range 0 .. 255; + subtype Priority is Any_Priority range 0 .. 254; + subtype Interrupt_Priority is Any_Priority range 255 .. 255; + + Default_Priority : constant Priority := 15; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := False; + 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 := True; + +end System; diff --git a/gcc/ada/system-mingw.ads b/gcc/ada/system-mingw.ads new file mode 100644 index 00000000000..9316644e0d9 --- /dev/null +++ b/gcc/ada/system-mingw.ads @@ -0,0 +1,208 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (NT Version) -- +-- -- +-- 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 := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := True; + 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; + + --------------------------- + -- Underlying Priorities -- + --------------------------- + + -- Important note: this section of the file must come AFTER the + -- definition of the system implementation parameters to ensure + -- that the value of these parameters is available for analysis + -- of the declarations here (using Rtsfind at compile time). + + -- The underlying priorities table provides a generalized mechanism + -- for mapping from Ada priorities to system priorities. In some + -- cases a 1-1 mapping is not the convenient or optimal choice. + + type Priorities_Mapping is array (Any_Priority) of Integer; + pragma Suppress_Initialization (Priorities_Mapping); + -- Suppress initialization in case gnat.adc specifies Normalize_Scalars + + -- On NT, the default mapping preserves the standard 31 priorities + -- of the Ada model, but maps them using compression onto the 7 + -- priority levels available in NT. + + -- To replace the default values of the Underlying_Priorities mapping, + -- copy this source file into your build directory, edit the file to + -- reflect your desired behavior, and recompile with the command: + + -- $ gcc -c -O3 -gnatpgn system.ads + + -- then recompile the run-time parts that depend on this package: + + -- $ gnatmake -a -gnatn -O3 + + -- then force rebuilding your application if you need different options: + + -- $ gnatmake -f + + Underlying_Priorities : constant Priorities_Mapping := + + (Priority'First .. 1 => -15, + + 2 .. Default_Priority - 2 => -2, + + Default_Priority - 1 => -1, + + Default_Priority => 0, + + Default_Priority + 1 .. 19 => 1, + + 20 .. Priority'Last => 2, + + Interrupt_Priority => 15); + + pragma Linker_Options ("-Wl,--stack=0x2000000"); + -- This is used to change the default stack (32 MB) size for non tasking + -- programs. We change this value for GNAT on Windows here because the + -- binutils on this platform have switched to a too low value for Ada + -- programs. Note that we also set the stack size for tasking programs in + -- System.Task_Primitives.Operations. + +end System; diff --git a/gcc/ada/system-os2.ads b/gcc/ada/system-os2.ads new file mode 100644 index 00000000000..17acb5bc21e --- /dev/null +++ b/gcc/ada/system-os2.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (OS/2 Version) -- +-- -- +-- 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 := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + Front_End_ZCX_Support : constant Boolean := True; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-solaris-sparc.ads b/gcc/ada/system-solaris-sparc.ads new file mode 100644 index 00000000000..80621a76517 --- /dev/null +++ b/gcc/ada/system-solaris-sparc.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (SUN Solaris Version) -- +-- -- +-- 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 := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := True; + 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 := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + 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 := True; + +end System; diff --git a/gcc/ada/system-solaris-sparcv9.ads b/gcc/ada/system-solaris-sparcv9.ads new file mode 100644 index 00000000000..dca552ebc5a --- /dev/null +++ b/gcc/ada/system-solaris-sparcv9.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Solaris Sparcv9 Version) -- +-- -- +-- 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 := 0.01; + + -- 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 := High_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := True; + 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 := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + 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 := True; + +end System; diff --git a/gcc/ada/system-solaris-x86.ads b/gcc/ada/system-solaris-x86.ads new file mode 100644 index 00000000000..d48b684f84c --- /dev/null +++ b/gcc/ada/system-solaris-x86.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (x86 Solaris Version) -- +-- -- +-- 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 := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := True; + 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 := False; + ZCX_By_Default : constant Boolean := False; + GCC_ZCX_Support : constant Boolean := False; + Front_End_ZCX_Support : constant Boolean := True; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + +end System; diff --git a/gcc/ada/system-tru64.ads b/gcc/ada/system-tru64.ads new file mode 100644 index 00000000000..f0067b37f84 --- /dev/null +++ b/gcc/ada/system-tru64.ads @@ -0,0 +1,221 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (DEC Unix Version) -- +-- -- +-- 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 / 1024.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) + + Max_Priority : constant Positive := 60; + Max_Interrupt_Priority : constant Positive := 63; + + subtype Any_Priority is Integer range 0 .. 63; + subtype Priority is Any_Priority range 0 .. 60; + subtype Interrupt_Priority is Any_Priority range 61 .. 63; + + Default_Priority : constant Priority := 30; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := False; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := True; + Stack_Check_Probes : constant Boolean := True; + 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 := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + 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 := True; + + -- Note: Denorm is False because denormals are only handled properly + -- if the -mieee switch is set, and we do not require this usage. + + --------------------------- + -- Underlying Priorities -- + --------------------------- + + -- Important note: this section of the file must come AFTER the + -- definition of the system implementation parameters to ensure + -- that the value of these parameters is available for analysis + -- of the declarations here (using Rtsfind at compile time). + + -- The underlying priorities table provides a generalized mechanism + -- for mapping from Ada priorities to system priorities. In some + -- cases a 1-1 mapping is not the convenient or optimal choice. + + -- For Dec Unix 4.0d, we use a default 1-to-1 mapping that provides + -- the full range of 64 priorities available from the operating system. + + -- On DU prior to 4.0d, less than 64 priorities are available so there + -- are two possibilities: + + -- Limit your range of priorities to the range provided by the + -- OS (e.g 16 .. 32 on 4.0b) + + -- Replace the standard table as described below + + -- To replace the default values of the Underlying_Priorities mapping, + -- copy this source file into your build directory, edit the file to + -- reflect your desired behavior, and recompile with the command: + + -- $ gcc -c -O3 -gnatpgn system.ads + + -- then recompile the run-time parts that depend on this package: + + -- $ gnatmake -a -gnatn -O3 + + -- then force rebuilding your application if you need different options: + + -- $ gnatmake -f + + type Priorities_Mapping is array (Any_Priority) of Integer; + pragma Suppress_Initialization (Priorities_Mapping); + -- Suppress initialization in case gnat.adc specifies Normalize_Scalars + + Underlying_Priorities : constant Priorities_Mapping := + + (Priority'First => 0, + + 1 => 1, 2 => 2, 3 => 3, 4 => 4, 5 => 5, + 6 => 6, 7 => 7, 8 => 8, 9 => 9, 10 => 10, + 11 => 11, 12 => 12, 13 => 13, 14 => 14, 15 => 15, + 16 => 16, 17 => 17, 18 => 18, 19 => 19, 20 => 20, + 21 => 21, 22 => 22, 23 => 23, 24 => 24, 25 => 25, + 26 => 26, 27 => 27, 28 => 28, 29 => 29, + + Default_Priority => 30, + + 31 => 31, 32 => 32, 33 => 33, 34 => 34, 35 => 35, + 36 => 36, 37 => 37, 38 => 38, 39 => 39, 40 => 40, + 41 => 41, 42 => 42, 43 => 43, 44 => 44, 45 => 45, + 46 => 46, 47 => 47, 48 => 48, 49 => 49, 50 => 50, + 51 => 51, 52 => 52, 53 => 53, 54 => 54, 55 => 55, + 56 => 56, 57 => 57, 58 => 58, 59 => 59, + + Priority'Last => 60, + + 61 => 61, 62 => 62, + + Interrupt_Priority'Last => 63); + +end System; diff --git a/gcc/ada/system-unixware.ads b/gcc/ada/system-unixware.ads new file mode 100644 index 00000000000..01404ee32aa --- /dev/null +++ b/gcc/ada/system-unixware.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (SCO UnixWare Version) -- +-- -- +-- 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 := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := True; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + 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 := False; + 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 := True; + +end System; diff --git a/gcc/ada/system-vms-zcx.ads b/gcc/ada/system-vms-zcx.ads new file mode 100644 index 00000000000..3ba5e692195 --- /dev/null +++ b/gcc/ada/system-vms-zcx.ads @@ -0,0 +1,236 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (OpenVMS GCC_ZCX DEC Threads Version) -- +-- -- +-- Copyright (C) 2002-2004 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 := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := False; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Functions_Return_By_DSP : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := True; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := True; + Stack_Check_Probes : constant Boolean := True; + 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 := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + 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; + + -------------------------- + -- Underlying Priorities -- + --------------------------- + + -- Important note: this section of the file must come AFTER the + -- definition of the system implementation parameters to ensure + -- that the value of these parameters is available for analysis + -- of the declarations here (using Rtsfind at compile time). + + -- The underlying priorities table provides a generalized mechanism + -- for mapping from Ada priorities to system priorities. In some + -- cases a 1-1 mapping is not the convenient or optimal choice. + + -- For DEC Threads OpenVMS, we use the full range of 31 priorities + -- in the Ada model, but map them by compression onto the more limited + -- range of priorities available in OpenVMS. + + -- To replace the default values of the Underlying_Priorities mapping, + -- copy this source file into your build directory, edit the file to + -- reflect your desired behavior, and recompile with the command: + + -- $ gcc -c -O3 -gnatpgn system.ads + + -- then recompile the run-time parts that depend on this package: + + -- $ gnatmake -a -gnatn -O3 + + -- then force rebuilding your application if you need different options: + + -- $ gnatmake -f + + type Priorities_Mapping is array (Any_Priority) of Integer; + pragma Suppress_Initialization (Priorities_Mapping); + -- Suppress initialization in case gnat.adc specifies Normalize_Scalars + + Underlying_Priorities : constant Priorities_Mapping := + + (Priority'First => 16, + + 1 => 17, + 2 => 18, + 3 => 18, + 4 => 18, + 5 => 18, + 6 => 19, + 7 => 19, + 8 => 19, + 9 => 20, + 10 => 20, + 11 => 21, + 12 => 21, + 13 => 22, + 14 => 23, + + Default_Priority => 24, + + 16 => 25, + 17 => 25, + 18 => 25, + 19 => 26, + 20 => 26, + 21 => 26, + 22 => 27, + 23 => 27, + 24 => 27, + 25 => 28, + 26 => 28, + 27 => 29, + 28 => 29, + 29 => 30, + + Priority'Last => 30, + + Interrupt_Priority => 31); + + ---------------------------- + -- Special VMS Interfaces -- + ---------------------------- + + procedure Lib_Stop (I : in Integer); + pragma Interface (C, Lib_Stop); + pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); + -- Interface to VMS condition handling. Used by RTSfind and pragma + -- {Import,Export}_Exception. Put here because this is the only + -- VMS specific package that doesn't drag in tasking. + +end System; diff --git a/gcc/ada/system-vms.ads b/gcc/ada/system-vms.ads new file mode 100644 index 00000000000..fc4fb2e6d6f --- /dev/null +++ b/gcc/ada/system-vms.ads @@ -0,0 +1,236 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (OpenVMS DEC Threads Version) -- +-- -- +-- Copyright (C) 1992-2004 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 := 0.01; + + -- Storage-related Declarations + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := Low_Order_First; + + -- Priority-related Declarations (RM D.1) + + Max_Priority : constant Positive := 30; + Max_Interrupt_Priority : constant Positive := 31; + + subtype Any_Priority is Integer range 0 .. 31; + subtype Priority is Any_Priority range 0 .. 30; + subtype Interrupt_Priority is Any_Priority range 31 .. 31; + + Default_Priority : constant Priority := 15; + +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 := True; + Configurable_Run_Time : constant Boolean := False; + Denorm : constant Boolean := False; + Duration_32_Bits : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; + Fractional_Fixed_Ops : constant Boolean := False; + Frontend_Layout : constant Boolean := False; + Functions_Return_By_DSP : constant Boolean := False; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + OpenVMS : constant Boolean := True; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := True; + Stack_Check_Probes : constant Boolean := True; + 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 := False; + ZCX_By_Default : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := False; + Front_End_ZCX_Support : constant Boolean := True; + + -- Obsolete entries, to be removed eventually (bootstrap issues!) + + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := False; + + -------------------------- + -- Underlying Priorities -- + --------------------------- + + -- Important note: this section of the file must come AFTER the + -- definition of the system implementation parameters to ensure + -- that the value of these parameters is available for analysis + -- of the declarations here (using Rtsfind at compile time). + + -- The underlying priorities table provides a generalized mechanism + -- for mapping from Ada priorities to system priorities. In some + -- cases a 1-1 mapping is not the convenient or optimal choice. + + -- For DEC Threads OpenVMS, we use the full range of 31 priorities + -- in the Ada model, but map them by compression onto the more limited + -- range of priorities available in OpenVMS. + + -- To replace the default values of the Underlying_Priorities mapping, + -- copy this source file into your build directory, edit the file to + -- reflect your desired behavior, and recompile with the command: + + -- $ gcc -c -O3 -gnatpgn system.ads + + -- then recompile the run-time parts that depend on this package: + + -- $ gnatmake -a -gnatn -O3 + + -- then force rebuilding your application if you need different options: + + -- $ gnatmake -f + + type Priorities_Mapping is array (Any_Priority) of Integer; + pragma Suppress_Initialization (Priorities_Mapping); + -- Suppress initialization in case gnat.adc specifies Normalize_Scalars + + Underlying_Priorities : constant Priorities_Mapping := + + (Priority'First => 16, + + 1 => 17, + 2 => 18, + 3 => 18, + 4 => 18, + 5 => 18, + 6 => 19, + 7 => 19, + 8 => 19, + 9 => 20, + 10 => 20, + 11 => 21, + 12 => 21, + 13 => 22, + 14 => 23, + + Default_Priority => 24, + + 16 => 25, + 17 => 25, + 18 => 25, + 19 => 26, + 20 => 26, + 21 => 26, + 22 => 27, + 23 => 27, + 24 => 27, + 25 => 28, + 26 => 28, + 27 => 29, + 28 => 29, + 29 => 30, + + Priority'Last => 30, + + Interrupt_Priority => 31); + + ---------------------------- + -- Special VMS Interfaces -- + ---------------------------- + + procedure Lib_Stop (I : in Integer); + pragma Interface (C, Lib_Stop); + pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); + -- Interface to VMS condition handling. Used by RTSfind and pragma + -- {Import,Export}_Exception. Put here because this is the only + -- VMS specific package that doesn't drag in tasking. + +end System; diff --git a/gcc/ada/system-vxworks-alpha.ads b/gcc/ada/system-vxworks-alpha.ads new file mode 100644 index 00000000000..12bbec478ff --- /dev/null +++ b/gcc/ada/system-vxworks-alpha.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- 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; diff --git a/gcc/ada/system-vxworks-m68k.ads b/gcc/ada/system-vxworks-m68k.ads new file mode 100644 index 00000000000..3e1e3cf9895 --- /dev/null +++ b/gcc/ada/system-vxworks-m68k.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks version M68K) -- +-- -- +-- 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 := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + + -- Priority-related Declarations (RM D.1) + + -- 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 := True; + 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 := False; + 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; diff --git a/gcc/ada/system-vxworks-mips.ads b/gcc/ada/system-vxworks-mips.ads new file mode 100644 index 00000000000..19c96d0d6ea --- /dev/null +++ b/gcc/ada/system-vxworks-mips.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks Version Mips) -- +-- -- +-- 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 := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + + -- Priority-related Declarations (RM D.1) + + -- 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; diff --git a/gcc/ada/system-vxworks-ppc.ads b/gcc/ada/system-vxworks-ppc.ads new file mode 100644 index 00000000000..bcb415c0277 --- /dev/null +++ b/gcc/ada/system-vxworks-ppc.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks Version PPC) -- +-- -- +-- Copyright (C) 1992-2004 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 := 32; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + + -- Priority-related Declarations (RM D.1) + + -- 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 := True; + 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 := True; + 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; diff --git a/gcc/ada/system-vxworks-sparcv9.ads b/gcc/ada/system-vxworks-sparcv9.ads new file mode 100644 index 00000000000..8ddf3b06a6a --- /dev/null +++ b/gcc/ada/system-vxworks-sparcv9.ads @@ -0,0 +1,160 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks Version Sparc/64) -- +-- -- +-- 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 + + -- VxWorks for UltraSparc uses 64bit words but 32bit pointers + + type Address is private; + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 32; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + + -- Priority-related Declarations (RM D.1) + + -- 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 := True; + 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; diff --git a/gcc/ada/system-vxworks-xscale.ads b/gcc/ada/system-vxworks-xscale.ads new file mode 100644 index 00000000000..1fa021d5187 --- /dev/null +++ b/gcc/ada/system-vxworks-xscale.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks Version Xscale) -- +-- -- +-- 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 := 32; + Memory_Size : constant := 2 ** 32; + + -- 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 := True; + 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;