41intnam.ads, [...]: Merge in ACT changes.
* 41intnam.ads, 42intnam.ads, 4aintnam.ads, 4cintnam.ads, 4dintnam.ads, 4gintnam.ads, 4hintnam.ads, 4lintnam.ads, 4mintnam.ads, 4pintnam.ads, 4rintnam.ads, 4sintnam.ads, 4uintnam.ads, 4vcalend.adb, 4zintnam.ads, 52system.ads, 5amastop.adb, 5asystem.ads, 5ataprop.adb, 5atpopsp.adb, 5avxwork.ads, 5bosinte.adb, 5bsystem.ads, 5esystem.ads, 5fsystem.ads, 5ftaprop.adb, 5ginterr.adb, 5gmastop.adb, 5gsystem.ads, 5gtaprop.adb, 5gtasinf.adb, 5gtasinf.ads, 5hparame.ads, 5hsystem.ads, 5htaprop.adb, 5htraceb.adb, 5itaprop.adb, 5ksystem.ads, 5kvxwork.ads, 5lintman.adb, 5lsystem.ads, 5mvxwork.ads, 5ninmaop.adb, 5nosinte.ads, 5ntaprop.adb, 5ointerr.adb, 5omastop.adb, 5oosinte.adb, 5osystem.ads, 5otaprop.adb, 5otaspri.ads, 5pvxwork.ads, 5qtaprop.adb, 5sintman.adb, 5ssystem.ads, 5staprop.adb, 5stpopse.adb, 5svxwork.ads, 5tosinte.ads, 5uintman.adb, 5vasthan.adb, 5vinmaop.adb, 5vinterr.adb, 5vintman.adb, 5vmastop.adb, 5vparame.ads, 5vsystem.ads, 5vtaprop.adb, 5vtpopde.adb, 5wmemory.adb, 5wsystem.ads, 5wtaprop.adb, 5ysystem.ads, 5zinterr.adb, 5zintman.adb, 5zosinte.adb, 5zosinte.ads, 5zsystem.ads, 5ztaprop.adb, 6vcpp.adb, 6vcstrea.adb, 7sintman.adb, 7staprop.adb, 7stpopsp.adb, 9drpc.adb, Make-lang.in, Makefile.in, a-caldel.adb, a-comlin.ads, a-dynpri.adb, a-except.adb, a-except.ads, a-finali.adb, a-ncelfu.ads, a-reatim.adb, a-retide.adb, a-stream.ads, a-ststio.adb, a-ststio.ads, a-stwifi.adb, a-tags.adb, a-tasatt.adb, a-textio.adb, a-tideau.adb, a-tiflau.adb, a-tigeau.adb, a-tigeau.ads, a-tiinau.adb, a-timoau.adb, a-witeio.adb, a-wtdeau.adb, a-wtenau.adb, a-wtflau.adb, a-wtgeau.adb, a-wtgeau.ads, a-wtinau.adb, a-wtmoau.adb, ada-tree.def, ada-tree.h, adaint.c, adaint.h, ali-util.adb, ali.adb, ali.ads, atree.adb, atree.ads, atree.h, back_end.adb, bcheck.adb, bindgen.adb, bindusg.adb, checks.adb, comperr.adb, config-lang.in, csets.adb, csets.ads, cstand.adb, cstreams.c, debug.adb, debug.ads, decl.c, einfo.adb, einfo.ads, einfo.h, elists.h, errout.adb, errout.ads, eval_fat.adb, exp_aggr.adb, exp_attr.adb, exp_ch11.adb, exp_ch12.adb, exp_ch13.adb, exp_ch2.adb, exp_ch3.adb, exp_ch3.ads, exp_ch4.adb, exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_ch7.ads, exp_ch9.adb, exp_ch9.ads, exp_dbug.adb, exp_dbug.ads, exp_disp.ads, exp_dist.adb, exp_fixd.adb, exp_intr.adb, exp_pakd.adb, exp_prag.adb, exp_strm.adb, exp_util.adb, exp_util.ads, expander.adb, expect.c, fe.h, fmap.adb, fmap.ads, fname-uf.adb, freeze.adb, frontend.adb, g-awk.adb, g-cgideb.adb, g-comlin.adb, g-comlin.ads, g-debpoo.adb, g-dirope.adb, g-dirope.ads, g-dyntab.adb, g-expect.adb, g-expect.ads, g-io.ads, g-io_aux.adb, g-io_aux.ads, g-locfil.adb, g-locfil.ads, g-os_lib.adb, g-os_lib.ads, g-regexp.adb, g-regpat.adb, g-socket.adb, g-socket.ads, g-spipat.adb, g-table.adb, g-trasym.adb, g-trasym.ads, gigi.h, gmem.c, gnat1drv.adb, gnatbind.adb, gnatbl.c, gnatchop.adb, gnatcmd.adb, gnatdll.adb, gnatfind.adb, gnatlbr.adb, gnatlink.adb, gnatls.adb, gnatmem.adb, gnatprep.adb, gnatvsn.ads, gnatxref.adb, hlo.adb, hostparm.ads, i-cobol.adb, i-cpp.adb, i-cstrea.ads, i-cstrin.adb, i-pacdec.adb, i-vxwork.ads, impunit.adb, init.c, inline.adb, io-aux.c, layout.adb, lib-load.adb, lib-util.adb, lib-writ.adb, lib-writ.ads, lib-xref.adb, lib-xref.ads, lib.adb, lib.ads, make.adb, makeusg.adb, mdll.adb, memroot.adb, misc.c, mlib-tgt.adb, mlib-utl.adb, mlib-utl.ads, mlib.adb, namet.adb, namet.ads, namet.h, nlists.h, nmake.adb, nmake.ads, nmake.adt, opt.adb, opt.ads, osint.adb, osint.ads, output.adb, output.ads, par-ch2.adb, par-ch3.adb, par-ch5.adb, par-prag.adb, par-tchk.adb, par-util.adb, par.adb, prj-attr.adb, prj-dect.adb, prj-env.adb, prj-env.ads, prj-nmsc.adb, prj-part.adb, prj-proc.adb, prj-strt.adb, prj-tree.adb, prj-tree.ads, prj.adb, prj.ads, raise.c, raise.h, repinfo.adb, restrict.adb, restrict.ads, rident.ads, rtsfind.adb, rtsfind.ads, s-arit64.adb, s-asthan.adb, s-atacco.adb, s-atacco.ads, s-auxdec.adb, s-crc32.adb, s-crc32.ads, s-direio.adb, s-fatgen.adb, s-fileio.adb, s-finimp.adb, s-gloloc.adb, s-gloloc.ads, s-interr.adb, s-mastop.adb, s-mastop.ads, s-memory.adb, s-parame.ads, s-parint.adb, s-pooglo.adb, s-pooloc.adb, s-rpc.adb, s-secsta.adb, s-sequio.adb, s-shasto.adb, s-soflin.adb, s-soflin.ads, s-stache.adb, s-taasde.adb, s-taasde.ads, s-tadeca.adb, s-tadeca.ads, s-tadert.adb, s-tadert.ads, s-taenca.adb, s-taenca.ads, s-taprob.adb, s-taprop.ads, s-tarest.adb, s-tasdeb.adb, s-tasini.adb, s-tasini.ads, s-taskin.adb, s-taskin.ads, s-tasque.adb, s-tasque.ads, s-tasren.adb, s-tasren.ads, s-tassta.adb, s-tasuti.adb, s-tasuti.ads, s-tataat.adb, s-tataat.ads, s-tpoben.adb, s-tpoben.ads, s-tpobop.adb, s-tposen.adb, s-tposen.ads, s-traceb.adb, s-traceb.ads, s-unstyp.ads, s-widenu.adb, scn-nlit.adb, scn.adb, sem.adb, sem_aggr.adb, sem_attr.adb, sem_attr.ads, sem_case.adb, sem_ch10.adb, sem_ch11.adb, sem_ch11.ads, sem_ch12.adb, sem_ch13.adb, sem_ch13.ads, sem_ch2.adb, sem_ch3.adb, sem_ch3.ads, sem_ch4.adb, sem_ch5.adb, sem_ch6.adb, sem_ch6.ads, sem_ch7.adb, sem_ch8.adb, sem_ch8.ads, sem_ch9.adb, sem_disp.adb, sem_dist.adb, sem_elab.adb, sem_elim.adb, sem_elim.ads, sem_eval.adb, sem_intr.adb, sem_mech.adb, sem_prag.adb, sem_res.adb, sem_type.adb, sem_util.adb, sem_util.ads, sem_vfpt.adb, sem_warn.adb, sinfo.adb, sinfo.ads, sinfo.h, sinput-l.adb, sinput-l.ads, sinput.adb, sinput.ads, snames.adb, snames.ads, snames.h, sprint.adb, sprint.ads, stringt.adb, stringt.ads, stringt.h, style.adb, switch.adb, switch.ads, sysdep.c, system.ads, table.adb, targparm.adb, targparm.ads, targtyps.c, tbuild.adb, tbuild.ads, tracebak.c, trans.c, tree_gen.adb, tree_io.adb, treepr.adb, treepr.ads, treeprs.ads, treeprs.adt, ttypes.ads, types.adb, types.ads, types.h, uintp.ads, urealp.ads, usage.adb, utils.c, utils2.c, validsw.adb, xnmake.adb, xr_tabls.adb, xr_tabls.ads, xref_lib.adb, xref_lib.ads : Merge in ACT changes. * 1ssecsta.adb, 1ssecsta.ads, a-chlat9.ads, a-cwila9.ads, g-enblsp.adb, g-md5.adb, g-md5.ads, gnatname.adb, gnatname.ads, mkdir.c, osint-b.adb, osint-b.ads, osint-c.adb, osint-c.ads, osint-l.adb, osint-l.ads, osint-m.adb, osint-m.ads : New files * 3lsoccon.ads, 5qparame.ads, 5qvxwork.ads, 5smastop.adb, 5zparame.ads, gnatmain.adb, gnatmain.ads, gnatpsys.adb : Removed * mdllfile.adb, mdllfile.ads, mdlltool.adb, mdlltool.ads : Renamed to mdll-fil.ad[bs] and mdll-util.ad[bs] * mdll-fil.adb, mdll-fil.ads, mdll-utl.adb, mdll-utl.ads : Renamed from mdllfile.ad[bs] and mdlltool.ad[bs] From-SVN: r50451
This commit is contained in:
Geert Bosch
parent
24965e7a8a
commit
07fc65c47c
145
gcc/ada/1ssecsta.adb
Normal file
145
gcc/ada/1ssecsta.adb
Normal file
@ -0,0 +1,145 @@
|
||||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- S Y S T E M . S E C O N D A R Y _ S T A C K --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 2, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
||||
-- for more details. You should have received a copy of the GNU General --
|
||||
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is the HI-E version of this package.
|
||||
|
||||
with Unchecked_Conversion;
|
||||
|
||||
package body System.Secondary_Stack is
|
||||
|
||||
use type SSE.Storage_Offset;
|
||||
|
||||
type Memory is array (Mark_Id range <>) of SSE.Storage_Element;
|
||||
|
||||
type Stack_Id is record
|
||||
Top : Mark_Id;
|
||||
Last : Mark_Id;
|
||||
Mem : Memory (1 .. Mark_Id'Last);
|
||||
end record;
|
||||
pragma Suppress_Initialization (Stack_Id);
|
||||
|
||||
type Stack_Ptr is access Stack_Id;
|
||||
|
||||
function From_Addr is new Unchecked_Conversion (Address, Stack_Ptr);
|
||||
|
||||
function Get_Sec_Stack return Stack_Ptr;
|
||||
pragma Import (C, Get_Sec_Stack, "__gnat_get_secondary_stack");
|
||||
-- Return the address of the secondary stack.
|
||||
-- In a multi-threaded environment, Sec_Stack should be a thread-local
|
||||
-- variable.
|
||||
|
||||
-- Possible implementation of Get_Sec_Stack in a single-threaded
|
||||
-- environment:
|
||||
--
|
||||
-- Chunk : aliased Memory (1 .. Default_Secondary_Stack_Size);
|
||||
-- for Chunk'Alignment use Standard'Maximum_Alignment;
|
||||
-- -- The secondary stack.
|
||||
--
|
||||
-- function Get_Sec_Stack return Stack_Ptr is
|
||||
-- begin
|
||||
-- return From_Addr (Chunk'Address);
|
||||
-- end Get_Sec_Stack;
|
||||
--
|
||||
-- begin
|
||||
-- SS_Init (Chunk'Address, Default_Secondary_Stack_Size);
|
||||
-- end System.Secondary_Stack;
|
||||
|
||||
-----------------
|
||||
-- SS_Allocate --
|
||||
-----------------
|
||||
|
||||
procedure SS_Allocate
|
||||
(Address : out System.Address;
|
||||
Storage_Size : SSE.Storage_Count)
|
||||
is
|
||||
Max_Align : constant Mark_Id := Mark_Id (Standard'Maximum_Alignment);
|
||||
Max_Size : constant Mark_Id :=
|
||||
((Mark_Id (Storage_Size) + Max_Align - 1) / Max_Align)
|
||||
* Max_Align;
|
||||
Sec_Stack : constant Stack_Ptr := Get_Sec_Stack;
|
||||
|
||||
begin
|
||||
if Sec_Stack.Top + Max_Size > Sec_Stack.Last then
|
||||
raise Storage_Error;
|
||||
end if;
|
||||
|
||||
Address := Sec_Stack.Mem (Sec_Stack.Top)'Address;
|
||||
Sec_Stack.Top := Sec_Stack.Top + Mark_Id (Max_Size);
|
||||
end SS_Allocate;
|
||||
|
||||
-------------
|
||||
-- SS_Free --
|
||||
-------------
|
||||
|
||||
procedure SS_Free (Stk : in out System.Address) is
|
||||
begin
|
||||
Stk := Null_Address;
|
||||
end SS_Free;
|
||||
|
||||
-------------
|
||||
-- SS_Init --
|
||||
-------------
|
||||
|
||||
procedure SS_Init
|
||||
(Stk : System.Address;
|
||||
Size : Natural := Default_Secondary_Stack_Size)
|
||||
is
|
||||
Stack : Stack_Ptr := From_Addr (Stk);
|
||||
begin
|
||||
pragma Assert (Size >= 2 * Mark_Id'Max_Size_In_Storage_Elements);
|
||||
|
||||
Stack.Top := Stack.Mem'First;
|
||||
Stack.Last := Mark_Id (Size) - 2 * Mark_Id'Max_Size_In_Storage_Elements;
|
||||
end SS_Init;
|
||||
|
||||
-------------
|
||||
-- SS_Mark --
|
||||
-------------
|
||||
|
||||
function SS_Mark return Mark_Id is
|
||||
begin
|
||||
return Get_Sec_Stack.Top;
|
||||
end SS_Mark;
|
||||
|
||||
----------------
|
||||
-- SS_Release --
|
||||
----------------
|
||||
|
||||
procedure SS_Release (M : Mark_Id) is
|
||||
begin
|
||||
Get_Sec_Stack.Top := M;
|
||||
end SS_Release;
|
||||
|
||||
end System.Secondary_Stack;
|
||||
85
gcc/ada/1ssecsta.ads
Normal file
85
gcc/ada/1ssecsta.ads
Normal file
@ -0,0 +1,85 @@
|
||||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- S Y S T E M . S E C O N D A R Y _ S T A C K --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 2, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
||||
-- for more details. You should have received a copy of the GNU General --
|
||||
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with System.Storage_Elements;
|
||||
|
||||
package System.Secondary_Stack is
|
||||
|
||||
package SSE renames System.Storage_Elements;
|
||||
|
||||
Default_Secondary_Stack_Size : constant := 10 * 1024;
|
||||
-- Default size of a secondary stack
|
||||
|
||||
procedure SS_Init
|
||||
(Stk : System.Address;
|
||||
Size : Natural := Default_Secondary_Stack_Size);
|
||||
-- Initialize the secondary stack with a main stack of the given Size.
|
||||
--
|
||||
-- Stk is an "in" parameter that is already pointing to a memory area of
|
||||
-- size Size.
|
||||
--
|
||||
-- The secondary stack is fixed, and any attempt to allocate more than the
|
||||
-- initial size will result in a Storage_Error being raised.
|
||||
|
||||
procedure SS_Allocate
|
||||
(Address : out System.Address;
|
||||
Storage_Size : SSE.Storage_Count);
|
||||
-- Allocate enough space for a 'Storage_Size' bytes object with Maximum
|
||||
-- alignment. The address of the allocated space is returned in 'Address'
|
||||
|
||||
procedure SS_Free (Stk : in out System.Address);
|
||||
-- Release the memory allocated for the Secondary Stack. That is to say,
|
||||
-- all the allocated chuncks.
|
||||
-- Upon return, Stk will be set to System.Null_Address
|
||||
|
||||
type Mark_Id is private;
|
||||
-- Type used to mark the stack.
|
||||
|
||||
function SS_Mark return Mark_Id;
|
||||
-- Return the Mark corresponding to the current state of the stack
|
||||
|
||||
procedure SS_Release (M : Mark_Id);
|
||||
-- Restore the state of the stack corresponding to the mark M. If an
|
||||
-- additional chunk have been allocated, it will never be freed during a
|
||||
|
||||
private
|
||||
|
||||
SS_Pool : Integer;
|
||||
-- Unused entity that is just present to ease the sharing of the pool
|
||||
-- mechanism for specific allocation/deallocation in the compiler
|
||||
|
||||
type Mark_Id is new SSE.Integer_Address;
|
||||
|
||||
end System.Secondary_Stack;
|
||||
@ -1,115 +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 --
|
||||
-- --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 2001 Ada Core Technologies, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 2, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
||||
-- for more details. You should have received a copy of the GNU General --
|
||||
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is the version for GNU/Linux
|
||||
|
||||
package GNAT.Sockets.Constants is
|
||||
|
||||
-- Families
|
||||
|
||||
AF_INET : constant := 2;
|
||||
AF_INET6 : constant := 10;
|
||||
|
||||
-- Modes
|
||||
|
||||
SOCK_STREAM : constant := 1;
|
||||
SOCK_DGRAM : constant := 2;
|
||||
|
||||
-- Socket Errors
|
||||
|
||||
EBADF : constant := 9;
|
||||
ENOTSOCK : constant := 88;
|
||||
ENOTCONN : constant := 107;
|
||||
ENOBUFS : constant := 105;
|
||||
EOPNOTSUPP : constant := 95;
|
||||
EFAULT : constant := 14;
|
||||
EWOULDBLOCK : constant := 11;
|
||||
EADDRNOTAVAIL : constant := 99;
|
||||
EMSGSIZE : constant := 90;
|
||||
EADDRINUSE : constant := 98;
|
||||
EINVAL : constant := 22;
|
||||
EACCES : constant := 13;
|
||||
EAFNOSUPPORT : constant := 97;
|
||||
EISCONN : constant := 106;
|
||||
ETIMEDOUT : constant := 110;
|
||||
ECONNREFUSED : constant := 111;
|
||||
ENETUNREACH : constant := 101;
|
||||
EALREADY : constant := 114;
|
||||
EINPROGRESS : constant := 115;
|
||||
ENOPROTOOPT : constant := 92;
|
||||
EPROTONOSUPPORT : constant := 93;
|
||||
EINTR : constant := 4;
|
||||
EIO : constant := 5;
|
||||
ESOCKTNOSUPPORT : constant := 94;
|
||||
|
||||
-- Host Errors
|
||||
|
||||
HOST_NOT_FOUND : constant := 1;
|
||||
TRY_AGAIN : constant := 2;
|
||||
NO_ADDRESS : constant := 4;
|
||||
NO_RECOVERY : constant := 3;
|
||||
|
||||
-- Control Flags
|
||||
|
||||
FIONBIO : constant := 21537;
|
||||
FIONREAD : constant := 21531;
|
||||
|
||||
-- Shutdown Modes
|
||||
|
||||
SHUT_RD : constant := 0;
|
||||
SHUT_WR : constant := 1;
|
||||
SHUT_RDWR : constant := 2;
|
||||
|
||||
-- Protocol Levels
|
||||
|
||||
SOL_SOCKET : constant := 1;
|
||||
IPPROTO_IP : constant := 0;
|
||||
IPPROTO_UDP : constant := 17;
|
||||
IPPROTO_TCP : constant := 6;
|
||||
|
||||
-- Socket Options
|
||||
|
||||
TCP_NODELAY : constant := 1;
|
||||
SO_SNDBUF : constant := 7;
|
||||
SO_RCVBUF : constant := 8;
|
||||
SO_REUSEADDR : constant := 2;
|
||||
SO_KEEPALIVE : constant := 9;
|
||||
SO_LINGER : constant := 13;
|
||||
SO_ERROR : constant := 4;
|
||||
SO_BROADCAST : constant := 6;
|
||||
IP_ADD_MEMBERSHIP : constant := 35;
|
||||
IP_DROP_MEMBERSHIP : constant := 36;
|
||||
IP_MULTICAST_TTL : constant := 33;
|
||||
IP_MULTICAST_LOOP : constant := 34;
|
||||
end GNAT.Sockets.Constants;
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.2 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -44,7 +44,6 @@
|
||||
-- The pragma Unreserve_All_Interrupts affects the following signal(s):
|
||||
--
|
||||
-- SIGINT: made available for Ada handler
|
||||
-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
|
||||
|
||||
with System.OS_Interface;
|
||||
-- used for names of interrupts
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.2 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -44,7 +44,6 @@
|
||||
-- The pragma Unreserve_All_Interrupts affects the following signal(s):
|
||||
--
|
||||
-- SIGINT: made available for Ada handler
|
||||
-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
|
||||
|
||||
with System.OS_Interface;
|
||||
-- used for names of interrupts
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.4 $ --
|
||||
-- $Revision$ --
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -44,7 +44,6 @@
|
||||
-- The pragma Unreserve_All_Interrupts affects the following signal(s):
|
||||
--
|
||||
-- SIGINT: made available for Ada handler
|
||||
-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
|
||||
|
||||
with System.OS_Interface;
|
||||
-- used for names of interrupts
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.4 $ --
|
||||
-- $Revision$ --
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -49,7 +49,6 @@
|
||||
-- The pragma Unreserve_All_Interrupts affects the following signal(s):
|
||||
--
|
||||
-- SIGINT: made available for Ada handler
|
||||
-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
|
||||
|
||||
-- This target-dependent package spec contains names of interrupts
|
||||
-- supported by the local system.
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.4 $ --
|
||||
-- $Revision$ --
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -44,7 +44,6 @@
|
||||
-- The pragma Unreserve_All_Interrupts affects the following signal(s):
|
||||
--
|
||||
-- SIGINT: Made available for Ada handler
|
||||
-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
|
||||
|
||||
-- This target-dependent package spec contains names of interrupts
|
||||
-- supported by the local system.
|
||||
|
||||
@ -8,7 +8,7 @@
|
||||
-- --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1997-2001, Florida State University --
|
||||
-- Copyright (C) 1997-2002, Florida State University --
|
||||
-- --
|
||||
-- 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 --
|
||||
@ -50,7 +50,6 @@
|
||||
-- (Pthread library):
|
||||
--
|
||||
-- SIGINT: made available for Ada handler
|
||||
-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
|
||||
|
||||
-- This target-dependent package spec contains names of interrupts
|
||||
-- supported by the local system.
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.5 $ --
|
||||
-- $Revision$ --
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001, Florida State University --
|
||||
-- Copyright (C) 1991-2002, Florida State University --
|
||||
-- --
|
||||
-- GNARL is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
@ -44,7 +44,6 @@
|
||||
-- The pragma Unreserve_All_Interrupts affects the following signal(s):
|
||||
--
|
||||
-- SIGINT: made available for Ada handler
|
||||
-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
|
||||
|
||||
-- This target-dependent package spec contains names of interrupts
|
||||
-- supported by the local system.
|
||||
|
||||
@ -8,7 +8,7 @@
|
||||
-- --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -49,7 +49,6 @@
|
||||
-- The pragma Unreserve_All_Interrupts affects the following signal(s):
|
||||
--
|
||||
-- SIGINT: made available for Ada handler
|
||||
-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
|
||||
|
||||
-- This target-dependent package spec contains names of interrupts
|
||||
-- supported by the local system.
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.4 $ --
|
||||
-- $Revision$ --
|
||||
-- --
|
||||
-- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1996-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- --
|
||||
@ -44,7 +44,6 @@
|
||||
-- The pragma Unreserve_All_Interrupts affects the following signal(s):
|
||||
--
|
||||
-- SIGINT: made available for Ada handlers
|
||||
-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
|
||||
|
||||
-- This target-dependent package spec contains names of interrupts
|
||||
-- supported by the local system.
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.4 $ --
|
||||
-- $Revision$ --
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -44,7 +44,6 @@
|
||||
-- The pragma Unreserve_All_Interrupts affects the following signal(s):
|
||||
--
|
||||
-- SIGINT: made available for Ada handlers
|
||||
-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
|
||||
|
||||
-- This target-dependent package spec contains names of interrupts
|
||||
-- supported by the local system.
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.5 $ --
|
||||
-- $Revision$ --
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -48,7 +48,6 @@
|
||||
-- The pragma Unreserve_All_Interrupts affects the following signal(s):
|
||||
--
|
||||
-- SIGINT: made available for Ada handlers
|
||||
-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
|
||||
|
||||
-- This target-dependent package spec contains names of interrupts
|
||||
-- supported by the local system.
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.7 $ --
|
||||
-- $Revision$ --
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -49,7 +49,6 @@
|
||||
-- The pragma Unreserve_All_Interrupts affects the following signal(s):
|
||||
--
|
||||
-- SIGINT: made available for Ada handlers
|
||||
-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
|
||||
|
||||
with System.OS_Interface;
|
||||
-- used for names of interrupts
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.7 $ --
|
||||
-- $Revision$ --
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -44,7 +44,6 @@
|
||||
-- The pragma Unreserve_All_Interrupts affects the following signal(s):
|
||||
--
|
||||
-- SIGINT: made available for Ada handlers
|
||||
-- SIGILL, SIGBUS, SIGSEGV: disconnected from runtime exception mapping
|
||||
|
||||
with System.OS_Interface;
|
||||
-- used for names of interrupts
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.19 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
|
||||
-- --
|
||||
@ -60,9 +60,6 @@ package body Ada.Calendar is
|
||||
|
||||
-- Some basic constants used throughout
|
||||
|
||||
Days_In_Month : constant array (Month_Number) of Day_Number :=
|
||||
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
|
||||
|
||||
function To_Relative_Time (D : Duration) return Time;
|
||||
|
||||
function To_Relative_Time (D : Duration) return Time is
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.3 $ --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -35,20 +35,8 @@
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is the VxWorks version of this package.
|
||||
--
|
||||
-- The following signals are reserved by the run time:
|
||||
--
|
||||
-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGABRT
|
||||
--
|
||||
-- The pragma Unreserve_All_Interrupts affects the following signal(s):
|
||||
--
|
||||
-- none
|
||||
|
||||
-- This target-dependent package spec contains names of interrupts
|
||||
-- supported by the local system.
|
||||
|
||||
with System.OS_Interface;
|
||||
with System.VxWorks;
|
||||
|
||||
package Ada.Interrupts.Names is
|
||||
|
||||
@ -56,136 +44,4 @@ package Ada.Interrupts.Names is
|
||||
range Interrupt_ID'First .. System.OS_Interface.Max_HW_Interrupt;
|
||||
-- Range of values that can be used for hardware interrupts.
|
||||
|
||||
-- The following constants can be used for software interrupts mapped to
|
||||
-- user-level signals:
|
||||
|
||||
SIGHUP : constant Interrupt_ID;
|
||||
-- hangup
|
||||
|
||||
SIGINT : constant Interrupt_ID;
|
||||
-- interrupt
|
||||
|
||||
SIGQUIT : constant Interrupt_ID;
|
||||
-- quit
|
||||
|
||||
SIGILL : constant Interrupt_ID;
|
||||
-- illegal instruction (not reset)
|
||||
|
||||
SIGTRAP : constant Interrupt_ID;
|
||||
-- trace trap (not reset)
|
||||
|
||||
SIGIOT : constant Interrupt_ID;
|
||||
-- IOT instruction
|
||||
|
||||
SIGABRT : constant Interrupt_ID;
|
||||
-- used by abort, replace SIGIOT
|
||||
|
||||
SIGEMT : constant Interrupt_ID;
|
||||
-- EMT instruction
|
||||
|
||||
SIGFPE : constant Interrupt_ID;
|
||||
-- floating point exception
|
||||
|
||||
SIGKILL : constant Interrupt_ID;
|
||||
-- kill (cannot be caught or ignored)
|
||||
|
||||
SIGBUS : constant Interrupt_ID;
|
||||
-- bus error
|
||||
|
||||
SIGSEGV : constant Interrupt_ID;
|
||||
-- segmentation violation
|
||||
|
||||
SIGSYS : constant Interrupt_ID;
|
||||
-- bad argument to system call
|
||||
|
||||
SIGPIPE : constant Interrupt_ID;
|
||||
-- no one to read it
|
||||
|
||||
SIGALRM : constant Interrupt_ID;
|
||||
-- alarm clock
|
||||
|
||||
SIGTERM : constant Interrupt_ID;
|
||||
-- software termination signal from kill
|
||||
|
||||
SIGURG : constant Interrupt_ID;
|
||||
-- urgent condition on IO channel
|
||||
|
||||
SIGSTOP : constant Interrupt_ID;
|
||||
-- stop (cannot be caught or ignored)
|
||||
|
||||
SIGTSTP : constant Interrupt_ID;
|
||||
-- user stop requested from tty
|
||||
|
||||
SIGCONT : constant Interrupt_ID;
|
||||
-- stopped process has been continued
|
||||
|
||||
SIGCHLD : constant Interrupt_ID;
|
||||
-- child status change
|
||||
|
||||
SIGTTIN : constant Interrupt_ID;
|
||||
-- background tty read attempted
|
||||
|
||||
SIGTTOU : constant Interrupt_ID;
|
||||
-- background tty write attempted
|
||||
|
||||
SIGIO : constant Interrupt_ID;
|
||||
-- input/output possible,
|
||||
|
||||
SIGXCPU : constant Interrupt_ID;
|
||||
-- CPU time limit exceeded
|
||||
|
||||
SIGXFSZ : constant Interrupt_ID;
|
||||
-- filesize limit exceeded
|
||||
|
||||
SIGVTALRM : constant Interrupt_ID;
|
||||
-- virtual timer expired
|
||||
|
||||
SIGPROF : constant Interrupt_ID;
|
||||
-- profiling timer expired
|
||||
|
||||
SIGWINCH : constant Interrupt_ID;
|
||||
-- window size change
|
||||
|
||||
SIGUSR1 : constant Interrupt_ID;
|
||||
-- user defined signal 1
|
||||
|
||||
SIGUSR2 : constant Interrupt_ID;
|
||||
-- user defined signal 2
|
||||
|
||||
private
|
||||
|
||||
Signal_Base : constant := System.VxWorks.Num_HW_Interrupts;
|
||||
|
||||
SIGHUP : constant Interrupt_ID := 1 + Signal_Base;
|
||||
SIGINT : constant Interrupt_ID := 2 + Signal_Base;
|
||||
SIGQUIT : constant Interrupt_ID := 3 + Signal_Base;
|
||||
SIGILL : constant Interrupt_ID := 4 + Signal_Base;
|
||||
SIGTRAP : constant Interrupt_ID := 5 + Signal_Base;
|
||||
SIGIOT : constant Interrupt_ID := 6 + Signal_Base;
|
||||
SIGABRT : constant Interrupt_ID := 6 + Signal_Base;
|
||||
SIGEMT : constant Interrupt_ID := 7 + Signal_Base;
|
||||
SIGFPE : constant Interrupt_ID := 8 + Signal_Base;
|
||||
SIGKILL : constant Interrupt_ID := 9 + Signal_Base;
|
||||
SIGBUS : constant Interrupt_ID := 10 + Signal_Base;
|
||||
SIGSEGV : constant Interrupt_ID := 11 + Signal_Base;
|
||||
SIGSYS : constant Interrupt_ID := 12 + Signal_Base;
|
||||
SIGPIPE : constant Interrupt_ID := 13 + Signal_Base;
|
||||
SIGALRM : constant Interrupt_ID := 14 + Signal_Base;
|
||||
SIGTERM : constant Interrupt_ID := 15 + Signal_Base;
|
||||
SIGURG : constant Interrupt_ID := 16 + Signal_Base;
|
||||
SIGSTOP : constant Interrupt_ID := 17 + Signal_Base;
|
||||
SIGTSTP : constant Interrupt_ID := 18 + Signal_Base;
|
||||
SIGCONT : constant Interrupt_ID := 19 + Signal_Base;
|
||||
SIGCHLD : constant Interrupt_ID := 20 + Signal_Base;
|
||||
SIGTTIN : constant Interrupt_ID := 21 + Signal_Base;
|
||||
SIGTTOU : constant Interrupt_ID := 22 + Signal_Base;
|
||||
SIGIO : constant Interrupt_ID := 23 + Signal_Base;
|
||||
SIGXCPU : constant Interrupt_ID := 24 + Signal_Base;
|
||||
SIGXFSZ : constant Interrupt_ID := 25 + Signal_Base;
|
||||
SIGVTALRM : constant Interrupt_ID := 26 + Signal_Base;
|
||||
SIGPROF : constant Interrupt_ID := 27 + Signal_Base;
|
||||
SIGWINCH : constant Interrupt_ID := 28 + Signal_Base;
|
||||
SIGUSR1 : constant Interrupt_ID := 30 + Signal_Base;
|
||||
SIGUSR2 : constant Interrupt_ID := 31 + Signal_Base;
|
||||
|
||||
end Ada.Interrupts.Names;
|
||||
|
||||
@ -7,9 +7,9 @@
|
||||
-- S p e c --
|
||||
-- (LynxOS PPC/x86 Version)
|
||||
-- --
|
||||
-- $Revision: 1.4 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- 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 --
|
||||
@ -60,16 +60,16 @@ pragma Pure (System);
|
||||
Max_Mantissa : constant := 63;
|
||||
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
|
||||
|
||||
Tick : constant := Standard'Tick;
|
||||
Tick : constant := 1.0;
|
||||
|
||||
-- Storage-related Declarations
|
||||
|
||||
type Address is private;
|
||||
Null_Address : constant Address;
|
||||
|
||||
Storage_Unit : constant := Standard'Storage_Unit;
|
||||
Word_Size : constant := Standard'Word_Size;
|
||||
Memory_Size : constant := 2 ** Standard'Address_Size;
|
||||
Storage_Unit : constant := 8;
|
||||
Word_Size : constant := 32;
|
||||
Memory_Size : constant := 2 ** 32;
|
||||
|
||||
-- Address comparison
|
||||
|
||||
@ -88,32 +88,18 @@ pragma Pure (System);
|
||||
-- Other System-Dependent Declarations
|
||||
|
||||
type Bit_Order is (High_Order_First, Low_Order_First);
|
||||
Default_Bit_Order : constant Bit_Order :=
|
||||
Bit_Order'Val (Standard'Default_Bit_Order);
|
||||
Default_Bit_Order : constant Bit_Order := High_Order_First;
|
||||
|
||||
-- Priority-related Declarations (RM D.1)
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
Max_Interrupt_Priority : constant Positive := 31;
|
||||
|
||||
subtype Any_Priority is Integer
|
||||
range 0 .. Standard'Max_Interrupt_Priority;
|
||||
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;
|
||||
|
||||
subtype Priority is Any_Priority
|
||||
range 0 .. Standard'Max_Priority;
|
||||
|
||||
-- Functional notation is needed in the following to avoid visibility
|
||||
-- problems when this package is compiled through rtsfind in the middle
|
||||
-- of another compilation.
|
||||
|
||||
subtype Interrupt_Priority is Any_Priority
|
||||
range
|
||||
Standard."+" (Standard'Max_Priority, 1) ..
|
||||
Standard'Max_Interrupt_Priority;
|
||||
|
||||
Default_Priority : constant Priority :=
|
||||
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
|
||||
Default_Priority : constant Priority := 15;
|
||||
|
||||
private
|
||||
|
||||
@ -131,8 +117,11 @@ private
|
||||
-- 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;
|
||||
Denorm : constant Boolean := True;
|
||||
Fractional_Fixed_Ops : constant Boolean := False;
|
||||
Frontend_Layout : constant Boolean := False;
|
||||
Functions_Return_By_DSP : constant Boolean := False;
|
||||
Long_Shifts_Inlined : constant Boolean := True;
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
-- B o d y --
|
||||
-- (Version for Alpha/Dec Unix) --
|
||||
-- --
|
||||
-- $Revision: 1.5 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
|
||||
-- --
|
||||
@ -87,11 +87,8 @@ package body System.Machine_State_Operations is
|
||||
------------------------
|
||||
|
||||
procedure Free_Machine_State (M : in out Machine_State) is
|
||||
procedure Gnat_Free (M : in Machine_State);
|
||||
pragma Import (C, Gnat_Free, "__gnat_free");
|
||||
|
||||
begin
|
||||
Gnat_Free (M);
|
||||
Memory.Free (Address (M));
|
||||
M := Machine_State (Null_Address);
|
||||
end Free_Machine_State;
|
||||
|
||||
|
||||
@ -7,9 +7,9 @@
|
||||
-- S p e c --
|
||||
-- (DEC Unix Version) --
|
||||
-- --
|
||||
-- $Revision: 1.20 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- 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 --
|
||||
@ -60,16 +60,16 @@ pragma Pure (System);
|
||||
Max_Mantissa : constant := 63;
|
||||
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
|
||||
|
||||
Tick : constant := Standard'Tick;
|
||||
Tick : constant := 1.0;
|
||||
|
||||
-- Storage-related Declarations
|
||||
|
||||
type Address is private;
|
||||
Null_Address : constant Address;
|
||||
|
||||
Storage_Unit : constant := Standard'Storage_Unit;
|
||||
Word_Size : constant := Standard'Word_Size;
|
||||
Memory_Size : constant := 2 ** Standard'Address_Size;
|
||||
Storage_Unit : constant := 8;
|
||||
Word_Size : constant := 64;
|
||||
Memory_Size : constant := 2 ** 64;
|
||||
|
||||
-- Address comparison
|
||||
|
||||
@ -92,27 +92,14 @@ pragma Pure (System);
|
||||
|
||||
-- Priority-related Declarations (RM D.1)
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
Max_Priority : constant Positive := 60;
|
||||
Max_Interrupt_Priority : constant Positive := 63;
|
||||
|
||||
Max_Interrupt_Priority : constant Positive := 31;
|
||||
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;
|
||||
|
||||
subtype Any_Priority is Integer
|
||||
range 0 .. Standard'Max_Interrupt_Priority;
|
||||
|
||||
subtype Priority is Any_Priority
|
||||
range 0 .. Standard'Max_Priority;
|
||||
|
||||
-- Functional notation is needed in the following to avoid visibility
|
||||
-- problems when this package is compiled through rtsfind in the middle
|
||||
-- of another compilation.
|
||||
|
||||
subtype Interrupt_Priority is Any_Priority
|
||||
range
|
||||
Standard."+" (Standard'Max_Priority, 1) ..
|
||||
Standard'Max_Interrupt_Priority;
|
||||
|
||||
Default_Priority : constant Priority :=
|
||||
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
|
||||
Default_Priority : constant Priority := 30;
|
||||
|
||||
private
|
||||
|
||||
@ -130,10 +117,13 @@ private
|
||||
-- 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;
|
||||
Denorm : constant Boolean := False;
|
||||
Fractional_Fixed_Ops : constant Boolean := False;
|
||||
Frontend_Layout : constant Boolean := False;
|
||||
Functions_Return_By_DSP : constant Boolean := True;
|
||||
Functions_Return_By_DSP : constant Boolean := False;
|
||||
Long_Shifts_Inlined : constant Boolean := True;
|
||||
High_Integrity_Mode : constant Boolean := False;
|
||||
Machine_Overflows : constant Boolean := False;
|
||||
@ -143,9 +133,9 @@ private
|
||||
Stack_Check_Default : constant Boolean := True;
|
||||
Stack_Check_Probes : constant Boolean := True;
|
||||
Use_Ada_Main_Program_Name : constant Boolean := False;
|
||||
ZCX_By_Default : constant Boolean := True;
|
||||
ZCX_By_Default : constant Boolean := False;
|
||||
GCC_ZCX_Support : constant Boolean := False;
|
||||
Front_End_ZCX_Support : constant Boolean := True;
|
||||
Front_End_ZCX_Support : constant Boolean := False;
|
||||
|
||||
-- Note: Denorm is False because denormals are only handled properly
|
||||
-- if the -mieee switch is set, and we do not require this usage.
|
||||
@ -193,37 +183,29 @@ private
|
||||
-- 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);
|
||||
|
||||
(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;
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001, Florida State University --
|
||||
-- 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -99,15 +98,17 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
package SSL renames System.Soft_Links;
|
||||
|
||||
-----------------
|
||||
-- Local Data --
|
||||
-----------------
|
||||
----------------
|
||||
-- Local Data --
|
||||
----------------
|
||||
|
||||
-- The followings are logically constants, but need to be initialized
|
||||
-- at run time.
|
||||
|
||||
All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
|
||||
-- See comments on locking rules in System.Tasking (spec).
|
||||
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.
|
||||
@ -221,7 +222,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- Note: mutexes and cond_variables needed per-task basis are
|
||||
-- initialized in Initialize_TCB and the Storage_Error is
|
||||
-- handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
|
||||
-- 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.
|
||||
@ -317,33 +318,40 @@ package body System.Task_Primitives.Operations is
|
||||
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
|
||||
-- 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) is
|
||||
procedure Write_Lock
|
||||
(L : access RTS_Lock; Global_Lock : Boolean := False)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
begin
|
||||
Result := pthread_mutex_lock (L);
|
||||
pragma Assert (Result = 0);
|
||||
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
|
||||
Result := pthread_mutex_lock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutex_lock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
end Write_Lock;
|
||||
|
||||
---------------
|
||||
@ -366,18 +374,22 @@ package body System.Task_Primitives.Operations is
|
||||
pragma Assert (Result = 0);
|
||||
end Unlock;
|
||||
|
||||
procedure Unlock (L : access RTS_Lock) is
|
||||
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
|
||||
Result : Interfaces.C.int;
|
||||
begin
|
||||
Result := pthread_mutex_unlock (L);
|
||||
pragma Assert (Result = 0);
|
||||
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
|
||||
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
end Unlock;
|
||||
|
||||
-----------
|
||||
@ -390,9 +402,13 @@ package body System.Task_Primitives.Operations is
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
begin
|
||||
pragma Assert (Self_ID = Self);
|
||||
Result := pthread_cond_wait
|
||||
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
|
||||
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.
|
||||
|
||||
@ -437,8 +453,16 @@ package body System.Task_Primitives.Operations is
|
||||
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
|
||||
or else Self_ID.Pending_Priority_Change;
|
||||
|
||||
Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access, Request'Access);
|
||||
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;
|
||||
|
||||
@ -477,6 +501,11 @@ package body System.Task_Primitives.Operations is
|
||||
-- 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
|
||||
@ -498,8 +527,13 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
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);
|
||||
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;
|
||||
|
||||
@ -512,6 +546,11 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
|
||||
Unlock (Self_ID);
|
||||
|
||||
if Single_Lock then
|
||||
Unlock_RTS;
|
||||
end if;
|
||||
|
||||
Yield;
|
||||
SSL.Abort_Undefer.all;
|
||||
end Timed_Delay;
|
||||
@ -612,7 +651,7 @@ package body System.Task_Primitives.Operations is
|
||||
Self_ID.Common.LL.Thread := pthread_self;
|
||||
Specific.Set (Self_ID);
|
||||
|
||||
Lock_All_Tasks_List;
|
||||
Lock_RTS;
|
||||
|
||||
for J in Known_Tasks'Range loop
|
||||
if Known_Tasks (J) = null then
|
||||
@ -622,7 +661,7 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Unlock_All_Tasks_List;
|
||||
Unlock_RTS;
|
||||
end Enter_Task;
|
||||
|
||||
--------------
|
||||
@ -644,45 +683,42 @@ package body System.Task_Primitives.Operations is
|
||||
Cond_Attr : aliased pthread_condattr_t;
|
||||
|
||||
begin
|
||||
Result := pthread_mutexattr_init (Mutex_Attr'Access);
|
||||
pragma Assert (Result = 0 or else Result = ENOMEM);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutexattr_init (Mutex_Attr'Access);
|
||||
pragma Assert (Result = 0 or else Result = ENOMEM);
|
||||
|
||||
if Result /= 0 then
|
||||
Succeeded := False;
|
||||
return;
|
||||
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_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;
|
||||
|
||||
Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
|
||||
pragma Assert (Result = 0);
|
||||
|
||||
Result := pthread_condattr_init (Cond_Attr'Access);
|
||||
pragma Assert (Result = 0 or else Result = ENOMEM);
|
||||
|
||||
if Result /= 0 then
|
||||
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
Succeeded := False;
|
||||
return;
|
||||
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;
|
||||
|
||||
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
|
||||
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
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;
|
||||
|
||||
@ -829,13 +865,18 @@ package body System.Task_Primitives.Operations is
|
||||
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_destroy (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
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;
|
||||
|
||||
@ -891,23 +932,23 @@ package body System.Task_Primitives.Operations is
|
||||
return Environment_Task_ID;
|
||||
end Environment_Task;
|
||||
|
||||
-------------------------
|
||||
-- Lock_All_Tasks_List --
|
||||
-------------------------
|
||||
--------------
|
||||
-- Lock_RTS --
|
||||
--------------
|
||||
|
||||
procedure Lock_All_Tasks_List is
|
||||
procedure Lock_RTS is
|
||||
begin
|
||||
Write_Lock (All_Tasks_L'Access);
|
||||
end Lock_All_Tasks_List;
|
||||
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Lock_RTS;
|
||||
|
||||
---------------------------
|
||||
-- Unlock_All_Tasks_List --
|
||||
---------------------------
|
||||
----------------
|
||||
-- Unlock_RTS --
|
||||
----------------
|
||||
|
||||
procedure Unlock_All_Tasks_List is
|
||||
procedure Unlock_RTS is
|
||||
begin
|
||||
Unlock (All_Tasks_L'Access);
|
||||
end Unlock_All_Tasks_List;
|
||||
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Unlock_RTS;
|
||||
|
||||
------------------
|
||||
-- Suspend_Task --
|
||||
@ -944,7 +985,7 @@ package body System.Task_Primitives.Operations is
|
||||
begin
|
||||
Environment_Task_ID := Environment_Task;
|
||||
|
||||
Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
|
||||
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
|
||||
-- Initialize the lock used to synchronize chain of all ATCBs.
|
||||
|
||||
Specific.Initialize (Environment_Task);
|
||||
@ -971,7 +1012,6 @@ package body System.Task_Primitives.Operations is
|
||||
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
|
||||
|
||||
@ -7,9 +7,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001, Florida State University --
|
||||
-- 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- --
|
||||
@ -30,15 +30,17 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is a POSIX version of this package where foreign threads are
|
||||
-- recognized.
|
||||
-- Currently, DEC Unix, SCO UnixWare, Solaris pthread, HPUX pthread and RTEMS
|
||||
-- use this version.
|
||||
-- Currently, DEC Unix, SCO UnixWare, Solaris pthread, HPUX pthread,
|
||||
-- GNU/Linux threads and RTEMS use this version.
|
||||
|
||||
with System.Task_Info;
|
||||
-- Use for Unspecified_Task_Info
|
||||
|
||||
with System.Soft_Links;
|
||||
-- used to initialize TSD for a C thread, in function Self
|
||||
@ -71,7 +73,7 @@ package body Specific is
|
||||
|
||||
Fake_ATCB_List : Fake_ATCB_Ptr;
|
||||
-- A linear linked list.
|
||||
-- The list is protected by All_Tasks_L;
|
||||
-- The list is protected by Single_RTS_Lock;
|
||||
-- Nodes are added to this list from the front.
|
||||
-- Once a node is added to this list, it is never removed.
|
||||
|
||||
@ -109,7 +111,7 @@ package body Specific is
|
||||
-- We dare not call anything that might require an ATCB, until
|
||||
-- we have the new ATCB in place.
|
||||
|
||||
Write_Lock (All_Tasks_L'Access);
|
||||
Lock_RTS;
|
||||
Q := null;
|
||||
P := Fake_ATCB_List;
|
||||
|
||||
@ -195,7 +197,7 @@ package body Specific is
|
||||
|
||||
-- Must not unlock until Next_ATCB is again allocated.
|
||||
|
||||
Unlock (All_Tasks_L'Access);
|
||||
Unlock_RTS;
|
||||
return Self_ID;
|
||||
end New_Fake_ATCB;
|
||||
|
||||
@ -205,7 +207,6 @@ package body Specific is
|
||||
|
||||
procedure Initialize (Environment_Task : Task_ID) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_key_create (ATCB_Key'Access, null);
|
||||
pragma Assert (Result = 0);
|
||||
@ -223,7 +224,6 @@ package body Specific is
|
||||
|
||||
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);
|
||||
@ -233,37 +233,21 @@ package body Specific is
|
||||
-- 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.
|
||||
-- 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.
|
||||
|
||||
-- (The entire Ada run-time system may not have been elaborated,
|
||||
-- either, but that is a different problem, that we will need to
|
||||
-- solve another way.)
|
||||
-- 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.
|
||||
|
||||
-- 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.
|
||||
|
||||
-- We will also use such points to poll for disappearance of the
|
||||
-- threads associated with any implicit ATCBs that we created
|
||||
-- earlier, and take the opportunity to recover them.
|
||||
|
||||
-- A nasty problem here is the limitations of the compilation
|
||||
-- order dependency, and in particular the GNARL/GNULLI layering.
|
||||
-- To initialize an ATCB we need to assume System.Tasking has
|
||||
-- been elaborated.
|
||||
-- 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);
|
||||
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.3 $ --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1998-2001 Free Software Foundation --
|
||||
-- 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -43,68 +42,18 @@ package System.VxWorks is
|
||||
|
||||
package IC renames Interfaces.C;
|
||||
|
||||
-- Define enough of a Wind Task Control Block in order to
|
||||
-- obtain the inherited priority. When porting this to
|
||||
-- different versions of VxWorks (this is based on 5.3[.1]),
|
||||
-- be sure to look at the definition for WIND_TCB located
|
||||
-- in $WIND_BASE/target/h/taskLib.h
|
||||
|
||||
type Wind_Fill_1 is array (0 .. 16#77#) of IC.unsigned_char;
|
||||
type Wind_Fill_2 is array (16#80# .. 16#1c7#) of IC.unsigned_char;
|
||||
type Wind_Fill_3 is array (16#1d8# .. 16#777#) of IC.unsigned_char;
|
||||
|
||||
type Wind_TCB is record
|
||||
Fill_1 : Wind_Fill_1; -- 0x00 - 0x77
|
||||
Priority : IC.int; -- 0x78 - 0x7b, current (inherited) priority
|
||||
Normal_Priority : IC.int; -- 0x7c - 0x7f, base priority
|
||||
Fill_2 : Wind_Fill_2; -- 0x80 - 0x1c7
|
||||
spare1 : Address; -- 0x1c8 - 0x1cb
|
||||
spare2 : Address; -- 0x1cc - 0x1cf
|
||||
spare3 : Address; -- 0x1d0 - 0x1d3
|
||||
spare4 : Address; -- 0x1d4 - 0x1d7
|
||||
|
||||
-- Fill_3 is much smaller on the board runtime, but the larger size
|
||||
-- below keeps this record compatible with vxsim.
|
||||
|
||||
Fill_3 : Wind_Fill_3; -- 0x1d8 - 0x777
|
||||
end record;
|
||||
type Wind_TCB_Ptr is access Wind_TCB;
|
||||
|
||||
|
||||
-- Floating point context record. Alpha version
|
||||
-- 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;
|
||||
fpx : Fpx_Array;
|
||||
fpcsr : IC.long;
|
||||
end record;
|
||||
pragma Convention (C, FP_CONTEXT);
|
||||
|
||||
-- Number of entries in hardware interrupt vector table. Value of
|
||||
-- 0 disables hardware interrupt handling until it can be tested
|
||||
Num_HW_Interrupts : constant := 0;
|
||||
|
||||
-- VxWorks 5.3 and 5.4 version
|
||||
type TASK_DESC is record
|
||||
td_id : IC.int; -- task id
|
||||
td_name : Address; -- name of task
|
||||
td_priority : IC.int; -- task priority
|
||||
td_status : IC.int; -- task status
|
||||
td_options : IC.int; -- task option bits (see below)
|
||||
td_entry : Address; -- original entry point of task
|
||||
td_sp : Address; -- saved stack pointer
|
||||
td_pStackBase : Address; -- the bottom of the stack
|
||||
td_pStackLimit : Address; -- the effective end of the stack
|
||||
td_pStackEnd : Address; -- the actual end of the stack
|
||||
td_stackSize : IC.int; -- size of stack in bytes
|
||||
td_stackCurrent : IC.int; -- current stack usage in bytes
|
||||
td_stackHigh : IC.int; -- maximum stack usage in bytes
|
||||
td_stackMargin : IC.int; -- current stack margin in bytes
|
||||
td_errorStatus : IC.int; -- most recent task error status
|
||||
td_delay : IC.int; -- delay/timeout ticks
|
||||
end record;
|
||||
pragma Convention (C, TASK_DESC);
|
||||
Num_HW_Interrupts : constant := 256;
|
||||
-- Number of entries in hardware interrupt vector table.
|
||||
|
||||
end System.VxWorks;
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.8 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1997-2001, Florida State University --
|
||||
-- Copyright (C) 1997-2001, 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -140,7 +139,7 @@ package body System.OS_Interface is
|
||||
function sched_yield return int is
|
||||
|
||||
procedure pthread_yield;
|
||||
pragma Import (C, pthread_yield, "pthread_yield");
|
||||
pragma Import (C, pthread_yield, "sched_yield");
|
||||
|
||||
begin
|
||||
pthread_yield;
|
||||
|
||||
@ -5,11 +5,11 @@
|
||||
-- S Y S T E M --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- (AIX/PPC Version)
|
||||
-- (AIX/PPC Version) --
|
||||
-- --
|
||||
-- $Revision: 1.4 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- 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 --
|
||||
@ -60,16 +60,16 @@ pragma Pure (System);
|
||||
Max_Mantissa : constant := 63;
|
||||
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
|
||||
|
||||
Tick : constant := Standard'Tick;
|
||||
Tick : constant := 1.0;
|
||||
|
||||
-- Storage-related Declarations
|
||||
|
||||
type Address is private;
|
||||
Null_Address : constant Address;
|
||||
|
||||
Storage_Unit : constant := Standard'Storage_Unit;
|
||||
Word_Size : constant := Standard'Word_Size;
|
||||
Memory_Size : constant := 2 ** Standard'Address_Size;
|
||||
Storage_Unit : constant := 8;
|
||||
Word_Size : constant := 32;
|
||||
Memory_Size : constant := 2 ** 32;
|
||||
|
||||
-- Address comparison
|
||||
|
||||
@ -88,32 +88,18 @@ pragma Pure (System);
|
||||
-- Other System-Dependent Declarations
|
||||
|
||||
type Bit_Order is (High_Order_First, Low_Order_First);
|
||||
Default_Bit_Order : constant Bit_Order :=
|
||||
Bit_Order'Val (Standard'Default_Bit_Order);
|
||||
Default_Bit_Order : constant Bit_Order := High_Order_First;
|
||||
|
||||
-- Priority-related Declarations (RM D.1)
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
Max_Interrupt_Priority : constant Positive := 31;
|
||||
|
||||
subtype Any_Priority is Integer
|
||||
range 0 .. Standard'Max_Interrupt_Priority;
|
||||
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;
|
||||
|
||||
subtype Priority is Any_Priority
|
||||
range 0 .. Standard'Max_Priority;
|
||||
|
||||
-- Functional notation is needed in the following to avoid visibility
|
||||
-- problems when this package is compiled through rtsfind in the middle
|
||||
-- of another compilation.
|
||||
|
||||
subtype Interrupt_Priority is Any_Priority
|
||||
range
|
||||
Standard."+" (Standard'Max_Priority, 1) ..
|
||||
Standard'Max_Interrupt_Priority;
|
||||
|
||||
Default_Priority : constant Priority :=
|
||||
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
|
||||
Default_Priority : constant Priority := 15;
|
||||
|
||||
private
|
||||
|
||||
@ -131,8 +117,11 @@ private
|
||||
-- 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;
|
||||
Denorm : constant Boolean := True;
|
||||
Fractional_Fixed_Ops : constant Boolean := False;
|
||||
Frontend_Layout : constant Boolean := False;
|
||||
Functions_Return_By_DSP : constant Boolean := False;
|
||||
Long_Shifts_Inlined : constant Boolean := True;
|
||||
|
||||
@ -7,9 +7,9 @@
|
||||
-- S p e c --
|
||||
-- (X86 Solaris Version) --
|
||||
-- --
|
||||
-- $Revision: 1.10 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- 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 --
|
||||
@ -60,16 +60,16 @@ pragma Pure (System);
|
||||
Max_Mantissa : constant := 63;
|
||||
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
|
||||
|
||||
Tick : constant := Standard'Tick;
|
||||
Tick : constant := 1.0;
|
||||
|
||||
-- Storage-related Declarations
|
||||
|
||||
type Address is private;
|
||||
Null_Address : constant Address;
|
||||
|
||||
Storage_Unit : constant := Standard'Storage_Unit;
|
||||
Word_Size : constant := Standard'Word_Size;
|
||||
Memory_Size : constant := 2 ** Standard'Address_Size;
|
||||
Storage_Unit : constant := 8;
|
||||
Word_Size : constant := 32;
|
||||
Memory_Size : constant := 2 ** 32;
|
||||
|
||||
-- Address comparison
|
||||
|
||||
@ -92,27 +92,14 @@ pragma Pure (System);
|
||||
|
||||
-- Priority-related Declarations (RM D.1)
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
Max_Interrupt_Priority : constant Positive := 31;
|
||||
|
||||
subtype Any_Priority is Integer
|
||||
range 0 .. Standard'Max_Interrupt_Priority;
|
||||
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;
|
||||
|
||||
subtype Priority is Any_Priority
|
||||
range 0 .. Standard'Max_Priority;
|
||||
|
||||
-- Functional notation is needed in the following to avoid visibility
|
||||
-- problems when this package is compiled through rtsfind in the middle
|
||||
-- of another compilation.
|
||||
|
||||
subtype Interrupt_Priority is Any_Priority
|
||||
range
|
||||
Standard."+" (Standard'Max_Priority, 1) ..
|
||||
Standard'Max_Interrupt_Priority;
|
||||
|
||||
Default_Priority : constant Priority :=
|
||||
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
|
||||
Default_Priority : constant Priority := 15;
|
||||
|
||||
private
|
||||
|
||||
@ -130,8 +117,11 @@ private
|
||||
-- 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;
|
||||
Denorm : constant Boolean := True;
|
||||
Fractional_Fixed_Ops : constant Boolean := False;
|
||||
Frontend_Layout : constant Boolean := False;
|
||||
Functions_Return_By_DSP : constant Boolean := False;
|
||||
Long_Shifts_Inlined : constant Boolean := True;
|
||||
@ -145,6 +135,6 @@ private
|
||||
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;
|
||||
Front_End_ZCX_Support : constant Boolean := True;
|
||||
|
||||
end System;
|
||||
|
||||
@ -7,9 +7,9 @@
|
||||
-- S p e c --
|
||||
-- (SGI Irix, o32 ABI) --
|
||||
-- --
|
||||
-- $Revision: 1.13 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- 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 --
|
||||
@ -60,16 +60,16 @@ pragma Pure (System);
|
||||
Max_Mantissa : constant := 63;
|
||||
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
|
||||
|
||||
Tick : constant := Standard'Tick;
|
||||
Tick : constant := 1.0;
|
||||
|
||||
-- Storage-related Declarations
|
||||
|
||||
type Address is private;
|
||||
Null_Address : constant Address;
|
||||
|
||||
Storage_Unit : constant := Standard'Storage_Unit;
|
||||
Word_Size : constant := Standard'Word_Size;
|
||||
Memory_Size : constant := 2 ** Standard'Address_Size;
|
||||
Storage_Unit : constant := 8;
|
||||
Word_Size : constant := 32;
|
||||
Memory_Size : constant := 2 ** 32;
|
||||
|
||||
-- Address comparison
|
||||
|
||||
@ -92,27 +92,14 @@ pragma Pure (System);
|
||||
|
||||
-- Priority-related Declarations (RM D.1)
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
Max_Interrupt_Priority : constant Positive := 31;
|
||||
|
||||
subtype Any_Priority is Integer
|
||||
range 0 .. Standard'Max_Interrupt_Priority;
|
||||
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;
|
||||
|
||||
subtype Priority is Any_Priority
|
||||
range 0 .. Standard'Max_Priority;
|
||||
|
||||
-- Functional notation is needed in the following to avoid visibility
|
||||
-- problems when this package is compiled through rtsfind in the middle
|
||||
-- of another compilation.
|
||||
|
||||
subtype Interrupt_Priority is Any_Priority
|
||||
range
|
||||
Standard."+" (Standard'Max_Priority, 1) ..
|
||||
Standard'Max_Interrupt_Priority;
|
||||
|
||||
Default_Priority : constant Priority :=
|
||||
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
|
||||
Default_Priority : constant Priority := 15;
|
||||
|
||||
private
|
||||
|
||||
@ -130,8 +117,11 @@ private
|
||||
-- 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;
|
||||
Denorm : constant Boolean := False;
|
||||
Fractional_Fixed_Ops : constant Boolean := False;
|
||||
Frontend_Layout : constant Boolean := False;
|
||||
Functions_Return_By_DSP : constant Boolean := True;
|
||||
Long_Shifts_Inlined : constant Boolean := True;
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001, Florida State University --
|
||||
-- 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -117,8 +116,10 @@ package body System.Task_Primitives.Operations is
|
||||
ATCB_Key : aliased pthread_key_t;
|
||||
-- Key used to find the Ada Task_ID associated with a thread
|
||||
|
||||
All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
|
||||
-- See comments on locking rules in System.Locking_Rules (spec).
|
||||
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.
|
||||
@ -206,7 +207,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- Note: mutexes and cond_variables needed per-task basis are
|
||||
-- initialized in Initialize_TCB and the Storage_Error is
|
||||
-- handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
|
||||
-- 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.
|
||||
@ -308,7 +309,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
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;
|
||||
@ -318,20 +318,24 @@ package body System.Task_Primitives.Operations is
|
||||
pragma Assert (Result = 0 or else Result = EINVAL);
|
||||
end Write_Lock;
|
||||
|
||||
procedure Write_Lock (L : access RTS_Lock) is
|
||||
procedure Write_Lock
|
||||
(L : access RTS_Lock; Global_Lock : Boolean := False)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_lock (L);
|
||||
pragma Assert (Result = 0);
|
||||
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
|
||||
Result := pthread_mutex_lock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutex_lock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
end Write_Lock;
|
||||
|
||||
---------------
|
||||
@ -349,26 +353,27 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
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) is
|
||||
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_unlock (L);
|
||||
pragma Assert (Result = 0);
|
||||
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
|
||||
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
end Unlock;
|
||||
|
||||
-----------
|
||||
@ -381,9 +386,13 @@ package body System.Task_Primitives.Operations is
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
begin
|
||||
pragma Assert (Self_ID = Self);
|
||||
Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access);
|
||||
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.
|
||||
|
||||
@ -424,8 +433,16 @@ package body System.Task_Primitives.Operations is
|
||||
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
|
||||
or else Self_ID.Pending_Priority_Change;
|
||||
|
||||
Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access, Request'Access);
|
||||
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;
|
||||
|
||||
@ -461,6 +478,11 @@ package body System.Task_Primitives.Operations is
|
||||
-- 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
|
||||
@ -495,6 +517,11 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
|
||||
Unlock (Self_ID);
|
||||
|
||||
if Single_Lock then
|
||||
Unlock_RTS;
|
||||
end if;
|
||||
|
||||
Yield;
|
||||
SSL.Abort_Undefer.all;
|
||||
end Timed_Delay;
|
||||
@ -621,7 +648,7 @@ package body System.Task_Primitives.Operations is
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
|
||||
Lock_All_Tasks_List;
|
||||
Lock_RTS;
|
||||
|
||||
for J in Known_Tasks'Range loop
|
||||
if Known_Tasks (J) = null then
|
||||
@ -631,7 +658,7 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Unlock_All_Tasks_List;
|
||||
Unlock_RTS;
|
||||
end Enter_Task;
|
||||
|
||||
--------------
|
||||
@ -652,28 +679,27 @@ package body System.Task_Primitives.Operations is
|
||||
Cond_Attr : aliased pthread_condattr_t;
|
||||
|
||||
begin
|
||||
Initialize_Lock (Self_ID.Common.LL.L'Access, All_Tasks_Level);
|
||||
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_mutex_destroy (Self_ID.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
|
||||
Succeeded := False;
|
||||
return;
|
||||
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;
|
||||
|
||||
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
|
||||
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
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;
|
||||
|
||||
@ -821,8 +847,10 @@ package body System.Task_Primitives.Operations is
|
||||
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_destroy (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
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);
|
||||
@ -885,23 +913,23 @@ package body System.Task_Primitives.Operations is
|
||||
return Environment_Task_ID;
|
||||
end Environment_Task;
|
||||
|
||||
-------------------------
|
||||
-- Lock_All_Tasks_List --
|
||||
-------------------------
|
||||
--------------
|
||||
-- Lock_RTS --
|
||||
--------------
|
||||
|
||||
procedure Lock_All_Tasks_List is
|
||||
procedure Lock_RTS is
|
||||
begin
|
||||
Write_Lock (All_Tasks_L'Access);
|
||||
end Lock_All_Tasks_List;
|
||||
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Lock_RTS;
|
||||
|
||||
---------------------------
|
||||
-- Unlock_All_Tasks_List --
|
||||
---------------------------
|
||||
----------------
|
||||
-- Unlock_RTS --
|
||||
----------------
|
||||
|
||||
procedure Unlock_All_Tasks_List is
|
||||
procedure Unlock_RTS is
|
||||
begin
|
||||
Unlock (All_Tasks_L'Access);
|
||||
end Unlock_All_Tasks_List;
|
||||
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Unlock_RTS;
|
||||
|
||||
------------------
|
||||
-- Suspend_Task --
|
||||
@ -939,7 +967,7 @@ package body System.Task_Primitives.Operations is
|
||||
Environment_Task_ID := Environment_Task;
|
||||
|
||||
-- Initialize the lock used to synchronize chain of all ATCBs.
|
||||
Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
|
||||
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
|
||||
|
||||
Enter_Task (Environment_Task);
|
||||
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.13 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1998-1999 Free Software Fundation --
|
||||
-- Copyright (C) 1998-2001 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -68,6 +67,9 @@ with System.Tasking.Initialization;
|
||||
|
||||
with System.Interrupt_Management;
|
||||
|
||||
with System.Parameters;
|
||||
-- used for Single_Lock
|
||||
|
||||
with Interfaces.C;
|
||||
-- used for int
|
||||
|
||||
@ -75,6 +77,7 @@ with Unchecked_Conversion;
|
||||
|
||||
package body System.Interrupts is
|
||||
|
||||
use Parameters;
|
||||
use Tasking;
|
||||
use Ada.Exceptions;
|
||||
use System.OS_Interface;
|
||||
@ -650,11 +653,21 @@ package body System.Interrupts is
|
||||
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
|
||||
|
||||
@ -7,7 +7,7 @@
|
||||
-- B o d y --
|
||||
-- (Version for IRIX/MIPS) --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
|
||||
-- --
|
||||
@ -66,27 +66,26 @@ package body System.Machine_State_Operations is
|
||||
|
||||
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 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;
|
||||
|
||||
@ -253,11 +252,8 @@ package body System.Machine_State_Operations is
|
||||
------------------------
|
||||
|
||||
procedure Free_Machine_State (M : in out Machine_State) is
|
||||
procedure Gnat_Free (M : in Machine_State);
|
||||
pragma Import (C, Gnat_Free, "__gnat_free");
|
||||
|
||||
begin
|
||||
Gnat_Free (M);
|
||||
Memory.Free (Address (M));
|
||||
M := Machine_State (Null_Address);
|
||||
end Free_Machine_State;
|
||||
|
||||
|
||||
@ -7,9 +7,9 @@
|
||||
-- S p e c --
|
||||
-- (SGI Irix, n32 ABI) --
|
||||
-- --
|
||||
-- $Revision: 1.19 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- 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 --
|
||||
@ -60,16 +60,16 @@ pragma Pure (System);
|
||||
Max_Mantissa : constant := 63;
|
||||
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
|
||||
|
||||
Tick : constant := Standard'Tick;
|
||||
Tick : constant := 1.0;
|
||||
|
||||
-- Storage-related Declarations
|
||||
|
||||
type Address is private;
|
||||
Null_Address : constant Address;
|
||||
|
||||
Storage_Unit : constant := Standard'Storage_Unit;
|
||||
Word_Size : constant := Standard'Word_Size;
|
||||
Memory_Size : constant := 2 ** Standard'Address_Size;
|
||||
Storage_Unit : constant := 8;
|
||||
Word_Size : constant := 64;
|
||||
Memory_Size : constant := 2 ** 32;
|
||||
|
||||
-- Address comparison
|
||||
|
||||
@ -92,27 +92,14 @@ pragma Pure (System);
|
||||
|
||||
-- Priority-related Declarations (RM D.1)
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
Max_Interrupt_Priority : constant Positive := 31;
|
||||
|
||||
subtype Any_Priority is Integer
|
||||
range 0 .. Standard'Max_Interrupt_Priority;
|
||||
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;
|
||||
|
||||
subtype Priority is Any_Priority
|
||||
range 0 .. Standard'Max_Priority;
|
||||
|
||||
-- Functional notation is needed in the following to avoid visibility
|
||||
-- problems when this package is compiled through rtsfind in the middle
|
||||
-- of another compilation.
|
||||
|
||||
subtype Interrupt_Priority is Any_Priority
|
||||
range
|
||||
Standard."+" (Standard'Max_Priority, 1) ..
|
||||
Standard'Max_Interrupt_Priority;
|
||||
|
||||
Default_Priority : constant Priority :=
|
||||
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
|
||||
Default_Priority : constant Priority := 15;
|
||||
|
||||
private
|
||||
|
||||
@ -130,8 +117,11 @@ private
|
||||
-- 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;
|
||||
Denorm : constant Boolean := False;
|
||||
Fractional_Fixed_Ops : constant Boolean := False;
|
||||
Frontend_Layout : constant Boolean := False;
|
||||
Functions_Return_By_DSP : constant Boolean := True;
|
||||
Long_Shifts_Inlined : constant Boolean := True;
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001, Florida State University --
|
||||
-- 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -106,15 +105,16 @@ package body System.Task_Primitives.Operations is
|
||||
-- The followings are logically constants, but need to be initialized
|
||||
-- at run time.
|
||||
|
||||
All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
|
||||
-- See comments on locking rules in System.Tasking (spec).
|
||||
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",
|
||||
"__gl_locking_policy");
|
||||
pragma Import (C, Locking_Policy, "__gl_locking_policy");
|
||||
|
||||
Clock_Address : constant System.Address :=
|
||||
System.Storage_Elements.To_Address (16#200F90#);
|
||||
@ -169,7 +169,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- Note: mutexes and cond_variables needed per-task basis are
|
||||
-- initialized in Initialize_TCB and the Storage_Error is
|
||||
-- handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
|
||||
-- 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.
|
||||
@ -267,7 +267,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_lock (L);
|
||||
|
||||
@ -275,20 +274,24 @@ package body System.Task_Primitives.Operations is
|
||||
pragma Assert (Result /= FUNC_ERR);
|
||||
end Write_Lock;
|
||||
|
||||
procedure Write_Lock (L : access RTS_Lock) is
|
||||
procedure Write_Lock
|
||||
(L : access RTS_Lock; Global_Lock : Boolean := False)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_lock (L);
|
||||
pragma Assert (Result = 0);
|
||||
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
|
||||
Result := pthread_mutex_lock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutex_lock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
end Write_Lock;
|
||||
|
||||
---------------
|
||||
@ -306,132 +309,55 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
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) is
|
||||
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_unlock (L);
|
||||
pragma Assert (Result = 0);
|
||||
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
|
||||
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
end Unlock;
|
||||
|
||||
-------------
|
||||
-- Sleep --
|
||||
-------------
|
||||
-----------
|
||||
-- Sleep --
|
||||
-----------
|
||||
|
||||
procedure Sleep
|
||||
(Self_ID : ST.Task_ID;
|
||||
Reason : System.Tasking.Task_States) is
|
||||
|
||||
Reason : System.Tasking.Task_States)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
pragma Assert (Self_ID = Self);
|
||||
Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access);
|
||||
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;
|
||||
|
||||
-- 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 --
|
||||
-----------------
|
||||
|
||||
-- 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.
|
||||
-- Yielded should be False unles we know for certain that the
|
||||
-- operation resulted in the calling task going to the end of
|
||||
-- the dispatching queue for its priority.
|
||||
-- ?????
|
||||
-- This version presumes the worst, so Yielded is always False.
|
||||
-- On some targets, if cond_timedwait always yields, we could
|
||||
-- set Yielded to True just before the cond_timedwait call.
|
||||
|
||||
procedure Timed_Sleep
|
||||
(Self_ID : Task_ID;
|
||||
Time : Duration;
|
||||
@ -461,8 +387,16 @@ package body System.Task_Primitives.Operations is
|
||||
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
|
||||
or else Self_ID.Pending_Priority_Change;
|
||||
|
||||
Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access, Request'Access);
|
||||
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;
|
||||
|
||||
@ -482,10 +416,6 @@ package body System.Task_Primitives.Operations is
|
||||
-- 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;
|
||||
@ -495,13 +425,18 @@ package body System.Task_Primitives.Operations is
|
||||
Abs_Time : Duration;
|
||||
Request : aliased struct_timeval;
|
||||
Result : Interfaces.C.int;
|
||||
begin
|
||||
|
||||
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
|
||||
@ -523,8 +458,13 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
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);
|
||||
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;
|
||||
|
||||
@ -538,6 +478,11 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
|
||||
Unlock (Self_ID);
|
||||
|
||||
if Single_Lock then
|
||||
Unlock_RTS;
|
||||
end if;
|
||||
|
||||
pthread_yield;
|
||||
SSL.Abort_Undefer.all;
|
||||
end Timed_Delay;
|
||||
@ -578,10 +523,9 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Wakeup
|
||||
(T : ST.Task_ID;
|
||||
Reason : System.Tasking.Task_States) is
|
||||
|
||||
Reason : System.Tasking.Task_States)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_cond_signal (T.Common.LL.CV'Access);
|
||||
pragma Assert (Result = 0);
|
||||
@ -608,7 +552,6 @@ package body System.Task_Primitives.Operations is
|
||||
Loss_Of_Inheritance : Boolean := False)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
T.Common.Current_Priority := Prio;
|
||||
Result := pthread_setprio (T.Common.LL.Thread, Interfaces.C.int (Prio));
|
||||
@ -631,9 +574,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
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;
|
||||
|
||||
@ -642,17 +583,17 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
pragma Assert (Result = 0);
|
||||
|
||||
Lock_All_Tasks_List;
|
||||
Lock_RTS;
|
||||
|
||||
for I in Known_Tasks'Range loop
|
||||
if Known_Tasks (I) = null then
|
||||
Known_Tasks (I) := Self_ID;
|
||||
Self_ID.Known_Tasks_Index := I;
|
||||
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_All_Tasks_List;
|
||||
Unlock_RTS;
|
||||
end Enter_Task;
|
||||
|
||||
--------------
|
||||
@ -669,31 +610,31 @@ package body System.Task_Primitives.Operations is
|
||||
----------------------
|
||||
|
||||
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
|
||||
Result : Interfaces.C.int;
|
||||
Result : Interfaces.C.int;
|
||||
Cond_Attr : aliased pthread_condattr_t;
|
||||
|
||||
begin
|
||||
Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
|
||||
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_mutex_destroy (Self_ID.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
Succeeded := False;
|
||||
return;
|
||||
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;
|
||||
|
||||
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
|
||||
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
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;
|
||||
|
||||
@ -723,6 +664,7 @@ package body System.Task_Primitives.Operations is
|
||||
(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 :=
|
||||
@ -809,8 +751,11 @@ package body System.Task_Primitives.Operations is
|
||||
Tmp : Task_ID := T;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_destroy (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
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);
|
||||
|
||||
@ -836,7 +781,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
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));
|
||||
@ -873,23 +817,23 @@ package body System.Task_Primitives.Operations is
|
||||
return Environment_Task_ID;
|
||||
end Environment_Task;
|
||||
|
||||
-------------------------
|
||||
-- Lock_All_Tasks_List --
|
||||
-------------------------
|
||||
--------------
|
||||
-- Lock_RTS --
|
||||
--------------
|
||||
|
||||
procedure Lock_All_Tasks_List is
|
||||
procedure Lock_RTS is
|
||||
begin
|
||||
Write_Lock (All_Tasks_L'Access);
|
||||
end Lock_All_Tasks_List;
|
||||
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Lock_RTS;
|
||||
|
||||
---------------------------
|
||||
-- Unlock_All_Tasks_List --
|
||||
---------------------------
|
||||
----------------
|
||||
-- Unlock_RTS --
|
||||
----------------
|
||||
|
||||
procedure Unlock_All_Tasks_List is
|
||||
procedure Unlock_RTS is
|
||||
begin
|
||||
Unlock (All_Tasks_L'Access);
|
||||
end Unlock_All_Tasks_List;
|
||||
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Unlock_RTS;
|
||||
|
||||
------------------
|
||||
-- Suspend_Task --
|
||||
@ -929,7 +873,7 @@ package body System.Task_Primitives.Operations is
|
||||
begin
|
||||
Environment_Task_ID := Environment_Task;
|
||||
|
||||
Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
|
||||
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
|
||||
-- Initialize the lock used to synchronize chain of all ATCBs.
|
||||
|
||||
Enter_Task (Environment_Task);
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.2 $ --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
@ -42,6 +42,7 @@ with Interfaces.C;
|
||||
with System.OS_Interface;
|
||||
with System;
|
||||
with Unchecked_Conversion;
|
||||
|
||||
package body System.Task_Info is
|
||||
|
||||
use System.OS_Interface;
|
||||
@ -67,52 +68,72 @@ package body System.Task_Info is
|
||||
TXTLOCK => 2,
|
||||
DATLOCK => 4);
|
||||
|
||||
-------------------------------
|
||||
-- Resource_Vector_Functions --
|
||||
-------------------------------
|
||||
|
||||
package body Resource_Vector_Functions is
|
||||
|
||||
function "+" (R : Resource_T)
|
||||
return Resource_Vector_T 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
|
||||
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
|
||||
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
|
||||
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
|
||||
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
|
||||
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;
|
||||
@ -120,14 +141,19 @@ package body System.Task_Info is
|
||||
|
||||
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
|
||||
|
||||
if Status = 0 then
|
||||
Status := sproc_attr_setresources
|
||||
(Sproc_Attr'Unrestricted_Access,
|
||||
To_Resource_T (Attr.Sproc_Resources));
|
||||
@ -136,13 +162,13 @@ package body System.Task_Info is
|
||||
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;
|
||||
@ -153,6 +179,7 @@ package body System.Task_Info is
|
||||
end if;
|
||||
|
||||
if Attr.NDPRI /= NDP_NONE then
|
||||
-- ??? why is that comment out, should it be removed ?
|
||||
-- if Geteuid /= 0 then
|
||||
-- raise Permission_Error;
|
||||
-- end if;
|
||||
@ -184,13 +211,17 @@ package body System.Task_Info is
|
||||
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
|
||||
|
||||
return sproc_t
|
||||
is
|
||||
Attr : Sproc_Attributes :=
|
||||
(Sproc_Resources, CPU, Resident, NDPRI);
|
||||
|
||||
@ -198,23 +229,37 @@ package body System.Task_Info is
|
||||
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
|
||||
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
|
||||
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;
|
||||
@ -222,8 +267,8 @@ package body System.Task_Info is
|
||||
CPU : CPU_Number := ANY_CPU;
|
||||
Resident : Page_Locking := NOLOCK;
|
||||
NDPRI : Non_Degrading_Priority := NDP_NONE)
|
||||
return Thread_Attributes is
|
||||
|
||||
return Thread_Attributes
|
||||
is
|
||||
Sproc : sproc_t := New_Sproc
|
||||
(Sproc_Resources, CPU, Resident, NDPRI);
|
||||
|
||||
@ -231,25 +276,39 @@ package body System.Task_Info is
|
||||
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
|
||||
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
|
||||
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;
|
||||
@ -257,8 +316,8 @@ package body System.Task_Info is
|
||||
CPU : CPU_Number := ANY_CPU;
|
||||
Resident : Page_Locking := NOLOCK;
|
||||
NDPRI : Non_Degrading_Priority := NDP_NONE)
|
||||
return Task_Info_Type is
|
||||
|
||||
return Task_Info_Type
|
||||
is
|
||||
Sproc : sproc_t := New_Sproc
|
||||
(Sproc_Resources, CPU, Resident, NDPRI);
|
||||
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.4 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
@ -40,6 +40,7 @@
|
||||
|
||||
with System.OS_Interface;
|
||||
with Unchecked_Deallocation;
|
||||
|
||||
package System.Task_Info is
|
||||
pragma Elaborate_Body;
|
||||
-- To ensure that a body is allowed
|
||||
@ -49,10 +50,10 @@ pragma Elaborate_Body;
|
||||
---------------------------------------------------------
|
||||
|
||||
-- The SGI implementation of the GNU Low-Level Interface (GNULLI)
|
||||
-- implements each Ada task as a Posix thread (Pthread). The SGI
|
||||
-- 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
|
||||
-- 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.
|
||||
|
||||
@ -103,19 +104,37 @@ pragma Elaborate_Body;
|
||||
NO_RESOURCES : constant Resource_Vector_T := (others => False);
|
||||
|
||||
generic
|
||||
type Resource_T is (<>); -- Discrete type up to 32 entries
|
||||
type Resource_T is (<>);
|
||||
-- Discrete type up to 32 entries
|
||||
|
||||
package Resource_Vector_Functions is
|
||||
function "+"(R : Resource_T)
|
||||
function "+"
|
||||
(R : Resource_T)
|
||||
return Resource_Vector_T;
|
||||
function "+"(R1, R2 : Resource_T)
|
||||
|
||||
function "+"
|
||||
(R1 : Resource_T;
|
||||
R2 : Resource_T)
|
||||
return Resource_Vector_T;
|
||||
function "+"(R : Resource_T; S : Resource_Vector_T)
|
||||
|
||||
function "+"
|
||||
(R : Resource_T;
|
||||
S : Resource_Vector_T)
|
||||
return Resource_Vector_T;
|
||||
function "+"(S : Resource_Vector_T; R : Resource_T)
|
||||
|
||||
function "+"
|
||||
(S : Resource_Vector_T;
|
||||
R : Resource_T)
|
||||
return Resource_Vector_T;
|
||||
function "+"(S1, S2 : Resource_Vector_T)
|
||||
|
||||
function "+"
|
||||
(S1 : Resource_Vector_T;
|
||||
S2 : Resource_Vector_T)
|
||||
return Resource_Vector_T;
|
||||
function "-"(S : Resource_Vector_T; R : Resource_T)
|
||||
|
||||
function "-"
|
||||
(S : Resource_Vector_T;
|
||||
R : Resource_T)
|
||||
return Resource_Vector_T;
|
||||
end Resource_Vector_Functions;
|
||||
|
||||
@ -129,7 +148,7 @@ pragma Elaborate_Body;
|
||||
|
||||
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.
|
||||
@ -138,24 +157,22 @@ pragma Elaborate_Body;
|
||||
--
|
||||
-- See the schedctl(2) man page for a complete discussion of non-degrading
|
||||
-- priorities.
|
||||
--
|
||||
type Non_Degrading_Priority is range 0 .. 255;
|
||||
|
||||
-- these priorities are higher than ALL normal user process priorities
|
||||
NDPHIMAX : constant Non_Degrading_Priority := 30;
|
||||
NDPHIMIN : constant Non_Degrading_Priority := 39;
|
||||
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;
|
||||
|
||||
-- these priorities overlap normal user process priorities
|
||||
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;
|
||||
|
||||
-- these priorities are below ALL normal user process priorities
|
||||
NDPLOMAX : constant Non_Degrading_Priority := 128;
|
||||
NDPLOMIN : constant Non_Degrading_Priority := 254;
|
||||
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;
|
||||
|
||||
@ -168,17 +185,16 @@ pragma Elaborate_Body;
|
||||
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;
|
||||
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;
|
||||
end record;
|
||||
|
||||
Default_Sproc_Attributes : constant Sproc_Attributes :=
|
||||
(NO_RESOURCES, ANY_CPU, NOLOCK, NDP_NONE);
|
||||
@ -190,10 +206,8 @@ pragma Elaborate_Body;
|
||||
Resident : Page_Locking := NOLOCK;
|
||||
NDPRI : Non_Degrading_Priority := NDP_NONE)
|
||||
return sproc_t;
|
||||
--
|
||||
-- Allocates a sproc_t controll structure and creates the
|
||||
-- Allocates a sproc_t control structure and creates the
|
||||
-- corresponding sproc.
|
||||
--
|
||||
|
||||
Invalid_CPU_Number : exception;
|
||||
Permission_Error : exception;
|
||||
@ -203,17 +217,18 @@ pragma Elaborate_Body;
|
||||
-- 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;
|
||||
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);
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.5 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
@ -34,6 +34,7 @@
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- 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
|
||||
@ -101,7 +102,7 @@ pragma Pure (Parameters);
|
||||
-- proper implementation of the stack overflow check.
|
||||
|
||||
----------------------------------------------
|
||||
-- Characteristics of types in Interfaces.C --
|
||||
-- Characteristics of Types in Interfaces.C --
|
||||
----------------------------------------------
|
||||
|
||||
long_bits : constant := Long_Integer'Size;
|
||||
@ -132,4 +133,59 @@ pragma Pure (Parameters);
|
||||
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 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);
|
||||
|
||||
--------------------
|
||||
-- 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;
|
||||
|
||||
@ -7,9 +7,9 @@
|
||||
-- S p e c --
|
||||
-- (HP-UX Version) --
|
||||
-- --
|
||||
-- $Revision: 1.15 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- 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 --
|
||||
@ -60,16 +60,16 @@ pragma Pure (System);
|
||||
Max_Mantissa : constant := 63;
|
||||
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
|
||||
|
||||
Tick : constant := Standard'Tick;
|
||||
Tick : constant := 1.0;
|
||||
|
||||
-- Storage-related Declarations
|
||||
|
||||
type Address is private;
|
||||
Null_Address : constant Address;
|
||||
|
||||
Storage_Unit : constant := Standard'Storage_Unit;
|
||||
Word_Size : constant := Standard'Word_Size;
|
||||
Memory_Size : constant := 2 ** Standard'Address_Size;
|
||||
Storage_Unit : constant := 8;
|
||||
Word_Size : constant := 32;
|
||||
Memory_Size : constant := 2 ** 32;
|
||||
|
||||
-- Address comparison
|
||||
|
||||
@ -92,27 +92,14 @@ pragma Pure (System);
|
||||
|
||||
-- Priority-related Declarations (RM D.1)
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
Max_Interrupt_Priority : constant Positive := 31;
|
||||
|
||||
subtype Any_Priority is Integer
|
||||
range 0 .. Standard'Max_Interrupt_Priority;
|
||||
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;
|
||||
|
||||
subtype Priority is Any_Priority
|
||||
range 0 .. Standard'Max_Priority;
|
||||
|
||||
-- Functional notation is needed in the following to avoid visibility
|
||||
-- problems when this package is compiled through rtsfind in the middle
|
||||
-- of another compilation.
|
||||
|
||||
subtype Interrupt_Priority is Any_Priority
|
||||
range
|
||||
Standard."+" (Standard'Max_Priority, 1) ..
|
||||
Standard'Max_Interrupt_Priority;
|
||||
|
||||
Default_Priority : constant Priority :=
|
||||
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
|
||||
Default_Priority : constant Priority := 15;
|
||||
|
||||
private
|
||||
|
||||
@ -130,8 +117,11 @@ private
|
||||
-- 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;
|
||||
Denorm : constant Boolean := False;
|
||||
Fractional_Fixed_Ops : constant Boolean := False;
|
||||
Frontend_Layout : constant Boolean := False;
|
||||
Functions_Return_By_DSP : constant Boolean := False;
|
||||
Long_Shifts_Inlined : constant Boolean := False;
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001, Florida State University --
|
||||
-- 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- --
|
||||
@ -29,12 +29,11 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is a HP-UX version of this package
|
||||
-- This is a HP-UX DCE threads version of this package
|
||||
|
||||
-- This package contains all the GNULL primitives that interface directly
|
||||
-- with the underlying OS.
|
||||
@ -106,8 +105,10 @@ package body System.Task_Primitives.Operations is
|
||||
ATCB_Key : aliased pthread_key_t;
|
||||
-- Key used to find the Ada Task_ID associated with a thread
|
||||
|
||||
All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
|
||||
-- See comments on locking rules in System.Tasking (spec).
|
||||
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.
|
||||
@ -143,53 +144,12 @@ package body System.Task_Primitives.Operations is
|
||||
-- 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.
|
||||
|
||||
-- Alternative solutions include:
|
||||
|
||||
-- 1. Change the PC saved in the system-dependent Context
|
||||
-- parameter to point to code that raises the exception.
|
||||
-- Normal return from this handler will then raise
|
||||
-- the exception after the mask and other system state has
|
||||
-- been restored (see example below).
|
||||
-- 2. Use siglongjmp()/sigsetjmp() to implement exceptions.
|
||||
-- 3. Unmask the signal in the Abortion_Signal exception handler
|
||||
-- (in the RTS).
|
||||
|
||||
-- The following procedure would be needed if we can't lonjmp out of
|
||||
-- a signal handler. (See below.)
|
||||
-- procedure Raise_Abort_Signal is
|
||||
-- begin
|
||||
-- raise Standard'Abort_Signal;
|
||||
-- end if;
|
||||
|
||||
procedure Abort_Handler (Sig : Signal) is
|
||||
Self_Id : constant Task_ID := Self;
|
||||
Result : Interfaces.C.int;
|
||||
Old_Set : aliased sigset_t;
|
||||
|
||||
begin
|
||||
-- Assuming it is safe to longjmp out of a signal handler, the
|
||||
-- following code can be used:
|
||||
|
||||
if Self_Id.Deferral_Level = 0
|
||||
and then Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level and then
|
||||
not Self_Id.Aborting
|
||||
@ -204,15 +164,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
raise Standard'Abort_Signal;
|
||||
end if;
|
||||
|
||||
-- Otherwise, something like this is required:
|
||||
-- if not Abort_Is_Deferred.all then
|
||||
-- -- Overwrite the return PC address with the address of the
|
||||
-- -- special raise routine, and "return" to that routine's
|
||||
-- -- starting address.
|
||||
-- Context.PC := Raise_Abort_Signal'Address;
|
||||
-- return;
|
||||
-- end if;
|
||||
end Abort_Handler;
|
||||
|
||||
-----------------
|
||||
@ -243,7 +194,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
function Self return Task_ID is
|
||||
Result : System.Address;
|
||||
|
||||
begin
|
||||
Result := pthread_getspecific (ATCB_Key);
|
||||
pragma Assert (Result /= System.Null_Address);
|
||||
@ -256,7 +206,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- Note: mutexes and cond_variables needed per-task basis are
|
||||
-- initialized in Initialize_TCB and the Storage_Error is
|
||||
-- handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
|
||||
-- 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.
|
||||
@ -266,7 +216,8 @@ package body System.Task_Primitives.Operations is
|
||||
L : access Lock)
|
||||
is
|
||||
Attributes : aliased pthread_mutexattr_t;
|
||||
Result : Interfaces.C.int;
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutexattr_init (Attributes'Access);
|
||||
pragma Assert (Result = 0 or else Result = ENOMEM);
|
||||
@ -290,7 +241,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
|
||||
Attributes : aliased pthread_mutexattr_t;
|
||||
Result : Interfaces.C.int;
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutexattr_init (Attributes'Access);
|
||||
@ -318,7 +269,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Finalize_Lock (L : access Lock) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_destroy (L.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
@ -326,7 +276,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Finalize_Lock (L : access RTS_Lock) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_destroy (L);
|
||||
pragma Assert (Result = 0);
|
||||
@ -337,8 +286,7 @@ package body System.Task_Primitives.Operations is
|
||||
----------------
|
||||
|
||||
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
Result : Interfaces.C.int;
|
||||
begin
|
||||
L.Owner_Priority := Get_Priority (Self);
|
||||
|
||||
@ -352,20 +300,24 @@ package body System.Task_Primitives.Operations is
|
||||
Ceiling_Violation := False;
|
||||
end Write_Lock;
|
||||
|
||||
procedure Write_Lock (L : access RTS_Lock) is
|
||||
procedure Write_Lock
|
||||
(L : access RTS_Lock; Global_Lock : Boolean := False)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_lock (L);
|
||||
pragma Assert (Result = 0);
|
||||
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
|
||||
Result := pthread_mutex_lock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutex_lock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
end Write_Lock;
|
||||
|
||||
---------------
|
||||
@ -382,41 +334,48 @@ package body System.Task_Primitives.Operations is
|
||||
------------
|
||||
|
||||
procedure Unlock (L : access Lock) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
Result : Interfaces.C.int;
|
||||
begin
|
||||
Result := pthread_mutex_unlock (L.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
end Unlock;
|
||||
|
||||
procedure Unlock (L : access RTS_Lock) is
|
||||
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_unlock (L);
|
||||
pragma Assert (Result = 0);
|
||||
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
|
||||
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
end Unlock;
|
||||
|
||||
-------------
|
||||
-- Sleep --
|
||||
-------------
|
||||
-----------
|
||||
-- Sleep --
|
||||
-----------
|
||||
|
||||
procedure Sleep (Self_ID : Task_ID;
|
||||
Reason : System.Tasking.Task_States) is
|
||||
procedure Sleep
|
||||
(Self_ID : Task_ID;
|
||||
Reason : System.Tasking.Task_States)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
pragma Assert (Self_ID = Self);
|
||||
Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access);
|
||||
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;
|
||||
@ -425,10 +384,6 @@ package body System.Task_Primitives.Operations is
|
||||
-- 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;
|
||||
@ -441,6 +396,7 @@ package body System.Task_Primitives.Operations is
|
||||
Abs_Time : Duration;
|
||||
Request : aliased timespec;
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Timedout := True;
|
||||
Yielded := False;
|
||||
@ -458,9 +414,16 @@ package body System.Task_Primitives.Operations is
|
||||
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
|
||||
or else Self_ID.Pending_Priority_Change;
|
||||
|
||||
Result := pthread_cond_timedwait
|
||||
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
|
||||
Request'Access);
|
||||
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;
|
||||
|
||||
@ -479,10 +442,6 @@ package body System.Task_Primitives.Operations is
|
||||
-- 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;
|
||||
@ -492,13 +451,18 @@ package body System.Task_Primitives.Operations is
|
||||
Abs_Time : Duration;
|
||||
Request : aliased timespec;
|
||||
Result : Interfaces.C.int;
|
||||
begin
|
||||
|
||||
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
|
||||
@ -520,8 +484,13 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
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);
|
||||
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;
|
||||
|
||||
@ -534,6 +503,11 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
|
||||
Unlock (Self_ID);
|
||||
|
||||
if Single_Lock then
|
||||
Unlock_RTS;
|
||||
end if;
|
||||
|
||||
Result := sched_yield;
|
||||
SSL.Abort_Undefer.all;
|
||||
end Timed_Delay;
|
||||
@ -567,7 +541,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_cond_signal (T.Common.LL.CV'Access);
|
||||
pragma Assert (Result = 0);
|
||||
@ -579,7 +552,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Yield (Do_Yield : Boolean := True) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
if Do_Yield then
|
||||
Result := sched_yield;
|
||||
@ -681,15 +653,17 @@ package body System.Task_Primitives.Operations is
|
||||
Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID));
|
||||
pragma Assert (Result = 0);
|
||||
|
||||
Lock_All_Tasks_List;
|
||||
for I in Known_Tasks'Range loop
|
||||
if Known_Tasks (I) = null then
|
||||
Known_Tasks (I) := Self_ID;
|
||||
Self_ID.Known_Tasks_Index := I;
|
||||
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_All_Tasks_List;
|
||||
|
||||
Unlock_RTS;
|
||||
end Enter_Task;
|
||||
|
||||
--------------
|
||||
@ -701,55 +675,52 @@ package body System.Task_Primitives.Operations is
|
||||
return new Ada_Task_Control_Block (Entry_Num);
|
||||
end New_ATCB;
|
||||
|
||||
----------------------
|
||||
-- Initialize_TCB --
|
||||
----------------------
|
||||
--------------------
|
||||
-- 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;
|
||||
Result : Interfaces.C.int;
|
||||
Cond_Attr : aliased pthread_condattr_t;
|
||||
|
||||
begin
|
||||
Result := pthread_mutexattr_init (Mutex_Attr'Access);
|
||||
pragma Assert (Result = 0 or else Result = ENOMEM);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutexattr_init (Mutex_Attr'Access);
|
||||
pragma Assert (Result = 0 or else Result = ENOMEM);
|
||||
|
||||
if Result /= 0 then
|
||||
Succeeded := False;
|
||||
return;
|
||||
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_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;
|
||||
|
||||
Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
|
||||
pragma Assert (Result = 0);
|
||||
|
||||
Result := pthread_condattr_init (Cond_Attr'Access);
|
||||
pragma Assert (Result = 0 or else Result = ENOMEM);
|
||||
|
||||
if Result /= 0 then
|
||||
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
Succeeded := False;
|
||||
return;
|
||||
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;
|
||||
|
||||
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
|
||||
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
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;
|
||||
|
||||
@ -834,8 +805,11 @@ package body System.Task_Primitives.Operations is
|
||||
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_destroy (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
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);
|
||||
|
||||
@ -901,23 +875,23 @@ package body System.Task_Primitives.Operations is
|
||||
return Environment_Task_ID;
|
||||
end Environment_Task;
|
||||
|
||||
-------------------------
|
||||
-- Lock_All_Tasks_List --
|
||||
-------------------------
|
||||
--------------
|
||||
-- Lock_RTS --
|
||||
--------------
|
||||
|
||||
procedure Lock_All_Tasks_List is
|
||||
procedure Lock_RTS is
|
||||
begin
|
||||
Write_Lock (All_Tasks_L'Access);
|
||||
end Lock_All_Tasks_List;
|
||||
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Lock_RTS;
|
||||
|
||||
---------------------------
|
||||
-- Unlock_All_Tasks_List --
|
||||
---------------------------
|
||||
----------------
|
||||
-- Unlock_RTS --
|
||||
----------------
|
||||
|
||||
procedure Unlock_All_Tasks_List is
|
||||
procedure Unlock_RTS is
|
||||
begin
|
||||
Unlock (All_Tasks_L'Access);
|
||||
end Unlock_All_Tasks_List;
|
||||
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Unlock_RTS;
|
||||
|
||||
------------------
|
||||
-- Suspend_Task --
|
||||
@ -955,7 +929,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
Environment_Task_ID := Environment_Task;
|
||||
|
||||
Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
|
||||
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
|
||||
-- Initialize the lock used to synchronize chain of all ATCBs.
|
||||
|
||||
Enter_Task (Environment_Task);
|
||||
@ -985,7 +959,6 @@ package body System.Task_Primitives.Operations is
|
||||
end do_nothing;
|
||||
|
||||
begin
|
||||
|
||||
declare
|
||||
Result : Interfaces.C.int;
|
||||
begin
|
||||
@ -998,5 +971,4 @@ begin
|
||||
Result := pthread_key_create (ATCB_Key'Access, do_nothing'Access);
|
||||
pragma Assert (Result = 0);
|
||||
end;
|
||||
|
||||
end System.Task_Primitives.Operations;
|
||||
|
||||
@ -7,9 +7,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.10 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
|
||||
-- Copyright (C) 1999-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- --
|
||||
@ -200,9 +200,6 @@ package body System.Traceback is
|
||||
-- Descriptors.
|
||||
|
||||
subtype UWT is Unwind_Table_Region;
|
||||
type UWT_Ptr is access all UWT;
|
||||
|
||||
function To_UWT_Address is new Ada.Unchecked_Conversion (UWT_Ptr, Address);
|
||||
|
||||
-- The subprograms imported below are provided by the HP library
|
||||
|
||||
@ -598,4 +595,3 @@ package body System.Traceback is
|
||||
end Call_Chain;
|
||||
|
||||
end System.Traceback;
|
||||
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.2 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001, Florida State University --
|
||||
-- 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -112,11 +111,10 @@ package body System.Task_Primitives.Operations is
|
||||
-- The followings are logically constants, but need to be initialized
|
||||
-- at run time.
|
||||
|
||||
ATCB_Key : aliased pthread_key_t;
|
||||
-- Key used to find the Ada Task_ID associated with a thread
|
||||
|
||||
All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
|
||||
-- See comments on locking rules in System.Tasking (spec).
|
||||
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.
|
||||
@ -186,6 +184,29 @@ package body System.Task_Primitives.Operations is
|
||||
function To_pthread_t is new Unchecked_Conversion
|
||||
(Integer, System.OS_Interface.pthread_t);
|
||||
|
||||
--------------------
|
||||
-- Local Packages --
|
||||
--------------------
|
||||
|
||||
package Specific is
|
||||
|
||||
procedure Initialize (Environment_Task : Task_ID);
|
||||
pragma Inline (Initialize);
|
||||
-- Initialize various data needed by this package.
|
||||
|
||||
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.
|
||||
|
||||
-------------------
|
||||
-- Abort_Handler --
|
||||
-------------------
|
||||
@ -297,9 +318,27 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
end Abort_Handler;
|
||||
|
||||
-------------------
|
||||
-- Stack_Guard --
|
||||
-------------------
|
||||
--------------
|
||||
-- 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.
|
||||
@ -322,14 +361,7 @@ package body System.Task_Primitives.Operations is
|
||||
-- Self --
|
||||
----------
|
||||
|
||||
function Self return Task_ID is
|
||||
Result : System.Address;
|
||||
|
||||
begin
|
||||
Result := pthread_getspecific (ATCB_Key);
|
||||
pragma Assert (Result /= System.Null_Address);
|
||||
return To_Task_ID (Result);
|
||||
end Self;
|
||||
function Self return Task_ID renames Specific.Self;
|
||||
|
||||
---------------------
|
||||
-- Initialize_Lock --
|
||||
@ -337,7 +369,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- Note: mutexes and cond_variables needed per-task basis are
|
||||
-- initialized in Initialize_TCB and the Storage_Error is
|
||||
-- handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
|
||||
-- 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.
|
||||
@ -401,7 +433,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
if Priority_Ceiling_Emulation then
|
||||
declare
|
||||
@ -427,20 +458,24 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
end Write_Lock;
|
||||
|
||||
procedure Write_Lock (L : access RTS_Lock) is
|
||||
procedure Write_Lock
|
||||
(L : access RTS_Lock; Global_Lock : Boolean := False)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_lock (L);
|
||||
pragma Assert (Result = 0);
|
||||
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
|
||||
Result := pthread_mutex_lock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutex_lock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
end Write_Lock;
|
||||
|
||||
---------------
|
||||
@ -458,7 +493,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Unlock (L : access Lock) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
if Priority_Ceiling_Emulation then
|
||||
declare
|
||||
@ -476,39 +510,44 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
end Unlock;
|
||||
|
||||
procedure Unlock (L : access RTS_Lock) is
|
||||
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
|
||||
Result : Interfaces.C.int;
|
||||
-- Beware of any changes to this that might
|
||||
-- require access to the ATCB after the mutex is unlocked.
|
||||
-- This is the last operation performed by a task
|
||||
-- before it allows its ATCB to be deallocated, so it
|
||||
-- MUST NOT refer to the ATCB.
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_unlock (L);
|
||||
pragma Assert (Result = 0);
|
||||
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
|
||||
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
end Unlock;
|
||||
|
||||
-------------
|
||||
-- Sleep --
|
||||
-------------
|
||||
-----------
|
||||
-- Sleep --
|
||||
-----------
|
||||
|
||||
procedure Sleep (Self_ID : Task_ID;
|
||||
Reason : System.Tasking.Task_States) is
|
||||
procedure Sleep
|
||||
(Self_ID : Task_ID;
|
||||
Reason : System.Tasking.Task_States)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
pragma Assert (Self_ID = Self);
|
||||
Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access);
|
||||
|
||||
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;
|
||||
@ -550,9 +589,16 @@ package body System.Task_Primitives.Operations is
|
||||
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
|
||||
or else Self_ID.Pending_Priority_Change;
|
||||
|
||||
Result := pthread_cond_timedwait
|
||||
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access,
|
||||
Request'Access);
|
||||
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;
|
||||
|
||||
@ -591,6 +637,11 @@ package body System.Task_Primitives.Operations is
|
||||
-- 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
|
||||
@ -612,8 +663,13 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
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);
|
||||
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;
|
||||
|
||||
@ -626,6 +682,11 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
|
||||
Unlock (Self_ID);
|
||||
|
||||
if Single_Lock then
|
||||
Unlock_RTS;
|
||||
end if;
|
||||
|
||||
Result := sched_yield;
|
||||
SSL.Abort_Undefer.all;
|
||||
end Timed_Delay;
|
||||
@ -734,23 +795,22 @@ package body System.Task_Primitives.Operations is
|
||||
----------------
|
||||
|
||||
procedure Enter_Task (Self_ID : Task_ID) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Self_ID.Common.LL.Thread := pthread_self;
|
||||
|
||||
Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID));
|
||||
pragma Assert (Result = 0);
|
||||
Specific.Set (Self_ID);
|
||||
|
||||
Lock_All_Tasks_List;
|
||||
for I in Known_Tasks'Range loop
|
||||
if Known_Tasks (I) = null then
|
||||
Known_Tasks (I) := Self_ID;
|
||||
Self_ID.Known_Tasks_Index := I;
|
||||
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_All_Tasks_List;
|
||||
|
||||
Unlock_RTS;
|
||||
end Enter_Task;
|
||||
|
||||
--------------
|
||||
@ -778,13 +838,15 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
Self_ID.Common.LL.Thread := To_pthread_t (-1);
|
||||
|
||||
Result := pthread_mutex_init (Self_ID.Common.LL.L'Access,
|
||||
Mutex_Attr'Access);
|
||||
pragma Assert (Result = 0 or else Result = ENOMEM);
|
||||
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;
|
||||
if Result /= 0 then
|
||||
Succeeded := False;
|
||||
return;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
Result := pthread_cond_init (Self_ID.Common.LL.CV'Access,
|
||||
@ -794,13 +856,13 @@ package body System.Task_Primitives.Operations is
|
||||
if Result = 0 then
|
||||
Succeeded := True;
|
||||
else
|
||||
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
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;
|
||||
|
||||
-----------------
|
||||
@ -865,13 +927,18 @@ package body System.Task_Primitives.Operations is
|
||||
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_destroy (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
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;
|
||||
|
||||
@ -927,24 +994,6 @@ package body System.Task_Primitives.Operations is
|
||||
return Environment_Task_ID;
|
||||
end Environment_Task;
|
||||
|
||||
-------------------------
|
||||
-- Lock_All_Tasks_List --
|
||||
-------------------------
|
||||
|
||||
procedure Lock_All_Tasks_List is
|
||||
begin
|
||||
Write_Lock (All_Tasks_L'Access);
|
||||
end Lock_All_Tasks_List;
|
||||
|
||||
---------------------------
|
||||
-- Unlock_All_Tasks_List --
|
||||
---------------------------
|
||||
|
||||
procedure Unlock_All_Tasks_List is
|
||||
begin
|
||||
Unlock (All_Tasks_L'Access);
|
||||
end Unlock_All_Tasks_List;
|
||||
|
||||
------------------
|
||||
-- Suspend_Task --
|
||||
------------------
|
||||
@ -994,8 +1043,10 @@ package body System.Task_Primitives.Operations is
|
||||
Result := pthread_condattr_init (Cond_Attr'Access);
|
||||
pragma Assert (Result = 0 or else Result = ENOMEM);
|
||||
|
||||
Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
|
||||
-- Initialize the lock used to synchronize chain of all ATCBs.
|
||||
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
|
||||
-- Initialize the global RTS lock
|
||||
|
||||
Specific.Initialize (Environment_Task);
|
||||
|
||||
Enter_Task (Environment_Task);
|
||||
|
||||
@ -1038,9 +1089,5 @@ begin
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Result := pthread_key_create (ATCB_Key'Access, null);
|
||||
pragma Assert (Result = 0);
|
||||
end;
|
||||
|
||||
end System.Task_Primitives.Operations;
|
||||
|
||||
@ -7,9 +7,9 @@
|
||||
-- S p e c --
|
||||
-- (VxWorks version M68K) --
|
||||
-- --
|
||||
-- $Revision: 1.11 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- 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 --
|
||||
@ -60,16 +60,16 @@ pragma Pure (System);
|
||||
Max_Mantissa : constant := 63;
|
||||
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
|
||||
|
||||
Tick : constant := Standard'Tick;
|
||||
Tick : constant := 1.0;
|
||||
|
||||
-- Storage-related Declarations
|
||||
|
||||
type Address is private;
|
||||
Null_Address : constant Address;
|
||||
|
||||
Storage_Unit : constant := Standard'Storage_Unit;
|
||||
Word_Size : constant := Standard'Word_Size;
|
||||
Memory_Size : constant := 2 ** Standard'Address_Size;
|
||||
Storage_Unit : constant := 8;
|
||||
Word_Size : constant := 32;
|
||||
Memory_Size : constant := 2 ** 32;
|
||||
|
||||
-- Address comparison
|
||||
|
||||
@ -88,40 +88,26 @@ pragma Pure (System);
|
||||
-- Other System-Dependent Declarations
|
||||
|
||||
type Bit_Order is (High_Order_First, Low_Order_First);
|
||||
Default_Bit_Order : constant Bit_Order :=
|
||||
Bit_Order'Val (Standard'Default_Bit_Order);
|
||||
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;
|
||||
-- 256 is reserved for the VxWorks kernel
|
||||
-- 248 - 255 correspond to hardware interrupt levels 0 .. 7
|
||||
-- 247 is a catchall default "interrupt" priority for signals,
|
||||
-- allowing higher priority than normal tasks, but lower than
|
||||
-- hardware priority levels. Protected Object ceilings can
|
||||
-- override these values.
|
||||
-- 246 is used by the Interrupt_Manager task
|
||||
|
||||
Max_Priority : constant Positive := 245;
|
||||
Max_Interrupt_Priority : constant Positive := 255;
|
||||
|
||||
subtype Any_Priority is Integer
|
||||
range 0 .. Standard'Max_Interrupt_Priority;
|
||||
subtype Any_Priority is Integer range 0 .. 255;
|
||||
subtype Priority is Any_Priority range 0 .. 245;
|
||||
subtype Interrupt_Priority is Any_Priority range 246 .. 255;
|
||||
|
||||
subtype Priority is Any_Priority
|
||||
range 0 .. Standard'Max_Priority;
|
||||
|
||||
-- Functional notation is needed in the following to avoid visibility
|
||||
-- problems when this package is compiled through rtsfind in the middle
|
||||
-- of another compilation.
|
||||
|
||||
subtype Interrupt_Priority is Any_Priority
|
||||
range
|
||||
Standard."+" (Standard'Max_Priority, 1) ..
|
||||
Standard'Max_Interrupt_Priority;
|
||||
|
||||
Default_Priority : constant Priority :=
|
||||
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
|
||||
Default_Priority : constant Priority := 122;
|
||||
|
||||
private
|
||||
|
||||
@ -139,8 +125,11 @@ private
|
||||
-- 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;
|
||||
Denorm : constant Boolean := True;
|
||||
Fractional_Fixed_Ops : constant Boolean := False;
|
||||
Frontend_Layout : constant Boolean := False;
|
||||
Functions_Return_By_DSP : constant Boolean := False;
|
||||
Long_Shifts_Inlined : constant Boolean := False;
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.2 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1998-2001 Free Software Foundation --
|
||||
-- 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- --
|
||||
@ -43,30 +43,9 @@ package System.VxWorks is
|
||||
|
||||
package IC renames Interfaces.C;
|
||||
|
||||
-- Define enough of a Wind Task Control Block in order to
|
||||
-- obtain the inherited priority. When porting this to
|
||||
-- different versions of VxWorks (this is based on 5.3[.1]),
|
||||
-- be sure to look at the definition for WIND_TCB located
|
||||
-- in $WIND_BASE/target/h/taskLib.h
|
||||
-- Floating point context record. 68K version
|
||||
|
||||
type Wind_Fill_1 is array (0 .. 16#3F#) of IC.unsigned_char;
|
||||
type Wind_Fill_2 is array (16#48# .. 16#107#) of IC.unsigned_char;
|
||||
|
||||
type Wind_TCB is record
|
||||
Fill_1 : Wind_Fill_1; -- 0x00 - 0x3f
|
||||
Priority : IC.int; -- 0x40 - 0x43, current (inherited) priority
|
||||
Normal_Priority : IC.int; -- 0x44 - 0x47, base priority
|
||||
Fill_2 : Wind_Fill_2; -- 0x48 - 0x107
|
||||
spare1 : Address; -- 0x108 - 0x10b
|
||||
spare2 : Address; -- 0x10c - 0x10f
|
||||
spare3 : Address; -- 0x110 - 0x113
|
||||
spare4 : Address; -- 0x114 - 0x117
|
||||
end record;
|
||||
type Wind_TCB_Ptr is access Wind_TCB;
|
||||
|
||||
-- Floating point context record. 68K version
|
||||
|
||||
FP_NUM_DREGS : constant := 8;
|
||||
FP_NUM_DREGS : constant := 8;
|
||||
FP_STATE_FRAME_SIZE : constant := 216;
|
||||
|
||||
type DOUBLEX is array (1 .. 12) of Interfaces.Unsigned_8;
|
||||
@ -97,25 +76,4 @@ package System.VxWorks is
|
||||
Num_HW_Interrupts : constant := 256;
|
||||
-- Number of entries in the hardware interrupt vector table
|
||||
|
||||
-- VxWorks 5.3 and 5.4 version
|
||||
type TASK_DESC is record
|
||||
td_id : IC.int; -- task id
|
||||
td_name : Address; -- name of task
|
||||
td_priority : IC.int; -- task priority
|
||||
td_status : IC.int; -- task status
|
||||
td_options : IC.int; -- task option bits (see below)
|
||||
td_entry : Address; -- original entry point of task
|
||||
td_sp : Address; -- saved stack pointer
|
||||
td_pStackBase : Address; -- the bottom of the stack
|
||||
td_pStackLimit : Address; -- the effective end of the stack
|
||||
td_pStackEnd : Address; -- the actual end of the stack
|
||||
td_stackSize : IC.int; -- size of stack in bytes
|
||||
td_stackCurrent : IC.int; -- current stack usage in bytes
|
||||
td_stackHigh : IC.int; -- maximum stack usage in bytes
|
||||
td_stackMargin : IC.int; -- current stack margin in bytes
|
||||
td_errorStatus : IC.int; -- most recent task error status
|
||||
td_delay : IC.int; -- delay/timeout ticks
|
||||
end record;
|
||||
pragma Convention (C, TASK_DESC);
|
||||
|
||||
end System.VxWorks;
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.2 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Florida State University --
|
||||
-- Copyright (C) 1991-2002 Florida State University --
|
||||
-- --
|
||||
-- GNARL is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
@ -304,33 +304,22 @@ begin
|
||||
|
||||
act.sa_mask := Signal_Mask;
|
||||
|
||||
Result :=
|
||||
sigaction
|
||||
(Signal (SIGFPE), act'Unchecked_Access,
|
||||
old_act'Unchecked_Access);
|
||||
pragma Assert (Result = 0);
|
||||
|
||||
for J in Exception_Interrupts'First + 1 .. Exception_Interrupts'Last loop
|
||||
for J in Exception_Interrupts'Range loop
|
||||
Keep_Unmasked (Exception_Interrupts (J)) := True;
|
||||
if Unreserve_All_Interrupts = 0 then
|
||||
Result :=
|
||||
sigaction
|
||||
(Signal (Exception_Interrupts (J)),
|
||||
act'Unchecked_Access,
|
||||
old_act'Unchecked_Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
Result :=
|
||||
sigaction
|
||||
(Signal (Exception_Interrupts (J)),
|
||||
act'Unchecked_Access,
|
||||
old_act'Unchecked_Access);
|
||||
pragma Assert (Result = 0);
|
||||
end loop;
|
||||
|
||||
Keep_Unmasked (Abort_Task_Interrupt) := True;
|
||||
Keep_Unmasked (SIGXCPU) := True;
|
||||
Keep_Unmasked (SIGBUS) := True;
|
||||
Keep_Unmasked (SIGFPE) := True;
|
||||
|
||||
-- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but in the
|
||||
-- same time, disable the ability of handling this signal
|
||||
-- via Ada.Interrupts.
|
||||
-- The pragma Unreserve_All_Interrupts let the user the ability to
|
||||
-- The pragma Unreserve_All_Interrupts allows the user to
|
||||
-- change this behavior.
|
||||
|
||||
if Unreserve_All_Interrupts = 0 then
|
||||
|
||||
@ -5,11 +5,11 @@
|
||||
-- S Y S T E M --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- (GNU/Linux/x86 Version) --
|
||||
-- (GNU-Linux/x86 Version) --
|
||||
-- --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- 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 --
|
||||
@ -60,16 +60,16 @@ pragma Pure (System);
|
||||
Max_Mantissa : constant := 63;
|
||||
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
|
||||
|
||||
Tick : constant := Standard'Tick;
|
||||
Tick : constant := 1.0;
|
||||
|
||||
-- Storage-related Declarations
|
||||
|
||||
type Address is private;
|
||||
Null_Address : constant Address;
|
||||
|
||||
Storage_Unit : constant := Standard'Storage_Unit;
|
||||
Word_Size : constant := Standard'Word_Size;
|
||||
Memory_Size : constant := 2 ** Standard'Address_Size;
|
||||
Storage_Unit : constant := 8;
|
||||
Word_Size : constant := 32;
|
||||
Memory_Size : constant := 2 ** 32;
|
||||
|
||||
-- Address comparison
|
||||
|
||||
@ -88,32 +88,18 @@ pragma Pure (System);
|
||||
-- Other System-Dependent Declarations
|
||||
|
||||
type Bit_Order is (High_Order_First, Low_Order_First);
|
||||
Default_Bit_Order : constant Bit_Order :=
|
||||
Bit_Order'Val (Standard'Default_Bit_Order);
|
||||
Default_Bit_Order : constant Bit_Order := Low_Order_First;
|
||||
|
||||
-- Priority-related Declarations (RM D.1)
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
Max_Interrupt_Priority : constant Positive := 31;
|
||||
|
||||
subtype Any_Priority is Integer
|
||||
range 0 .. Standard'Max_Interrupt_Priority;
|
||||
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;
|
||||
|
||||
subtype Priority is Any_Priority
|
||||
range 0 .. Standard'Max_Priority;
|
||||
|
||||
-- Functional notation is needed in the following to avoid visibility
|
||||
-- problems when this package is compiled through rtsfind in the middle
|
||||
-- of another compilation.
|
||||
|
||||
subtype Interrupt_Priority is Any_Priority
|
||||
range
|
||||
Standard."+" (Standard'Max_Priority, 1) ..
|
||||
Standard'Max_Interrupt_Priority;
|
||||
|
||||
Default_Priority : constant Priority :=
|
||||
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
|
||||
Default_Priority : constant Priority := 15;
|
||||
|
||||
private
|
||||
|
||||
@ -131,8 +117,11 @@ private
|
||||
-- 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;
|
||||
Denorm : constant Boolean := True;
|
||||
Fractional_Fixed_Ops : constant Boolean := False;
|
||||
Frontend_Layout : constant Boolean := False;
|
||||
Functions_Return_By_DSP : constant Boolean := False;
|
||||
Long_Shifts_Inlined : constant Boolean := True;
|
||||
@ -146,5 +135,5 @@ private
|
||||
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;
|
||||
Front_End_ZCX_Support : constant Boolean := False;
|
||||
end System;
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1998-2001 Free Software Foundation --
|
||||
-- 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -43,61 +42,18 @@ package System.VxWorks is
|
||||
|
||||
package IC renames Interfaces.C;
|
||||
|
||||
-- Define enough of a Wind Task Control Block in order to
|
||||
-- obtain the inherited priority. When porting this to
|
||||
-- different versions of VxWorks (this is based on 5.3[.1]),
|
||||
-- be sure to look at the definition for WIND_TCB located
|
||||
-- in $WIND_BASE/target/h/taskLib.h
|
||||
|
||||
type Wind_Fill_1 is array (0 .. 16#3F#) of IC.unsigned_char;
|
||||
type Wind_Fill_2 is array (16#48# .. 16#107#) of IC.unsigned_char;
|
||||
|
||||
type Wind_TCB is record
|
||||
Fill_1 : Wind_Fill_1; -- 0x00 - 0x3f
|
||||
Priority : IC.int; -- 0x40 - 0x43, current (inherited) priority
|
||||
Normal_Priority : IC.int; -- 0x44 - 0x47, base priority
|
||||
Fill_2 : Wind_Fill_2; -- 0x48 - 0x107
|
||||
spare1 : Address; -- 0x108 - 0x10b
|
||||
spare2 : Address; -- 0x10c - 0x10f
|
||||
spare3 : Address; -- 0x110 - 0x113
|
||||
spare4 : Address; -- 0x114 - 0x117
|
||||
end record;
|
||||
type Wind_TCB_Ptr is access Wind_TCB;
|
||||
|
||||
-- Floating point context record. MIPS version
|
||||
-- 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;
|
||||
fpx : Fpx_Array;
|
||||
fpcsr : IC.int;
|
||||
end record;
|
||||
pragma Convention (C, FP_CONTEXT);
|
||||
|
||||
-- Number of entries in hardware interrupt vector table. Value of
|
||||
-- 0 disables hardware interrupt handling until it can be tested
|
||||
Num_HW_Interrupts : constant := 0;
|
||||
|
||||
-- VxWorks 5.3 and 5.4 version
|
||||
type TASK_DESC is record
|
||||
td_id : IC.int; -- task id
|
||||
td_name : Address; -- name of task
|
||||
td_priority : IC.int; -- task priority
|
||||
td_status : IC.int; -- task status
|
||||
td_options : IC.int; -- task option bits (see below)
|
||||
td_entry : Address; -- original entry point of task
|
||||
td_sp : Address; -- saved stack pointer
|
||||
td_pStackBase : Address; -- the bottom of the stack
|
||||
td_pStackLimit : Address; -- the effective end of the stack
|
||||
td_pStackEnd : Address; -- the actual end of the stack
|
||||
td_stackSize : IC.int; -- size of stack in bytes
|
||||
td_stackCurrent : IC.int; -- current stack usage in bytes
|
||||
td_stackHigh : IC.int; -- maximum stack usage in bytes
|
||||
td_stackMargin : IC.int; -- current stack margin in bytes
|
||||
td_errorStatus : IC.int; -- most recent task error status
|
||||
td_delay : IC.int; -- delay/timeout ticks
|
||||
end record;
|
||||
pragma Convention (C, TASK_DESC);
|
||||
Num_HW_Interrupts : constant := 256;
|
||||
-- Number of entries in hardware interrupt vector table.
|
||||
|
||||
end System.VxWorks;
|
||||
|
||||
@ -2,14 +2,13 @@
|
||||
-- --
|
||||
-- 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 --
|
||||
-- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.5 $ --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-1998 Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -39,6 +38,10 @@
|
||||
|
||||
package body System.Interrupt_Management.Operations is
|
||||
|
||||
-- Turn off warnings since many unused formals
|
||||
|
||||
pragma Warnings (Off);
|
||||
|
||||
----------------------------
|
||||
-- Thread_Block_Interrupt --
|
||||
----------------------------
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -29,25 +29,21 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is the no tasking version
|
||||
|
||||
with Interfaces.C;
|
||||
package System.OS_Interface is
|
||||
pragma Preelaborate;
|
||||
|
||||
subtype int is Interfaces.C.int;
|
||||
|
||||
-------------
|
||||
-- Signals --
|
||||
-------------
|
||||
|
||||
Max_Interrupt : constant := 2;
|
||||
type Signal is new int range 0 .. Max_Interrupt;
|
||||
type Signal is new Integer range 0 .. Max_Interrupt;
|
||||
|
||||
type sigset_t is new Integer;
|
||||
type Thread_Id is new Integer;
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.33 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001, Florida State University --
|
||||
-- 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -59,9 +58,9 @@ package body System.Task_Primitives.Operations is
|
||||
use System.Parameters;
|
||||
use System.OS_Primitives;
|
||||
|
||||
-------------------
|
||||
-- Stack_Guard --
|
||||
-------------------
|
||||
-----------------
|
||||
-- Stack_Guard --
|
||||
-----------------
|
||||
|
||||
procedure Stack_Guard (T : ST.Task_ID; On : Boolean) is
|
||||
begin
|
||||
@ -92,8 +91,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Initialize_Lock
|
||||
(Prio : System.Any_Priority;
|
||||
L : access Lock)
|
||||
is
|
||||
L : access Lock) is
|
||||
begin
|
||||
null;
|
||||
end Initialize_Lock;
|
||||
@ -126,7 +124,9 @@ package body System.Task_Primitives.Operations is
|
||||
Ceiling_Violation := False;
|
||||
end Write_Lock;
|
||||
|
||||
procedure Write_Lock (L : access RTS_Lock) is
|
||||
procedure Write_Lock
|
||||
(L : access RTS_Lock; Global_Lock : Boolean := False)
|
||||
is
|
||||
begin
|
||||
null;
|
||||
end Write_Lock;
|
||||
@ -154,7 +154,7 @@ package body System.Task_Primitives.Operations is
|
||||
null;
|
||||
end Unlock;
|
||||
|
||||
procedure Unlock (L : access RTS_Lock) is
|
||||
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
|
||||
begin
|
||||
null;
|
||||
end Unlock;
|
||||
@ -164,12 +164,11 @@ package body System.Task_Primitives.Operations is
|
||||
null;
|
||||
end Unlock;
|
||||
|
||||
-------------
|
||||
-- Sleep --
|
||||
-------------
|
||||
-----------
|
||||
-- Sleep --
|
||||
-----------
|
||||
|
||||
procedure Sleep (Self_ID : Task_ID;
|
||||
Reason : System.Tasking.Task_States) is
|
||||
procedure Sleep (Self_ID : Task_ID; Reason : System.Tasking.Task_States) is
|
||||
begin
|
||||
null;
|
||||
end Sleep;
|
||||
@ -195,25 +194,11 @@ package body System.Task_Primitives.Operations is
|
||||
-----------------
|
||||
|
||||
procedure Timed_Delay
|
||||
(Self_ID : Task_ID;
|
||||
Time : Duration;
|
||||
Mode : ST.Delay_Modes)
|
||||
is
|
||||
Rel_Time : Duration;
|
||||
|
||||
procedure sleep (How_Long : Natural);
|
||||
pragma Import (C, sleep, "sleep");
|
||||
|
||||
(Self_ID : Task_ID;
|
||||
Time : Duration;
|
||||
Mode : ST.Delay_Modes) is
|
||||
begin
|
||||
if Mode = Relative then
|
||||
Rel_Time := Time;
|
||||
else
|
||||
Rel_Time := Time - Monotonic_Clock;
|
||||
end if;
|
||||
|
||||
if Rel_Time > 0.0 then
|
||||
sleep (Natural (Rel_Time));
|
||||
end if;
|
||||
null;
|
||||
end Timed_Delay;
|
||||
|
||||
---------------------
|
||||
@ -248,8 +233,8 @@ package body System.Task_Primitives.Operations is
|
||||
------------------
|
||||
|
||||
procedure Set_Priority
|
||||
(T : Task_ID;
|
||||
Prio : System.Any_Priority;
|
||||
(T : Task_ID;
|
||||
Prio : System.Any_Priority;
|
||||
Loss_Of_Inheritance : Boolean := False) is
|
||||
begin
|
||||
null;
|
||||
@ -300,8 +285,7 @@ package body System.Task_Primitives.Operations is
|
||||
Wrapper : System.Address;
|
||||
Stack_Size : System.Parameters.Size_Type;
|
||||
Priority : System.Any_Priority;
|
||||
Succeeded : out Boolean)
|
||||
is
|
||||
Succeeded : out Boolean) is
|
||||
begin
|
||||
Succeeded := False;
|
||||
end Create_Task;
|
||||
@ -372,23 +356,23 @@ package body System.Task_Primitives.Operations is
|
||||
return null;
|
||||
end Environment_Task;
|
||||
|
||||
-------------------------
|
||||
-- Lock_All_Tasks_List --
|
||||
-------------------------
|
||||
--------------
|
||||
-- Lock_RTS --
|
||||
--------------
|
||||
|
||||
procedure Lock_All_Tasks_List is
|
||||
procedure Lock_RTS is
|
||||
begin
|
||||
null;
|
||||
end Lock_All_Tasks_List;
|
||||
end Lock_RTS;
|
||||
|
||||
---------------------------
|
||||
-- Unlock_All_Tasks_List --
|
||||
---------------------------
|
||||
----------------
|
||||
-- Unlock_RTS --
|
||||
----------------
|
||||
|
||||
procedure Unlock_All_Tasks_List is
|
||||
procedure Unlock_RTS is
|
||||
begin
|
||||
null;
|
||||
end Unlock_All_Tasks_List;
|
||||
end Unlock_RTS;
|
||||
|
||||
------------------
|
||||
-- Suspend_Task --
|
||||
@ -424,7 +408,6 @@ package body System.Task_Primitives.Operations is
|
||||
No_Tasking : Boolean;
|
||||
|
||||
begin
|
||||
|
||||
-- Can't raise an exception because target independent packages try to
|
||||
-- do an Abort_Defer, which gets a memory fault.
|
||||
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.5 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2000 Florida State University --
|
||||
-- Copyright (C) 1991-2001 Florida State University --
|
||||
-- --
|
||||
-- GNARL is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
@ -43,6 +43,8 @@ with Ada.Exceptions;
|
||||
|
||||
package body System.Interrupts is
|
||||
|
||||
pragma Warnings (Off); -- kill warnings on unreferenced formals
|
||||
|
||||
use System.Tasking;
|
||||
|
||||
-----------------------
|
||||
|
||||
@ -7,9 +7,9 @@
|
||||
-- B o d y --
|
||||
-- (Version for x86) --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
|
||||
-- Copyright (C) 1999-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- --
|
||||
@ -41,6 +41,7 @@
|
||||
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
|
||||
|
||||
@ -54,11 +55,7 @@ package body System.Machine_State_Operations is
|
||||
|
||||
function To_Address is new Unchecked_Conversion (Uns32, Address);
|
||||
|
||||
function To_Uns32 is new Unchecked_Conversion (Integer, Uns32);
|
||||
function To_Uns32 is new Unchecked_Conversion (Address, Uns32);
|
||||
|
||||
type Uns32_Ptr is access all Uns32;
|
||||
function To_Uns32_Ptr is new Unchecked_Conversion (Address, Uns32_Ptr);
|
||||
function To_Uns32_Ptr is new Unchecked_Conversion (Uns32, Uns32_Ptr);
|
||||
|
||||
-- Note: the type Uns32 has an alignment of 4. However, in some cases
|
||||
@ -178,9 +175,12 @@ package body System.Machine_State_Operations is
|
||||
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
|
||||
@ -329,14 +329,11 @@ package body System.Machine_State_Operations is
|
||||
----------------------------
|
||||
|
||||
function Allocate_Machine_State return Machine_State is
|
||||
|
||||
use System.Storage_Elements;
|
||||
|
||||
function Gnat_Malloc (Size : Storage_Offset) return Machine_State;
|
||||
pragma Import (C, Gnat_Malloc, "__gnat_malloc");
|
||||
|
||||
begin
|
||||
return Gnat_Malloc (MState'Max_Size_In_Storage_Elements);
|
||||
return Machine_State
|
||||
(Memory.Alloc (MState'Max_Size_In_Storage_Elements));
|
||||
end Allocate_Machine_State;
|
||||
|
||||
--------------------
|
||||
@ -445,11 +442,8 @@ package body System.Machine_State_Operations is
|
||||
------------------------
|
||||
|
||||
procedure Free_Machine_State (M : in out Machine_State) is
|
||||
procedure Gnat_Free (M : in Machine_State);
|
||||
pragma Import (C, Gnat_Free, "__gnat_free");
|
||||
|
||||
begin
|
||||
Gnat_Free (M);
|
||||
Memory.Free (Address (M));
|
||||
M := Machine_State (Null_Address);
|
||||
end Free_Machine_State;
|
||||
|
||||
@ -584,7 +578,11 @@ package body System.Machine_State_Operations is
|
||||
|
||||
procedure Set_Signal_Machine_State
|
||||
(M : Machine_State;
|
||||
Context : System.Address) is
|
||||
Context : System.Address)
|
||||
is
|
||||
pragma Warnings (Off, M);
|
||||
pragma Warnings (Off, Context);
|
||||
|
||||
begin
|
||||
null;
|
||||
end Set_Signal_Machine_State;
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.3 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Florida State University --
|
||||
-- Copyright (C) 1991-2002 Florida State University --
|
||||
-- --
|
||||
-- GNARL is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
@ -40,7 +40,6 @@ 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.Strings;
|
||||
with Interfaces.OS2Lib.Errors;
|
||||
with Interfaces.OS2Lib.Synchronization;
|
||||
|
||||
@ -51,33 +50,6 @@ package body System.OS_Interface is
|
||||
use Interfaces.OS2Lib.Synchronization;
|
||||
use Interfaces.OS2Lib.Errors;
|
||||
|
||||
------------------
|
||||
-- Timer (spec) --
|
||||
------------------
|
||||
|
||||
-- Although the OS uses a 32-bit integer representing milliseconds
|
||||
-- as timer value that doesn't work for us since 32 bits are not
|
||||
-- enough for absolute timing. Also it is useful to use better
|
||||
-- intermediate precision when adding/subtracting timing intervals.
|
||||
-- So we use the standard Ada Duration type which is implemented using
|
||||
-- microseconds.
|
||||
|
||||
-- Shouldn't the timer be moved to a separate package ???
|
||||
|
||||
type Timer is record
|
||||
Handle : aliased HTIMER := NULLHANDLE;
|
||||
Event : aliased HEV := NULLHANDLE;
|
||||
end record;
|
||||
|
||||
procedure Initialize (T : out Timer);
|
||||
procedure Finalize (T : in out Timer);
|
||||
procedure Wait (T : in out Timer);
|
||||
procedure Reset (T : in out Timer);
|
||||
|
||||
procedure Set_Timer_For (T : in out Timer; Period : in Duration);
|
||||
procedure Set_Timer_At (T : in out Timer; Time : in Duration);
|
||||
-- Add a hook to locate the Epoch, for use with Calendar????
|
||||
|
||||
-----------
|
||||
-- Yield --
|
||||
-----------
|
||||
@ -147,110 +119,4 @@ package body System.OS_Interface is
|
||||
return Tick_Count * Tick_Duration;
|
||||
end Clock;
|
||||
|
||||
----------------------
|
||||
-- Initialize Timer --
|
||||
----------------------
|
||||
|
||||
procedure Initialize (T : out Timer) is
|
||||
begin
|
||||
pragma Assert
|
||||
(T.Handle = NULLHANDLE, "GNULLI---Timer already initialized");
|
||||
|
||||
Must_Not_Fail (DosCreateEventSem
|
||||
(pszName => Interfaces.C.Strings.Null_Ptr,
|
||||
f_phev => T.Event'Unchecked_Access,
|
||||
flAttr => DC_SEM_SHARED,
|
||||
fState => False32));
|
||||
end Initialize;
|
||||
|
||||
-------------------
|
||||
-- Set_Timer_For --
|
||||
-------------------
|
||||
|
||||
procedure Set_Timer_For
|
||||
(T : in out Timer;
|
||||
Period : in Duration)
|
||||
is
|
||||
Rel_Time : Duration_In_Millisec :=
|
||||
Duration_In_Millisec (Period * 1_000.0);
|
||||
|
||||
begin
|
||||
pragma Assert
|
||||
(T.Event /= NULLHANDLE, "GNULLI---Timer not initialized");
|
||||
pragma Assert
|
||||
(T.Handle = NULLHANDLE, "GNULLI---Timer already in use");
|
||||
|
||||
Must_Not_Fail (DosAsyncTimer
|
||||
(msec => ULONG (Rel_Time),
|
||||
F_hsem => HSEM (T.Event),
|
||||
F_phtimer => T.Handle'Unchecked_Access));
|
||||
end Set_Timer_For;
|
||||
|
||||
------------------
|
||||
-- Set_Timer_At --
|
||||
------------------
|
||||
|
||||
-- Note that the timer is started in a critical section to prevent the
|
||||
-- race condition when absolute time is converted to time relative to
|
||||
-- current time. T.Event will be posted when the Time has passed
|
||||
|
||||
procedure Set_Timer_At
|
||||
(T : in out Timer;
|
||||
Time : in Duration)
|
||||
is
|
||||
Relative_Time : Duration;
|
||||
|
||||
begin
|
||||
Must_Not_Fail (DosEnterCritSec);
|
||||
|
||||
begin
|
||||
Relative_Time := Time - Clock;
|
||||
if Relative_Time > 0.0 then
|
||||
Set_Timer_For (T, Period => Time - Clock);
|
||||
else
|
||||
Sem_Must_Not_Fail (DosPostEventSem (T.Event));
|
||||
end if;
|
||||
end;
|
||||
|
||||
Must_Not_Fail (DosExitCritSec);
|
||||
end Set_Timer_At;
|
||||
|
||||
----------
|
||||
-- Wait --
|
||||
----------
|
||||
|
||||
procedure Wait (T : in out Timer) is
|
||||
begin
|
||||
Sem_Must_Not_Fail (DosWaitEventSem (T.Event, SEM_INDEFINITE_WAIT));
|
||||
T.Handle := NULLHANDLE;
|
||||
end Wait;
|
||||
|
||||
-----------
|
||||
-- Reset --
|
||||
-----------
|
||||
|
||||
procedure Reset (T : in out Timer) is
|
||||
Dummy_Count : aliased ULONG;
|
||||
|
||||
begin
|
||||
if T.Handle /= NULLHANDLE then
|
||||
Must_Not_Fail (DosStopTimer (T.Handle));
|
||||
T.Handle := NULLHANDLE;
|
||||
end if;
|
||||
|
||||
Sem_Must_Not_Fail
|
||||
(DosResetEventSem (T.Event, Dummy_Count'Unchecked_Access));
|
||||
end Reset;
|
||||
|
||||
--------------
|
||||
-- Finalize --
|
||||
--------------
|
||||
|
||||
procedure Finalize (T : in out Timer) is
|
||||
begin
|
||||
Reset (T);
|
||||
Must_Not_Fail (DosCloseEventSem (T.Event));
|
||||
T.Event := NULLHANDLE;
|
||||
end Finalize;
|
||||
|
||||
end System.OS_Interface;
|
||||
|
||||
@ -7,9 +7,9 @@
|
||||
-- S p e c --
|
||||
-- (OS/2 Version) --
|
||||
-- --
|
||||
-- $Revision: 1.9 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- 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 --
|
||||
@ -60,16 +60,16 @@ pragma Pure (System);
|
||||
Max_Mantissa : constant := 63;
|
||||
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
|
||||
|
||||
Tick : constant := Standard'Tick;
|
||||
Tick : constant := 1.0;
|
||||
|
||||
-- Storage-related Declarations
|
||||
|
||||
type Address is private;
|
||||
Null_Address : constant Address;
|
||||
|
||||
Storage_Unit : constant := Standard'Storage_Unit;
|
||||
Word_Size : constant := Standard'Word_Size;
|
||||
Memory_Size : constant := 2 ** Standard'Address_Size;
|
||||
Storage_Unit : constant := 8;
|
||||
Word_Size : constant := 32;
|
||||
Memory_Size : constant := 2 ** 32;
|
||||
|
||||
-- Address comparison
|
||||
|
||||
@ -88,32 +88,18 @@ pragma Pure (System);
|
||||
-- Other System-Dependent Declarations
|
||||
|
||||
type Bit_Order is (High_Order_First, Low_Order_First);
|
||||
Default_Bit_Order : constant Bit_Order :=
|
||||
Bit_Order'Val (Standard'Default_Bit_Order);
|
||||
Default_Bit_Order : constant Bit_Order := Low_Order_First;
|
||||
|
||||
-- Priority-related Declarations (RM D.1)
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
Max_Interrupt_Priority : constant Positive := 31;
|
||||
|
||||
subtype Any_Priority is Integer
|
||||
range 0 .. Standard'Max_Interrupt_Priority;
|
||||
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;
|
||||
|
||||
subtype Priority is Any_Priority
|
||||
range 0 .. Standard'Max_Priority;
|
||||
|
||||
-- Functional notation is needed in the following to avoid visibility
|
||||
-- problems when this package is compiled through rtsfind in the middle
|
||||
-- of another compilation.
|
||||
|
||||
subtype Interrupt_Priority is Any_Priority
|
||||
range
|
||||
Standard."+" (Standard'Max_Priority, 1) ..
|
||||
Standard'Max_Interrupt_Priority;
|
||||
|
||||
Default_Priority : constant Priority :=
|
||||
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
|
||||
Default_Priority : constant Priority := 15;
|
||||
|
||||
private
|
||||
|
||||
@ -131,8 +117,11 @@ private
|
||||
-- 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;
|
||||
Denorm : constant Boolean := True;
|
||||
Fractional_Fixed_Ops : constant Boolean := False;
|
||||
Frontend_Layout : constant Boolean := False;
|
||||
Functions_Return_By_DSP : constant Boolean := False;
|
||||
Long_Shifts_Inlined : constant Boolean := True;
|
||||
@ -146,6 +135,6 @@ private
|
||||
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;
|
||||
Front_End_ZCX_Support : constant Boolean := True;
|
||||
|
||||
end System;
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Florida State University --
|
||||
-- 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -91,29 +90,29 @@ package body System.Task_Primitives.Operations is
|
||||
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 --
|
||||
----------------------
|
||||
---------------------
|
||||
-- Local Constants --
|
||||
---------------------
|
||||
|
||||
Max_Locks_Per_Task : constant := 100;
|
||||
Suppress_Owner_Check : constant Boolean := False;
|
||||
|
||||
------------------
|
||||
-- Local Types --
|
||||
------------------
|
||||
-----------------
|
||||
-- Local Types --
|
||||
-----------------
|
||||
|
||||
type Microseconds is new IC.long;
|
||||
subtype Lock_Range is Integer range 0 .. Max_Locks_Per_Task;
|
||||
|
||||
------------------
|
||||
-- Local Data --
|
||||
------------------
|
||||
-----------------
|
||||
-- Local Data --
|
||||
-----------------
|
||||
|
||||
-- The OS/2 DosAllocThreadLocalMemory API is used to allocate our TCB_Ptr.
|
||||
|
||||
@ -138,8 +137,10 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
type PPTLD is access all Access_Thread_Local_Data;
|
||||
|
||||
All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
|
||||
-- See comments on locking rules in System.Tasking (spec).
|
||||
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.
|
||||
@ -192,15 +193,18 @@ package body System.Task_Primitives.Operations is
|
||||
-- handler or to change the execution context of the thread.
|
||||
-- So asynchonous transfer of control is not supported.
|
||||
|
||||
-------------------
|
||||
-- Stack_Guard --
|
||||
-------------------
|
||||
-----------------
|
||||
-- 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;
|
||||
@ -220,7 +224,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
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.
|
||||
|
||||
@ -252,6 +255,8 @@ package body System.Task_Primitives.Operations is
|
||||
end Initialize_Lock;
|
||||
|
||||
procedure Initialize_Lock (L : access RTS_Lock; Level : Lock_Level) is
|
||||
pragma Warnings (Off, Level);
|
||||
|
||||
begin
|
||||
if DosCreateMutexSem
|
||||
(ICS.Null_Ptr, L.Mutex'Unchecked_Access, 0, False32) /= NO_ERROR
|
||||
@ -312,44 +317,52 @@ package body System.Task_Primitives.Operations is
|
||||
L.Owner_ID := Self_ID.all'Address;
|
||||
end Write_Lock;
|
||||
|
||||
procedure Write_Lock (L : access RTS_Lock) is
|
||||
Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID;
|
||||
Old_Priority : constant Any_Priority :=
|
||||
Self_ID.Common.LL.Current_Priority;
|
||||
procedure Write_Lock
|
||||
(L : access RTS_Lock; Global_Lock : Boolean := False)
|
||||
is
|
||||
Self_ID : Task_ID;
|
||||
Old_Priority : Any_Priority;
|
||||
|
||||
begin
|
||||
-- Increase priority before getting the lock
|
||||
-- to prevent priority inversion
|
||||
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;
|
||||
|
||||
Thread_Local_Data_Ptr.Lock_Prio_Level :=
|
||||
Thread_Local_Data_Ptr.Lock_Prio_Level + 1;
|
||||
-- Increase priority before getting the lock
|
||||
-- to prevent priority inversion
|
||||
|
||||
if L.Priority > Old_Priority then
|
||||
Set_Temporary_Priority (Self_ID, L.Priority);
|
||||
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;
|
||||
|
||||
-- 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 (T : Task_ID) is
|
||||
begin
|
||||
-- Request the lock and then update the lock owner data
|
||||
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;
|
||||
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;
|
||||
procedure Read_Lock
|
||||
(L : access Lock; Ceiling_Violation : out Boolean) renames Write_Lock;
|
||||
|
||||
------------
|
||||
-- Unlock --
|
||||
@ -383,53 +396,63 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
end Unlock;
|
||||
|
||||
procedure Unlock (L : access RTS_Lock) is
|
||||
Self_ID : constant Task_ID := Thread_Local_Data_Ptr.Self_ID;
|
||||
Old_Priority : constant Any_Priority := L.Owner_Priority;
|
||||
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
|
||||
Self_ID : Task_ID;
|
||||
Old_Priority : Any_Priority;
|
||||
|
||||
begin
|
||||
-- Check that this task holds the lock
|
||||
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);
|
||||
pragma Assert (Suppress_Owner_Check
|
||||
or else L.Owner_ID = Self_ID.all'Address);
|
||||
|
||||
-- Upate the owner data
|
||||
-- Upate the owner data
|
||||
|
||||
L.Owner_ID := Null_Address;
|
||||
L.Owner_ID := Null_Address;
|
||||
|
||||
-- Do the actual unlocking. No more references
|
||||
-- to owner data of L after this point.
|
||||
-- Do the actual unlocking. No more references
|
||||
-- to owner data of L after this point.
|
||||
|
||||
Must_Not_Fail (DosReleaseMutexSem (L.Mutex));
|
||||
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;
|
||||
-- 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);
|
||||
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
|
||||
-- Check the owner data
|
||||
if not Single_Lock then
|
||||
-- Check the owner data
|
||||
|
||||
pragma Assert (Suppress_Owner_Check
|
||||
or else T.Common.LL.L.Owner_ID = Null_Address);
|
||||
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.
|
||||
-- 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));
|
||||
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
|
||||
procedure Sleep
|
||||
(Self_ID : Task_ID;
|
||||
Reason : System.Tasking.Task_States)
|
||||
is
|
||||
pragma Warnings (Off, Reason);
|
||||
|
||||
Count : aliased ULONG; -- Used to store dummy result
|
||||
|
||||
begin
|
||||
@ -437,7 +460,12 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
Sem_Must_Not_Fail
|
||||
(DosResetEventSem (Self_ID.Common.LL.CV, Count'Unchecked_Access));
|
||||
Unlock (Self_ID);
|
||||
|
||||
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.
|
||||
@ -447,7 +475,11 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- Since L was previously accquired, lock operation should not fail.
|
||||
|
||||
Write_Lock (Self_ID);
|
||||
if Single_Lock then
|
||||
Lock_RTS;
|
||||
else
|
||||
Write_Lock (Self_ID);
|
||||
end if;
|
||||
end Sleep;
|
||||
|
||||
-----------------
|
||||
@ -472,6 +504,8 @@ package body System.Task_Primitives.Operations is
|
||||
Timedout : out Boolean;
|
||||
Yielded : out Boolean)
|
||||
is
|
||||
pragma Warnings (Off, Reason);
|
||||
|
||||
Check_Time : constant Duration := OSP.Monotonic_Clock;
|
||||
Rel_Time : Duration;
|
||||
Abs_Time : Duration;
|
||||
@ -485,7 +519,12 @@ package body System.Task_Primitives.Operations is
|
||||
Sem_Must_Not_Fail
|
||||
(DosResetEventSem (Self_ID.Common.LL.CV,
|
||||
Count'Unchecked_Access));
|
||||
Unlock (Self_ID);
|
||||
|
||||
if Single_Lock then
|
||||
Unlock_RTS;
|
||||
else
|
||||
Unlock (Self_ID);
|
||||
end if;
|
||||
|
||||
Timedout := True;
|
||||
Yielded := False;
|
||||
@ -529,7 +568,11 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- Ensure post-condition
|
||||
|
||||
Write_Lock (Self_ID);
|
||||
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));
|
||||
@ -550,7 +593,7 @@ package body System.Task_Primitives.Operations is
|
||||
Abs_Time : Duration;
|
||||
Timedout : Boolean := True;
|
||||
Time_Out : ULONG;
|
||||
Result : APIRET;
|
||||
Result : APIRET;
|
||||
Count : aliased ULONG; -- Used to store dummy result
|
||||
|
||||
begin
|
||||
@ -559,14 +602,24 @@ package body System.Task_Primitives.Operations is
|
||||
-- check for pending abort and priority change below! :(
|
||||
|
||||
SSL.Abort_Defer.all;
|
||||
Write_Lock (Self_ID);
|
||||
|
||||
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));
|
||||
Unlock (Self_ID);
|
||||
|
||||
if Single_Lock then
|
||||
Unlock_RTS;
|
||||
else
|
||||
Unlock (Self_ID);
|
||||
end if;
|
||||
|
||||
if Mode = Relative then
|
||||
Rel_Time := Time;
|
||||
@ -578,6 +631,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
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;
|
||||
@ -599,15 +653,22 @@ package body System.Task_Primitives.Operations is
|
||||
Timedout := Result = ERROR_TIMEOUT;
|
||||
end if;
|
||||
|
||||
-- Ensure post-condition
|
||||
|
||||
Write_Lock (Self_ID);
|
||||
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;
|
||||
|
||||
Unlock (Self_ID);
|
||||
if Single_Lock then
|
||||
Unlock_RTS;
|
||||
else
|
||||
Unlock (Self_ID);
|
||||
end if;
|
||||
|
||||
System.OS_Interface.Yield;
|
||||
SSL.Abort_Undefer.all;
|
||||
end Timed_Delay;
|
||||
@ -617,6 +678,7 @@ package body System.Task_Primitives.Operations is
|
||||
------------
|
||||
|
||||
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
|
||||
pragma Warnings (Off, Reason);
|
||||
begin
|
||||
Sem_Must_Not_Fail (DosPostEventSem (T.Common.LL.CV));
|
||||
end Wakeup;
|
||||
@ -659,7 +721,6 @@ package body System.Task_Primitives.Operations is
|
||||
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.
|
||||
@ -679,9 +740,12 @@ package body System.Task_Primitives.Operations is
|
||||
------------------
|
||||
|
||||
procedure Set_Priority
|
||||
(T : Task_ID;
|
||||
Prio : System.Any_Priority;
|
||||
Loss_Of_Inheritance : Boolean := False) is
|
||||
(T : Task_ID;
|
||||
Prio : System.Any_Priority;
|
||||
Loss_Of_Inheritance : Boolean := False)
|
||||
is
|
||||
pragma Warnings (Off, Loss_Of_Inheritance);
|
||||
|
||||
begin
|
||||
T.Common.Current_Priority := Prio;
|
||||
Set_Temporary_Priority (T, Prio);
|
||||
@ -702,21 +766,22 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
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_All_Tasks_List;
|
||||
for I in Known_Tasks'Range loop
|
||||
if Known_Tasks (I) = null then
|
||||
Known_Tasks (I) := Self_ID;
|
||||
Self_ID.Known_Tasks_Index := I;
|
||||
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_All_Tasks_List;
|
||||
|
||||
Unlock_RTS;
|
||||
|
||||
-- For OS/2, we can set Self_ID.Common.LL.Thread in
|
||||
-- Create_Task, since the thread is created suspended.
|
||||
@ -725,7 +790,6 @@ package body System.Task_Primitives.Operations is
|
||||
-- has been initialized.
|
||||
|
||||
-- .... Do we need to do anything with signals for OS/2 ???
|
||||
null;
|
||||
end Enter_Task;
|
||||
|
||||
--------------
|
||||
@ -746,8 +810,12 @@ package body System.Task_Primitives.Operations is
|
||||
if DosCreateEventSem (ICS.Null_Ptr,
|
||||
Self_ID.Common.LL.CV'Unchecked_Access, 0, True32) = NO_ERROR
|
||||
then
|
||||
if DosCreateMutexSem (ICS.Null_Ptr,
|
||||
Self_ID.Common.LL.L.Mutex'Unchecked_Access, 0, False32) /= NO_ERROR
|
||||
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));
|
||||
@ -755,8 +823,6 @@ package body System.Task_Primitives.Operations is
|
||||
Succeeded := True;
|
||||
end if;
|
||||
|
||||
pragma Assert (Self_ID.Common.LL.L.Mutex /= 0);
|
||||
|
||||
-- We now want to do the equivalent of:
|
||||
|
||||
-- Initialize_Lock
|
||||
@ -774,7 +840,7 @@ package body System.Task_Primitives.Operations is
|
||||
Succeeded := False;
|
||||
end if;
|
||||
|
||||
-- Note: at one time we had anb exception handler here, whose code
|
||||
-- Note: at one time we had an exception handler here, whose code
|
||||
-- was as follows:
|
||||
|
||||
-- exception
|
||||
@ -789,7 +855,6 @@ package body System.Task_Primitives.Operations is
|
||||
-- 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;
|
||||
|
||||
-----------------
|
||||
@ -889,12 +954,18 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Free is new
|
||||
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
|
||||
|
||||
begin
|
||||
Must_Not_Fail (DosCloseEventSem (T.Common.LL.CV));
|
||||
Finalize_Lock (T.Common.LL.L'Unchecked_Access);
|
||||
|
||||
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;
|
||||
|
||||
@ -916,6 +987,8 @@ package body System.Task_Primitives.Operations is
|
||||
----------------
|
||||
|
||||
procedure Abort_Task (T : Task_ID) is
|
||||
pragma Warnings (Off, T);
|
||||
|
||||
begin
|
||||
null;
|
||||
|
||||
@ -956,23 +1029,23 @@ package body System.Task_Primitives.Operations is
|
||||
return Environment_Task_ID;
|
||||
end Environment_Task;
|
||||
|
||||
-------------------------
|
||||
-- Lock_All_Tasks_List --
|
||||
-------------------------
|
||||
--------------
|
||||
-- Lock_RTS --
|
||||
--------------
|
||||
|
||||
procedure Lock_All_Tasks_List is
|
||||
procedure Lock_RTS is
|
||||
begin
|
||||
Write_Lock (All_Tasks_L'Access);
|
||||
end Lock_All_Tasks_List;
|
||||
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Lock_RTS;
|
||||
|
||||
---------------------------
|
||||
-- Unlock_All_Tasks_List --
|
||||
---------------------------
|
||||
----------------
|
||||
-- Unlock_RTS --
|
||||
----------------
|
||||
|
||||
procedure Unlock_All_Tasks_List is
|
||||
procedure Unlock_RTS is
|
||||
begin
|
||||
Unlock (All_Tasks_L'Access);
|
||||
end Unlock_All_Tasks_List;
|
||||
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Unlock_RTS;
|
||||
|
||||
------------------
|
||||
-- Suspend_Task --
|
||||
@ -1010,11 +1083,10 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Initialize (Environment_Task : Task_ID) is
|
||||
Succeeded : Boolean;
|
||||
|
||||
begin
|
||||
Environment_Task_ID := Environment_Task;
|
||||
|
||||
Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
|
||||
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
|
||||
-- Initialize the lock used to synchronize chain of all ATCBs.
|
||||
|
||||
-- Set ID of environment task.
|
||||
@ -1047,7 +1119,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- Insert here any other special
|
||||
-- initialization needed for the environment task.
|
||||
|
||||
end Initialize;
|
||||
|
||||
begin
|
||||
@ -1062,5 +1133,4 @@ begin
|
||||
|
||||
Thread_Local_Data_Ptr.Self_ID := null;
|
||||
Thread_Local_Data_Ptr.Lock_Prio_Level := 0;
|
||||
|
||||
end System.Task_Primitives.Operations;
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.5 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-1999 Florida State University --
|
||||
-- Copyright (C) 1991-2001 Florida State University --
|
||||
-- --
|
||||
-- GNARL is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
@ -69,13 +69,12 @@ package System.Task_Primitives is
|
||||
|
||||
-- private
|
||||
|
||||
type Lock is
|
||||
record
|
||||
Mutex : aliased Interfaces.OS2Lib.Synchronization.HMTX;
|
||||
Priority : Integer;
|
||||
Owner_Priority : Integer;
|
||||
Owner_ID : Address;
|
||||
end record;
|
||||
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;
|
||||
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.1 $ --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1998 - 2001 Free Software Foundation --
|
||||
-- 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- --
|
||||
@ -34,8 +34,7 @@
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is the PPC VxWorks 5.x version of this package. A different version
|
||||
-- is used for VxWorks 6.0
|
||||
-- This is the PPC VxWorks version of this package.
|
||||
|
||||
with Interfaces.C;
|
||||
|
||||
@ -44,60 +43,18 @@ package System.VxWorks is
|
||||
|
||||
package IC renames Interfaces.C;
|
||||
|
||||
-- Define enough of a Wind Task Control Block in order to
|
||||
-- obtain the inherited priority. When porting this to
|
||||
-- different versions of VxWorks (this is based on 5.3[.1]),
|
||||
-- be sure to look at the definition for WIND_TCB located
|
||||
-- in $WIND_BASE/target/h/taskLib.h
|
||||
|
||||
type Wind_Fill_1 is array (0 .. 16#3F#) of IC.unsigned_char;
|
||||
type Wind_Fill_2 is array (16#48# .. 16#107#) of IC.unsigned_char;
|
||||
|
||||
type Wind_TCB is record
|
||||
Fill_1 : Wind_Fill_1; -- 0x00 - 0x3f
|
||||
Priority : IC.int; -- 0x40 - 0x43, current (inherited) priority
|
||||
Normal_Priority : IC.int; -- 0x44 - 0x47, base priority
|
||||
Fill_2 : Wind_Fill_2; -- 0x48 - 0x107
|
||||
spare1 : Address; -- 0x108 - 0x10b
|
||||
spare2 : Address; -- 0x10c - 0x10f
|
||||
spare3 : Address; -- 0x110 - 0x113
|
||||
spare4 : Address; -- 0x114 - 0x117
|
||||
end record;
|
||||
type Wind_TCB_Ptr is access Wind_TCB;
|
||||
|
||||
-- Floating point context record. PPC version
|
||||
-- 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;
|
||||
fpr : Fpr_Array;
|
||||
fpcsr : IC.int;
|
||||
pad : IC.int;
|
||||
pad : IC.int;
|
||||
end record;
|
||||
pragma Convention (C, FP_CONTEXT);
|
||||
|
||||
Num_HW_Interrupts : constant := 256;
|
||||
|
||||
-- VxWorks 5.3 and 5.4 version
|
||||
type TASK_DESC is record
|
||||
td_id : IC.int; -- task id
|
||||
td_name : Address; -- name of task
|
||||
td_priority : IC.int; -- task priority
|
||||
td_status : IC.int; -- task status
|
||||
td_options : IC.int; -- task option bits (see below)
|
||||
td_entry : Address; -- original entry point of task
|
||||
td_sp : Address; -- saved stack pointer
|
||||
td_pStackBase : Address; -- the bottom of the stack
|
||||
td_pStackLimit : Address; -- the effective end of the stack
|
||||
td_pStackEnd : Address; -- the actual end of the stack
|
||||
td_stackSize : IC.int; -- size of stack in bytes
|
||||
td_stackCurrent : IC.int; -- current stack usage in bytes
|
||||
td_stackHigh : IC.int; -- maximum stack usage in bytes
|
||||
td_stackMargin : IC.int; -- current stack margin in bytes
|
||||
td_errorStatus : IC.int; -- most recent task error status
|
||||
td_delay : IC.int; -- delay/timeout ticks
|
||||
end record;
|
||||
pragma Convention (C, TASK_DESC);
|
||||
|
||||
end System.VxWorks;
|
||||
|
||||
@ -1,136 +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 --
|
||||
-- --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 2, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
||||
-- for more details. You should have received a copy of the GNU General --
|
||||
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is the RT-GNU/Linux 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 := 10;
|
||||
-- The secondary stack ratio is a constant between 0 and 100 which
|
||||
-- determines the percentage of the allocated task stack that is
|
||||
-- used by the secondary stack (the rest being the primary stack).
|
||||
-- The special value of minus one indicates that the secondary
|
||||
-- stack is to be allocated from the heap instead.
|
||||
|
||||
Sec_Stack_Ratio : constant Ratio := Dynamic;
|
||||
-- This constant defines the handling of the secondary stack
|
||||
|
||||
Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic;
|
||||
-- Convenient Boolean for testing for dynamic secondary stack
|
||||
|
||||
function Default_Stack_Size return Size_Type;
|
||||
-- Default task stack size used if none is specified
|
||||
|
||||
function Minimum_Stack_Size return Size_Type;
|
||||
-- Minimum task stack size permitted
|
||||
|
||||
function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
|
||||
-- Given the storage size stored in the TCB, return the Storage_Size
|
||||
-- value required by the RM for the Storage_Size attribute. The
|
||||
-- required adjustment is as follows:
|
||||
--
|
||||
-- when Size = Unspecified_Size, return Default_Stack_Size
|
||||
-- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
|
||||
-- otherwise return given Size
|
||||
|
||||
Stack_Grows_Down : constant Boolean := 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)
|
||||
|
||||
end System.Parameters;
|
||||
@ -8,7 +8,7 @@
|
||||
-- --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001, Florida State University --
|
||||
-- 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -185,8 +184,10 @@ package body System.Task_Primitives.Operations is
|
||||
-- In the current implementation, this is the task assigned permanently
|
||||
-- as the regular GNU/Linux kernel.
|
||||
|
||||
All_Tasks_L : aliased RTS_Lock;
|
||||
-- See comments on locking rules in System.Tasking (spec).
|
||||
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
|
||||
|
||||
-- The followings are internal configuration constants needed.
|
||||
Next_Serial_Number : Task_Serial_Number := 100;
|
||||
@ -722,12 +723,10 @@ package body System.Task_Primitives.Operations is
|
||||
-- Write_Lock --
|
||||
----------------
|
||||
|
||||
procedure Write_Lock
|
||||
(L : access Lock;
|
||||
Ceiling_Violation : out Boolean)
|
||||
is
|
||||
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
|
||||
Prio : constant System.Any_Priority :=
|
||||
Current_Task.Common.LL.Active_Priority;
|
||||
|
||||
begin
|
||||
pragma Debug (Printk ("procedure Write_Lock called" & LF));
|
||||
|
||||
@ -756,7 +755,9 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
end Write_Lock;
|
||||
|
||||
procedure Write_Lock (L : access RTS_Lock) is
|
||||
procedure Write_Lock
|
||||
(L : access RTS_Lock; Global_Lock : Boolean := False)
|
||||
is
|
||||
Prio : constant System.Any_Priority :=
|
||||
Current_Task.Common.LL.Active_Priority;
|
||||
|
||||
@ -872,7 +873,7 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
end Unlock;
|
||||
|
||||
procedure Unlock (L : access RTS_Lock) is
|
||||
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
|
||||
Flags : Integer;
|
||||
begin
|
||||
pragma Debug (Printk ("procedure Unlock (RTS_Lock) called" & LF));
|
||||
@ -1607,27 +1608,23 @@ package body System.Task_Primitives.Operations is
|
||||
return Environment_Task_ID;
|
||||
end Environment_Task;
|
||||
|
||||
-------------------------
|
||||
-- Lock_All_Tasks_List --
|
||||
-------------------------
|
||||
--------------
|
||||
-- Lock_RTS --
|
||||
--------------
|
||||
|
||||
procedure Lock_All_Tasks_List is
|
||||
procedure Lock_RTS is
|
||||
begin
|
||||
pragma Debug (Printk ("procedure Lock_All_Tasks_List called" & LF));
|
||||
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Lock_RTS;
|
||||
|
||||
Write_Lock (All_Tasks_L'Access);
|
||||
end Lock_All_Tasks_List;
|
||||
----------------
|
||||
-- Unlock_RTS --
|
||||
----------------
|
||||
|
||||
---------------------------
|
||||
-- Unlock_All_Tasks_List --
|
||||
---------------------------
|
||||
|
||||
procedure Unlock_All_Tasks_List is
|
||||
procedure Unlock_RTS is
|
||||
begin
|
||||
pragma Debug (Printk ("procedure Unlock_All_Tasks_List called" & LF));
|
||||
|
||||
Unlock (All_Tasks_L'Access);
|
||||
end Unlock_All_Tasks_List;
|
||||
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Unlock_RTS;
|
||||
|
||||
-----------------
|
||||
-- Stack_Guard --
|
||||
@ -1770,7 +1767,10 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- Initialize the lock used to synchronize chain of all ATCBs.
|
||||
|
||||
Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
|
||||
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
|
||||
|
||||
-- Single_Lock isn't supported in this configuration
|
||||
pragma Assert (not Single_Lock);
|
||||
|
||||
Enter_Task (Environment_Task);
|
||||
end Initialize;
|
||||
|
||||
@ -1,112 +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 --
|
||||
-- --
|
||||
-- $Revision: 1.1 $ --
|
||||
-- --
|
||||
-- Copyright (C) 1998 - 2001 Free Software Foundation --
|
||||
-- --
|
||||
-- GNARL is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 2, or (at your option) any later ver- --
|
||||
-- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
||||
-- for more details. You should have received a copy of the GNU General --
|
||||
-- Public License distributed with GNARL; see file COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNARL was developed by the GNARL team at Florida State University. It is --
|
||||
-- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
|
||||
-- State University (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is the PPC VxWorks 6.0 version of this package. A different version
|
||||
-- is used for VxWorks 5.x
|
||||
|
||||
with Interfaces.C;
|
||||
|
||||
package System.VxWorks is
|
||||
pragma Preelaborate (System.VxWorks);
|
||||
|
||||
package IC renames Interfaces.C;
|
||||
|
||||
-- Define enough of a Wind Task Control Block in order to
|
||||
-- obtain the inherited priority. When porting this to
|
||||
-- different versions of VxWorks (this is based on 6.0),
|
||||
-- be sure to look at the definition for WIND_TCB located
|
||||
-- in $WIND_BASE/target/h/taskLib.h
|
||||
|
||||
type Wind_Fill_1 is array (0 .. 16#6B#) of IC.unsigned_char;
|
||||
type Wind_Fill_2 is array (16#74# .. 16#10F#) of IC.unsigned_char;
|
||||
|
||||
type Wind_TCB is record
|
||||
Fill_1 : Wind_Fill_1; -- 0x00 - 0x6b
|
||||
Priority : IC.int; -- 0x6c - 0x6f, current (inherited) priority
|
||||
Normal_Priority : IC.int; -- 0x70 - 0x73, base priority
|
||||
Fill_2 : Wind_Fill_2; -- 0x74 - 0x10f
|
||||
spare1 : Address; -- 0x110 - 0x113
|
||||
spare2 : Address; -- 0x114 - 0x117
|
||||
spare3 : Address; -- 0x118 - 0x11b
|
||||
spare4 : Address; -- 0x11c - 0x11f
|
||||
end record;
|
||||
type Wind_TCB_Ptr is access Wind_TCB;
|
||||
|
||||
-- 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;
|
||||
|
||||
-- For VxWorks 6.0
|
||||
type TASK_DESC is record
|
||||
td_id : IC.int; -- task id
|
||||
td_priority : IC.int; -- task priority
|
||||
td_status : IC.int; -- task status
|
||||
td_options : IC.int; -- task option bits (see below)
|
||||
td_entry : Address; -- original entry point of task
|
||||
td_sp : Address; -- saved stack pointer
|
||||
td_pStackBase : Address; -- the bottom of the stack
|
||||
td_pStackLimit : Address; -- the effective end of the stack
|
||||
td_pStackEnd : Address; -- the actual end of the stack
|
||||
td_stackSize : IC.int; -- size of stack in bytes
|
||||
td_stackCurrent : IC.int; -- current stack usage in bytes
|
||||
td_stackHigh : IC.int; -- maximum stack usage in bytes
|
||||
td_stackMargin : IC.int; -- current stack margin in bytes
|
||||
|
||||
td_PExcStkBase : Address; -- exception stack base
|
||||
td_PExcStkPtr : Address; -- exception stack pointer
|
||||
td_ExcStkHigh : IC.int; -- exception stack max usage
|
||||
td_ExcStkMgn : IC.int; -- exception stack margin
|
||||
|
||||
td_errorStatus : IC.int; -- most recent task error status
|
||||
td_delay : IC.int; -- delay/timeout ticks
|
||||
|
||||
td_PdId : Address; -- task's home protection domain
|
||||
td_name : Address; -- name of task
|
||||
end record;
|
||||
|
||||
pragma Convention (C, TASK_DESC);
|
||||
|
||||
end System.VxWorks;
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.21 $ --
|
||||
-- $Revision$ --
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -173,13 +173,6 @@ begin
|
||||
act.sa_mask := mask;
|
||||
|
||||
Keep_Unmasked (Abort_Task_Interrupt) := True;
|
||||
Keep_Unmasked (SIGXCPU) := True;
|
||||
Keep_Unmasked (SIGFPE) := True;
|
||||
Result :=
|
||||
sigaction
|
||||
(Signal (SIGFPE), act'Unchecked_Access,
|
||||
old_act'Unchecked_Access);
|
||||
pragma Assert (Result = 0);
|
||||
|
||||
-- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but in the
|
||||
-- same time, disable the ability of handling this signal
|
||||
@ -191,17 +184,13 @@ begin
|
||||
Keep_Unmasked (SIGINT) := True;
|
||||
end if;
|
||||
|
||||
for J in
|
||||
Exception_Interrupts'First + 1 .. Exception_Interrupts'Last loop
|
||||
for J in Exception_Interrupts'Range loop
|
||||
Keep_Unmasked (Exception_Interrupts (J)) := True;
|
||||
|
||||
if Unreserve_All_Interrupts = 0 then
|
||||
Result :=
|
||||
sigaction
|
||||
(Signal (Exception_Interrupts (J)), act'Unchecked_Access,
|
||||
old_act'Unchecked_Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
Result :=
|
||||
sigaction
|
||||
(Signal (Exception_Interrupts (J)), act'Unchecked_Access,
|
||||
old_act'Unchecked_Access);
|
||||
pragma Assert (Result = 0);
|
||||
end loop;
|
||||
|
||||
for J in Unmasked'Range loop
|
||||
|
||||
@ -1,159 +0,0 @@
|
||||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT COMPILER COMPONENTS --
|
||||
-- --
|
||||
-- SYSTEM.MACHINE_STATE_OPERATIONS --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- (Version using the GCC stack unwinding mechanism) --
|
||||
-- --
|
||||
-- $Revision: 1.3 $
|
||||
-- --
|
||||
-- Copyright (C) 1999-2001 Ada Core Technologies, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 2, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
||||
-- for more details. You should have received a copy of the GNU General --
|
||||
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This version of System.Machine_State_Operations is for use on
|
||||
-- systems where the GCC stack unwinding mechanism is supported.
|
||||
-- It is currently only used on Solaris
|
||||
|
||||
package body System.Machine_State_Operations is
|
||||
|
||||
use System.Storage_Elements;
|
||||
use System.Exceptions;
|
||||
|
||||
----------------------------
|
||||
-- Allocate_Machine_State --
|
||||
----------------------------
|
||||
|
||||
function Allocate_Machine_State return Machine_State is
|
||||
function Machine_State_Length return Storage_Offset;
|
||||
pragma Import (C, Machine_State_Length, "__gnat_machine_state_length");
|
||||
|
||||
function Gnat_Malloc (Size : Storage_Offset) return Machine_State;
|
||||
pragma Import (C, Gnat_Malloc, "__gnat_malloc");
|
||||
|
||||
begin
|
||||
return Gnat_Malloc (Machine_State_Length);
|
||||
end Allocate_Machine_State;
|
||||
|
||||
-------------------
|
||||
-- Enter_Handler --
|
||||
-------------------
|
||||
|
||||
procedure Enter_Handler (M : Machine_State; Handler : Handler_Loc) is
|
||||
procedure c_enter_handler (m : Machine_State; handler : Handler_Loc);
|
||||
pragma Import (C, c_enter_handler, "__gnat_enter_handler");
|
||||
|
||||
begin
|
||||
c_enter_handler (M, Handler);
|
||||
end Enter_Handler;
|
||||
|
||||
----------------
|
||||
-- Fetch_Code --
|
||||
----------------
|
||||
|
||||
function Fetch_Code (Loc : Code_Loc) return Code_Loc is
|
||||
begin
|
||||
return Loc;
|
||||
end Fetch_Code;
|
||||
|
||||
------------------------
|
||||
-- Free_Machine_State --
|
||||
------------------------
|
||||
|
||||
procedure Free_Machine_State (M : in out Machine_State) is
|
||||
procedure Gnat_Free (M : in Machine_State);
|
||||
pragma Import (C, Gnat_Free, "__gnat_free");
|
||||
|
||||
begin
|
||||
Gnat_Free (M);
|
||||
M := Machine_State (Null_Address);
|
||||
end Free_Machine_State;
|
||||
|
||||
------------------
|
||||
-- Get_Code_Loc --
|
||||
------------------
|
||||
|
||||
function Get_Code_Loc (M : Machine_State) return Code_Loc is
|
||||
function c_get_code_loc (m : Machine_State) return Code_Loc;
|
||||
pragma Import (C, c_get_code_loc, "__gnat_get_code_loc");
|
||||
|
||||
begin
|
||||
return c_get_code_loc (M);
|
||||
end Get_Code_Loc;
|
||||
|
||||
--------------------------
|
||||
-- Machine_State_Length --
|
||||
--------------------------
|
||||
|
||||
function Machine_State_Length return Storage_Offset is
|
||||
|
||||
function c_machine_state_length return Storage_Offset;
|
||||
pragma Import (C, c_machine_state_length, "__gnat_machine_state_length");
|
||||
|
||||
begin
|
||||
return c_machine_state_length;
|
||||
end Machine_State_Length;
|
||||
|
||||
---------------
|
||||
-- Pop_Frame --
|
||||
---------------
|
||||
|
||||
procedure Pop_Frame
|
||||
(M : Machine_State;
|
||||
Info : Subprogram_Info_Type)
|
||||
is
|
||||
procedure c_pop_frame (m : Machine_State);
|
||||
pragma Import (C, c_pop_frame, "__gnat_pop_frame");
|
||||
|
||||
begin
|
||||
c_pop_frame (M);
|
||||
end Pop_Frame;
|
||||
|
||||
-----------------------
|
||||
-- Set_Machine_State --
|
||||
-----------------------
|
||||
|
||||
procedure Set_Machine_State (M : Machine_State) is
|
||||
procedure c_set_machine_state (m : Machine_State);
|
||||
pragma Import (C, c_set_machine_state, "__gnat_set_machine_state");
|
||||
|
||||
begin
|
||||
c_set_machine_state (M);
|
||||
Pop_Frame (M, System.Null_Address);
|
||||
end Set_Machine_State;
|
||||
|
||||
------------------------------
|
||||
-- Set_Signal_Machine_State --
|
||||
------------------------------
|
||||
|
||||
procedure Set_Signal_Machine_State
|
||||
(M : Machine_State;
|
||||
Context : System.Address) is
|
||||
begin
|
||||
null;
|
||||
end Set_Signal_Machine_State;
|
||||
|
||||
end System.Machine_State_Operations;
|
||||
@ -7,9 +7,9 @@
|
||||
-- S p e c --
|
||||
-- (SUN Solaris Version) --
|
||||
-- --
|
||||
-- $Revision: 1.14 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- 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 --
|
||||
@ -60,16 +60,16 @@ pragma Pure (System);
|
||||
Max_Mantissa : constant := 63;
|
||||
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
|
||||
|
||||
Tick : constant := Standard'Tick;
|
||||
Tick : constant := 1.0;
|
||||
|
||||
-- Storage-related Declarations
|
||||
|
||||
type Address is private;
|
||||
Null_Address : constant Address;
|
||||
|
||||
Storage_Unit : constant := Standard'Storage_Unit;
|
||||
Word_Size : constant := Standard'Word_Size;
|
||||
Memory_Size : constant := 2 ** Standard'Address_Size;
|
||||
Storage_Unit : constant := 8;
|
||||
Word_Size : constant := 32;
|
||||
Memory_Size : constant := 2 ** 32;
|
||||
|
||||
-- Address comparison
|
||||
|
||||
@ -92,27 +92,14 @@ pragma Pure (System);
|
||||
|
||||
-- Priority-related Declarations (RM D.1)
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
Max_Interrupt_Priority : constant Positive := 31;
|
||||
|
||||
subtype Any_Priority is Integer
|
||||
range 0 .. Standard'Max_Interrupt_Priority;
|
||||
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;
|
||||
|
||||
subtype Priority is Any_Priority
|
||||
range 0 .. Standard'Max_Priority;
|
||||
|
||||
-- Functional notation is needed in the following to avoid visibility
|
||||
-- problems when this package is compiled through rtsfind in the middle
|
||||
-- of another compilation.
|
||||
|
||||
subtype Interrupt_Priority is Any_Priority
|
||||
range
|
||||
Standard."+" (Standard'Max_Priority, 1) ..
|
||||
Standard'Max_Interrupt_Priority;
|
||||
|
||||
Default_Priority : constant Priority :=
|
||||
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
|
||||
Default_Priority : constant Priority := 15;
|
||||
|
||||
private
|
||||
|
||||
@ -130,8 +117,11 @@ private
|
||||
-- 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;
|
||||
Denorm : constant Boolean := True;
|
||||
Fractional_Fixed_Ops : constant Boolean := False;
|
||||
Frontend_Layout : constant Boolean := False;
|
||||
Functions_Return_By_DSP : constant Boolean := False;
|
||||
Long_Shifts_Inlined : constant Boolean := True;
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001, Florida State University --
|
||||
-- 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -108,11 +107,6 @@ package body System.Task_Primitives.Operations is
|
||||
-- Local Data --
|
||||
------------------
|
||||
|
||||
ATCB_Magic_Code : constant := 16#ADAADAAD#;
|
||||
-- This is used to allow us to catch attempts to call Self
|
||||
-- from outside an Ada task, with high probability.
|
||||
-- For an Ada task, Task_Wrapper.Magic_Number = ATCB_Magic_Code.
|
||||
|
||||
-- The following are logically constants, but need to be initialized
|
||||
-- at run time.
|
||||
|
||||
@ -128,8 +122,10 @@ package body System.Task_Primitives.Operations is
|
||||
-- Key used to find the Ada Task_ID associated with a thread,
|
||||
-- at least for C threads unknown to the Ada run-time system.
|
||||
|
||||
All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
|
||||
-- See comments on locking rules in System.Tasking (spec).
|
||||
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
|
||||
@ -140,9 +136,6 @@ package body System.Task_Primitives.Operations is
|
||||
-- Priority Support --
|
||||
------------------------
|
||||
|
||||
Dynamic_Priority_Support : constant Boolean := True;
|
||||
-- controls whether we poll for pending priority changes during sleeps
|
||||
|
||||
Priority_Ceiling_Emulation : constant Boolean := True;
|
||||
-- controls whether we emulate priority ceiling locking
|
||||
|
||||
@ -194,7 +187,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
Fake_ATCB_List : Fake_ATCB_Ptr;
|
||||
-- A linear linked list.
|
||||
-- The list is protected by All_Tasks_L;
|
||||
-- The list is protected by Single_RTS_Lock;
|
||||
-- Nodes are added to this list from the front.
|
||||
-- Once a node is added to this list, it is never removed.
|
||||
|
||||
@ -245,13 +238,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
|
||||
|
||||
type Ptr is access Task_ID;
|
||||
function To_Ptr is new Unchecked_Conversion (Interfaces.C.unsigned, Ptr);
|
||||
function To_Ptr is new Unchecked_Conversion (System.Address, Ptr);
|
||||
|
||||
type Iptr is access Interfaces.C.unsigned;
|
||||
function To_Iptr is new Unchecked_Conversion (Interfaces.C.unsigned, Iptr);
|
||||
|
||||
function Thread_Body_Access is
|
||||
new Unchecked_Conversion (System.Address, Thread_Body);
|
||||
|
||||
@ -259,6 +245,9 @@ package body System.Task_Primitives.Operations is
|
||||
-- Allocate and Initialize a new ATCB. This code can safely be called from
|
||||
-- a foreign thread, as it doesn't access implicitly or explicitly
|
||||
-- "self" before having initialized the new ATCB.
|
||||
pragma Warnings (Off, New_Fake_ATCB);
|
||||
-- Disable warning on this function, since the Solaris x86 version does
|
||||
-- not use it.
|
||||
|
||||
------------
|
||||
-- Checks --
|
||||
@ -309,10 +298,10 @@ package body System.Task_Primitives.Operations is
|
||||
-- This section is ticklish.
|
||||
-- We dare not call anything that might require an ATCB, until
|
||||
-- we have the new ATCB in place.
|
||||
-- Note: we don't use "Write_Lock (All_Tasks_L'Access);" because
|
||||
-- we don't yet have an ATCB, and so can't pass the safety check.
|
||||
-- Note: we don't use Lock_RTS because we don't yet have an ATCB, and
|
||||
-- so can't pass the safety check.
|
||||
|
||||
Result := mutex_lock (All_Tasks_L.L'Access);
|
||||
Result := mutex_lock (Single_RTS_Lock.L'Access);
|
||||
Q := null;
|
||||
P := Fake_ATCB_List;
|
||||
|
||||
@ -415,10 +404,10 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Result := mutex_unlock (All_Tasks_L.L'Access);
|
||||
Result := mutex_unlock (Single_RTS_Lock.L'Access);
|
||||
|
||||
-- We cannot use "Unlock (All_Tasks_L'Access);" because
|
||||
-- we did not use Write_Lock, and so would not pass the checks.
|
||||
-- We cannot use Unlock_RTS because we did not use Write_Lock, and so
|
||||
-- would not pass the checks.
|
||||
|
||||
return Self_ID;
|
||||
end New_Fake_ATCB;
|
||||
@ -550,7 +539,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- Note: mutexes and cond_variables needed per-task basis are
|
||||
-- initialized in Initialize_TCB and the Storage_Error is
|
||||
-- handled. Other mutexes (such as All_Tasks_L, Memory_Lock...)
|
||||
-- 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.
|
||||
@ -658,24 +647,28 @@ package body System.Task_Primitives.Operations is
|
||||
pragma Assert (Record_Lock (Lock_Ptr (L)));
|
||||
end Write_Lock;
|
||||
|
||||
procedure Write_Lock (L : access RTS_Lock) is
|
||||
procedure Write_Lock
|
||||
(L : access RTS_Lock; Global_Lock : Boolean := False)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
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))));
|
||||
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
|
||||
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)));
|
||||
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;
|
||||
|
||||
---------------
|
||||
@ -693,7 +686,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Unlock (L : access Lock) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
pragma Assert (Check_Unlock (Lock_Ptr (L)));
|
||||
|
||||
@ -715,22 +707,24 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
end Unlock;
|
||||
|
||||
procedure Unlock (L : access RTS_Lock) is
|
||||
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
pragma Assert (Check_Unlock (To_Lock_Ptr (RTS_Lock_Ptr (L))));
|
||||
Result := mutex_unlock (L.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
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
|
||||
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);
|
||||
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
|
||||
@ -899,16 +893,17 @@ package body System.Task_Primitives.Operations is
|
||||
-- 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_All_Tasks_List;
|
||||
Lock_RTS;
|
||||
|
||||
for I in Known_Tasks'Range loop
|
||||
if Known_Tasks (I) = null then
|
||||
Known_Tasks (I) := Self_ID;
|
||||
Self_ID.Known_Tasks_Index := I;
|
||||
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_All_Tasks_List;
|
||||
|
||||
Unlock_RTS;
|
||||
end Enter_Task;
|
||||
|
||||
--------------
|
||||
@ -920,13 +915,12 @@ package body System.Task_Primitives.Operations is
|
||||
return new Ada_Task_Control_Block (Entry_Num);
|
||||
end New_ATCB;
|
||||
|
||||
----------------------
|
||||
-- Initialize_TCB --
|
||||
----------------------
|
||||
--------------------
|
||||
-- Initialize_TCB --
|
||||
--------------------
|
||||
|
||||
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
Result : Interfaces.C.int := 0;
|
||||
begin
|
||||
-- Give the task a unique serial number.
|
||||
|
||||
@ -935,25 +929,28 @@ package body System.Task_Primitives.Operations is
|
||||
pragma Assert (Next_Serial_Number /= 0);
|
||||
|
||||
Self_ID.Common.LL.Thread := To_thread_t (-1);
|
||||
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);
|
||||
|
||||
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
|
||||
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);
|
||||
Succeeded := False;
|
||||
else
|
||||
Succeeded := True;
|
||||
end if;
|
||||
|
||||
else
|
||||
Succeeded := False;
|
||||
end if;
|
||||
end Initialize_TCB;
|
||||
@ -1042,8 +1039,12 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
begin
|
||||
T.Common.LL.Thread := To_thread_t (0);
|
||||
Result := mutex_destroy (T.Common.LL.L.L'Access);
|
||||
pragma Assert (Result = 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);
|
||||
|
||||
@ -1083,16 +1084,15 @@ package body System.Task_Primitives.Operations is
|
||||
pragma Assert (Result = 0);
|
||||
end Abort_Task;
|
||||
|
||||
-------------
|
||||
-- Sleep --
|
||||
-------------
|
||||
-----------
|
||||
-- Sleep --
|
||||
-----------
|
||||
|
||||
procedure Sleep
|
||||
(Self_ID : Task_ID;
|
||||
Reason : Task_States)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
pragma Assert (Check_Sleep (Reason));
|
||||
|
||||
@ -1104,11 +1104,17 @@ package body System.Task_Primitives.Operations is
|
||||
Set_Priority (Self_ID, Self_ID.Common.Base_Priority);
|
||||
end if;
|
||||
|
||||
Result := cond_wait
|
||||
(Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L.L'Access);
|
||||
pragma Assert (Result = 0 or else Result = EINTR);
|
||||
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
|
||||
@ -1121,7 +1127,7 @@ package body System.Task_Primitives.Operations is
|
||||
-- ???
|
||||
-- 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
|
||||
-- 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
|
||||
@ -1157,9 +1163,9 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- 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
|
||||
-- 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,
|
||||
-- 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.
|
||||
@ -1177,29 +1183,16 @@ package body System.Task_Primitives.Operations is
|
||||
-- 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
|
||||
-- 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
|
||||
-- changes. We can quietly handle priority changes inside the
|
||||
-- procedure, since there is no entry-queue reordering involved.
|
||||
|
||||
-----------------
|
||||
-- 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.
|
||||
|
||||
-- Yielded should be False unles we know for certain that the
|
||||
-- operation resulted in the calling task going to the end of
|
||||
-- the dispatching queue for its priority.
|
||||
|
||||
-- ???
|
||||
-- This version presumes the worst, so Yielded is always False.
|
||||
-- On some targets, if cond_timedwait always yields, we could
|
||||
-- set Yielded to True just before the cond_timedwait call.
|
||||
|
||||
procedure Timed_Sleep
|
||||
(Self_ID : Task_ID;
|
||||
Time : Duration;
|
||||
@ -1232,8 +1225,15 @@ package body System.Task_Primitives.Operations is
|
||||
or else (Dynamic_Priority_Support and then
|
||||
Self_ID.Pending_Priority_Change);
|
||||
|
||||
Result := cond_timedwait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L.L'Access, Request'Access);
|
||||
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;
|
||||
|
||||
@ -1255,10 +1255,6 @@ package body System.Task_Primitives.Operations is
|
||||
-- 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;
|
||||
@ -1268,6 +1264,7 @@ package body System.Task_Primitives.Operations is
|
||||
Abs_Time : Duration;
|
||||
Request : aliased timespec;
|
||||
Result : Interfaces.C.int;
|
||||
Yielded : Boolean := False;
|
||||
|
||||
begin
|
||||
-- Only the little window between deferring abort and
|
||||
@ -1275,6 +1272,11 @@ package body System.Task_Primitives.Operations is
|
||||
-- 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
|
||||
@ -1299,8 +1301,15 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
|
||||
|
||||
Result := cond_timedwait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L.L'Access, Request'Access);
|
||||
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;
|
||||
|
||||
@ -1316,7 +1325,15 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
|
||||
Unlock (Self_ID);
|
||||
thr_yield;
|
||||
|
||||
if Single_Lock then
|
||||
Unlock_RTS;
|
||||
end if;
|
||||
|
||||
if not Yielded then
|
||||
thr_yield;
|
||||
end if;
|
||||
|
||||
SSL.Abort_Undefer.all;
|
||||
end Timed_Delay;
|
||||
|
||||
@ -1329,7 +1346,6 @@ package body System.Task_Primitives.Operations is
|
||||
Reason : Task_States)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
pragma Assert (Check_Wakeup (T, Reason));
|
||||
Result := cond_signal (T.Common.LL.CV'Access);
|
||||
@ -1400,6 +1416,10 @@ package body System.Task_Primitives.Operations is
|
||||
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;
|
||||
@ -1435,6 +1455,10 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
L.Owner := To_Owner_ID (Self_ID);
|
||||
|
||||
if Single_Lock then
|
||||
return True;
|
||||
end if;
|
||||
|
||||
-- Check that TCB lock order rules are satisfied
|
||||
|
||||
P := Self_ID.Common.LL.Locks;
|
||||
@ -1463,6 +1487,10 @@ package body System.Task_Primitives.Operations is
|
||||
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 /=
|
||||
@ -1501,6 +1529,10 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
L.Owner := To_Owner_ID (Self_ID);
|
||||
|
||||
if Single_Lock then
|
||||
return True;
|
||||
end if;
|
||||
|
||||
-- Check that TCB lock order rules are satisfied
|
||||
|
||||
P := Self_ID.Common.LL.Locks;
|
||||
@ -1566,7 +1598,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
if Unlock_Count - Check_Count > 1000 then
|
||||
Check_Count := Unlock_Count;
|
||||
Old_Owner := To_Task_ID (All_Tasks_L.Owner);
|
||||
Old_Owner := To_Task_ID (Single_RTS_Lock.Owner);
|
||||
end if;
|
||||
|
||||
-- Check that caller is abort-deferred
|
||||
@ -1596,7 +1628,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
function Check_Finalize_Lock (L : Lock_Ptr) return Boolean is
|
||||
Self_ID : Task_ID := Self;
|
||||
|
||||
begin
|
||||
-- Check that caller is abort-deferred
|
||||
|
||||
@ -1664,23 +1695,23 @@ package body System.Task_Primitives.Operations is
|
||||
return Environment_Task_ID;
|
||||
end Environment_Task;
|
||||
|
||||
-------------------------
|
||||
-- Lock_All_Tasks_List --
|
||||
-------------------------
|
||||
--------------
|
||||
-- Lock_RTS --
|
||||
--------------
|
||||
|
||||
procedure Lock_All_Tasks_List is
|
||||
procedure Lock_RTS is
|
||||
begin
|
||||
Write_Lock (All_Tasks_L'Access);
|
||||
end Lock_All_Tasks_List;
|
||||
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Lock_RTS;
|
||||
|
||||
---------------------------
|
||||
-- Unlock_All_Tasks_List --
|
||||
---------------------------
|
||||
----------------
|
||||
-- Unlock_RTS --
|
||||
----------------
|
||||
|
||||
procedure Unlock_All_Tasks_List is
|
||||
procedure Unlock_RTS is
|
||||
begin
|
||||
Unlock (All_Tasks_L'Access);
|
||||
end Unlock_All_Tasks_List;
|
||||
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Unlock_RTS;
|
||||
|
||||
------------------
|
||||
-- Suspend_Task --
|
||||
@ -1717,10 +1748,10 @@ package body System.Task_Primitives.Operations is
|
||||
----------------
|
||||
|
||||
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;
|
||||
act : aliased struct_sigaction;
|
||||
old_act : aliased struct_sigaction;
|
||||
Tmp_Set : aliased sigset_t;
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
procedure Configure_Processors;
|
||||
-- Processors configuration
|
||||
@ -1740,71 +1771,51 @@ package body System.Task_Primitives.Operations is
|
||||
-- _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 #
|
||||
|
||||
Proc_Acc : constant GNAT.OS_Lib.String_Access :=
|
||||
GNAT.OS_Lib.Getenv ("GNAT_PROCESSOR");
|
||||
begin
|
||||
if Proc_Acc.all'Length /= 0 then
|
||||
|
||||
-- Environment variable is defined
|
||||
|
||||
declare
|
||||
Proc : aliased processorid_t; -- User processor #
|
||||
Last_Proc : processorid_t; -- Last processor #
|
||||
Last_Proc := Num_Procs - 1;
|
||||
|
||||
begin
|
||||
Last_Proc := Num_Procs - 1;
|
||||
|
||||
if Last_Proc = -1 then
|
||||
|
||||
-- Unable to read system variable _SC_NPROCESSORS_CONF
|
||||
-- Ignore environment variable GNAT_PROCESSOR
|
||||
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
|
||||
Proc := processorid_t'Value (Proc_Acc.all);
|
||||
-- Use user processor
|
||||
|
||||
if Proc < -2 or Proc > Last_Proc then
|
||||
raise Constraint_Error;
|
||||
|
||||
elsif Proc = -2 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;
|
||||
Result := processor_bind (P_PID, P_MYID, Proc, null);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
|
||||
exception
|
||||
when Constraint_Error =>
|
||||
|
||||
-- Illegal environment variable GNAT_PROCESSOR - ignored
|
||||
|
||||
null;
|
||||
end;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
exception
|
||||
when Constraint_Error =>
|
||||
-- Illegal environment variable GNAT_PROCESSOR - ignored
|
||||
null;
|
||||
end Configure_Processors;
|
||||
|
||||
-- Start of processing for Initialize
|
||||
@ -1821,7 +1832,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- Initialize the lock used to synchronize chain of all ATCBs.
|
||||
|
||||
Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
|
||||
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
|
||||
|
||||
Enter_Task (Environment_Task);
|
||||
|
||||
@ -1861,7 +1872,6 @@ package body System.Task_Primitives.Operations is
|
||||
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
|
||||
@ -1892,12 +1902,11 @@ begin
|
||||
|
||||
if Dispatching_Policy = 'F' then
|
||||
declare
|
||||
Result : Interfaces.C.long;
|
||||
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
|
||||
@ -1918,7 +1927,7 @@ begin
|
||||
|
||||
Class_Info.pc_clname (1) := 'R';
|
||||
Class_Info.pc_clname (2) := 'T';
|
||||
Class_Info.pc_clname (3) := ASCII.Nul;
|
||||
Class_Info.pc_clname (3) := ASCII.NUL;
|
||||
|
||||
Result := priocntl (PC_VERSION, P_LWPID, P_MYID, PC_GETCID,
|
||||
Class_Info'Address);
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.2 $ --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-1998, Florida State University --
|
||||
-- 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- --
|
||||
@ -139,6 +139,17 @@ separate (System.Task_Primitives.Operations)
|
||||
-- been elaborated.
|
||||
|
||||
function Self return Task_ID is
|
||||
ATCB_Magic_Code : constant := 16#ADAADAAD#;
|
||||
-- This is used to allow us to catch attempts to call Self
|
||||
-- from outside an Ada task, with high probability.
|
||||
-- For an Ada task, Task_Wrapper.Magic_Number = ATCB_Magic_Code.
|
||||
|
||||
type Iptr is access Interfaces.C.unsigned;
|
||||
function To_Iptr is new Unchecked_Conversion (Interfaces.C.unsigned, Iptr);
|
||||
|
||||
type Ptr is access Task_ID;
|
||||
function To_Ptr is new Unchecked_Conversion (Interfaces.C.unsigned, Ptr);
|
||||
|
||||
X : Ptr;
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.1 $ --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1998-2001 Free Software Foundation --
|
||||
-- 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- --
|
||||
@ -29,42 +29,18 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is the SPARC64 VxWorks version of this package.
|
||||
-- This is the Sparc64 VxWorks version of this package.
|
||||
|
||||
with Interfaces.C;
|
||||
with Interfaces;
|
||||
|
||||
package System.VxWorks is
|
||||
pragma Preelaborate (System.VxWorks);
|
||||
|
||||
package IC renames Interfaces.C;
|
||||
|
||||
-- Define enough of a Wind Task Control Block in order to
|
||||
-- obtain the inherited priority. When porting this to
|
||||
-- different versions of VxWorks (this is based on 5.3[.1]),
|
||||
-- be sure to look at the definition for WIND_TCB located
|
||||
-- in $WIND_BASE/target/h/taskLib.h
|
||||
|
||||
type Wind_Fill_1 is array (0 .. 16#3F#) of IC.unsigned_char;
|
||||
type Wind_Fill_2 is array (16#48# .. 16#107#) of IC.unsigned_char;
|
||||
|
||||
type Wind_TCB is record
|
||||
Fill_1 : Wind_Fill_1; -- 0x00 - 0x3f
|
||||
Priority : IC.int; -- 0x40 - 0x43, current (inherited) priority
|
||||
Normal_Priority : IC.int; -- 0x44 - 0x47, base priority
|
||||
Fill_2 : Wind_Fill_2; -- 0x48 - 0x107
|
||||
spare1 : Address; -- 0x108 - 0x10b
|
||||
spare2 : Address; -- 0x10c - 0x10f
|
||||
spare3 : Address; -- 0x110 - 0x113
|
||||
spare4 : Address; -- 0x114 - 0x117
|
||||
end record;
|
||||
type Wind_TCB_Ptr is access Wind_TCB;
|
||||
|
||||
-- Floating point context record. SPARCV9 version
|
||||
-- Floating point context record. SPARCV9 version
|
||||
|
||||
FP_NUM_DREGS : constant := 32;
|
||||
|
||||
@ -75,37 +51,14 @@ package System.VxWorks is
|
||||
for Fpd_Array'Alignment use 8;
|
||||
|
||||
type FP_CONTEXT is record
|
||||
fpd : Fpd_Array;
|
||||
fsr : RType;
|
||||
fpd : Fpd_Array;
|
||||
fsr : RType;
|
||||
end record;
|
||||
|
||||
for FP_CONTEXT'Alignment use 8;
|
||||
pragma Convention (C, FP_CONTEXT);
|
||||
|
||||
-- Number of entries in hardware interrupt vector table. Value of
|
||||
-- 0 disables hardware interrupt handling until we have time to test it
|
||||
-- on this target.
|
||||
Num_HW_Interrupts : constant := 0;
|
||||
|
||||
-- VxWorks 5.3 and 5.4 version
|
||||
type TASK_DESC is record
|
||||
td_id : IC.int; -- task id
|
||||
td_name : Address; -- name of task
|
||||
td_priority : IC.int; -- task priority
|
||||
td_status : IC.int; -- task status
|
||||
td_options : IC.int; -- task option bits (see below)
|
||||
td_entry : Address; -- original entry point of task
|
||||
td_sp : Address; -- saved stack pointer
|
||||
td_pStackBase : Address; -- the bottom of the stack
|
||||
td_pStackLimit : Address; -- the effective end of the stack
|
||||
td_pStackEnd : Address; -- the actual end of the stack
|
||||
td_stackSize : IC.int; -- size of stack in bytes
|
||||
td_stackCurrent : IC.int; -- current stack usage in bytes
|
||||
td_stackHigh : IC.int; -- maximum stack usage in bytes
|
||||
td_stackMargin : IC.int; -- current stack margin in bytes
|
||||
td_errorStatus : IC.int; -- most recent task error status
|
||||
td_delay : IC.int; -- delay/timeout ticks
|
||||
end record;
|
||||
pragma Convention (C, TASK_DESC);
|
||||
Num_HW_Interrupts : constant := 256;
|
||||
-- Number of entries in hardware interrupt vector table.
|
||||
|
||||
end System.VxWorks;
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.26 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1997-2001, Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -120,6 +120,8 @@ package System.OS_Interface is
|
||||
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;
|
||||
|
||||
@ -127,7 +129,7 @@ package System.OS_Interface is
|
||||
(SIGTRAP, SIGLWP, SIGTTIN, SIGTTOU, SIGTSTP, SIGPROF);
|
||||
|
||||
Reserved : constant Signal_Set :=
|
||||
(SIGKILL, SIGSTOP, SIGALRM, SIGVTALRM, SIGWAITING);
|
||||
(SIGKILL, SIGSTOP, SIGALRM, SIGVTALRM, SIGWAITING, SIGRTMAX);
|
||||
|
||||
type sigset_t is private;
|
||||
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.15 $ --
|
||||
-- $Revision$ --
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Florida State University --
|
||||
-- Copyright (C) 1991-2002 Florida State University --
|
||||
-- --
|
||||
-- GNARL is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
@ -208,28 +208,18 @@ begin
|
||||
for J in Exception_Interrupts'Range loop
|
||||
Keep_Unmasked (Exception_Interrupts (J)) := True;
|
||||
|
||||
if Unreserve_All_Interrupts = 0 then
|
||||
Result :=
|
||||
sigaction
|
||||
(Signal (Exception_Interrupts (J)),
|
||||
act'Unchecked_Access,
|
||||
old_act'Unchecked_Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
Result :=
|
||||
sigaction
|
||||
(Signal (Exception_Interrupts (J)),
|
||||
act'Unchecked_Access,
|
||||
old_act'Unchecked_Access);
|
||||
pragma Assert (Result = 0);
|
||||
end loop;
|
||||
|
||||
Keep_Unmasked (Abort_Task_Interrupt) := True;
|
||||
Keep_Unmasked (SIGBUS) := True;
|
||||
Keep_Unmasked (SIGFPE) := True;
|
||||
Result :=
|
||||
sigaction
|
||||
(Signal (SIGFPE), act'Unchecked_Access,
|
||||
old_act'Unchecked_Access);
|
||||
|
||||
Keep_Unmasked (SIGALRM) := True;
|
||||
Keep_Unmasked (SIGSTOP) := True;
|
||||
Keep_Unmasked (SIGKILL) := True;
|
||||
Keep_Unmasked (SIGXCPU) := True;
|
||||
|
||||
-- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but at
|
||||
-- the same time, disable the ability of handling this signal using
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.18 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1996-2001 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1996-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- --
|
||||
@ -60,7 +60,6 @@ with Ada.Task_Identification;
|
||||
with Ada.Exceptions; use Ada.Exceptions;
|
||||
|
||||
with Ada.Unchecked_Conversion;
|
||||
with Ada.Unchecked_Deallocation;
|
||||
|
||||
package body System.AST_Handling is
|
||||
|
||||
@ -162,12 +161,6 @@ package body System.AST_Handling is
|
||||
function To_AST_Handler is new Ada.Unchecked_Conversion
|
||||
(AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler);
|
||||
|
||||
function To_AST_Data_Handler_Ref is new Ada.Unchecked_Conversion
|
||||
(System.Aux_DEC.AST_Handler, AST_Handler_Data_Ref);
|
||||
|
||||
function To_AST_Data_Handler_Ref is new Ada.Unchecked_Conversion
|
||||
(AST_Handler, AST_Handler_Data_Ref);
|
||||
|
||||
-- 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
|
||||
@ -198,9 +191,6 @@ package body System.AST_Handling is
|
||||
|
||||
type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data;
|
||||
type AST_Handler_Vector_Ref is access all AST_Handler_Vector;
|
||||
procedure Free is new Ada.Unchecked_Deallocation
|
||||
(Object => AST_Handler_Vector,
|
||||
Name => AST_Handler_Vector_Ref);
|
||||
|
||||
-- type AST_Vector_Ptr is new Ada.Finalization.Controlled with record
|
||||
-- removed due to problem with controlled attribute, consequence is that
|
||||
@ -211,9 +201,6 @@ package body System.AST_Handling is
|
||||
Vector : AST_Handler_Vector_Ref;
|
||||
end record;
|
||||
|
||||
procedure Finalize (Object : in out AST_Vector_Ptr);
|
||||
-- Used to get rid of allocated AST_Vector's
|
||||
|
||||
AST_Vector_Init : AST_Vector_Ptr;
|
||||
-- Initial value, treated as constant, Vector will be null.
|
||||
|
||||
@ -308,9 +295,6 @@ package body System.AST_Handling is
|
||||
type AST_Server_Task_Ptr is access all AST_Server_Task;
|
||||
-- Type used to allocate server tasks
|
||||
|
||||
function To_Integer is new Ada.Unchecked_Conversion
|
||||
(ATID.Task_Id, Integer);
|
||||
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
-----------------------
|
||||
@ -532,15 +516,6 @@ package body System.AST_Handling is
|
||||
Total_Number := AST_Service_Queue_Size;
|
||||
end Expand_AST_Packet_Pool;
|
||||
|
||||
--------------
|
||||
-- Finalize --
|
||||
--------------
|
||||
|
||||
procedure Finalize (Object : in out AST_Vector_Ptr) is
|
||||
begin
|
||||
Free (Object.Vector);
|
||||
end Finalize;
|
||||
|
||||
-----------------
|
||||
-- Process_AST --
|
||||
-----------------
|
||||
|
||||
@ -7,9 +7,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.8 $ --
|
||||
-- $Revision$ --
|
||||
-- --
|
||||
-- Copyright (C) 1991-2000 Florida State University --
|
||||
-- Copyright (C) 1991-2001 Florida State University --
|
||||
-- --
|
||||
-- GNARL is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
@ -57,7 +57,6 @@ package body System.Interrupt_Management.Operations is
|
||||
use type unsigned_short;
|
||||
|
||||
function To_Address is new Unchecked_Conversion (Task_ID, System.Address);
|
||||
function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
|
||||
package POP renames System.Task_Primitives.Operations;
|
||||
|
||||
----------------------------
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2000 Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -84,13 +83,8 @@ with System.Interrupt_Management.Operations;
|
||||
-- Set_Interrupt_Mask
|
||||
-- IS_Member
|
||||
-- Environment_Mask
|
||||
-- All_Tasks_Mask
|
||||
pragma Elaborate_All (System.Interrupt_Management.Operations);
|
||||
|
||||
with System.Error_Reporting;
|
||||
pragma Warnings (Off, System.Error_Reporting);
|
||||
-- used for Shutdown
|
||||
|
||||
with System.Task_Primitives.Operations;
|
||||
-- used for Write_Lock
|
||||
-- Unlock
|
||||
@ -125,12 +119,15 @@ 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.Error_Reporting;
|
||||
use System.Parameters;
|
||||
use Ada.Exceptions;
|
||||
|
||||
package PRI renames System.Task_Primitives;
|
||||
@ -146,11 +143,13 @@ package body System.Interrupts is
|
||||
-- Local Tasks --
|
||||
-----------------
|
||||
|
||||
-- WARNING: System.Tasking.Utilities performs calls to this task
|
||||
-- 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
|
||||
@ -174,8 +173,6 @@ package body System.Interrupts is
|
||||
E : Task_Entry_Index;
|
||||
Interrupt : Interrupt_ID);
|
||||
|
||||
entry Detach_Interrupt_Entries (T : Task_ID);
|
||||
|
||||
entry Block_Interrupt (Interrupt : Interrupt_ID);
|
||||
|
||||
entry Unblock_Interrupt (Interrupt : Interrupt_ID);
|
||||
@ -260,109 +257,20 @@ package body System.Interrupts is
|
||||
Access_Hold : Server_Task_Access;
|
||||
-- variable used to allocate Server_Task using "new".
|
||||
|
||||
L : aliased PRI.RTS_Lock;
|
||||
-- L protects contents in tables above corresponding to interrupts
|
||||
-- for which Server_ID (T) = null.
|
||||
--
|
||||
-- If Server_ID (T) /= null then protection is via
|
||||
-- per-task (TCB) lock of Server_ID (T).
|
||||
--
|
||||
-- For deadlock prevention, L should not be locked after
|
||||
-- any other lock is held.
|
||||
|
||||
Task_Lock : array (Interrupt_ID'Range) of Boolean := (others => False);
|
||||
-- Boolean flags to give matching Locking and Unlocking. See the comments
|
||||
-- in Lock_Interrupt.
|
||||
|
||||
-----------------------
|
||||
-- Local Subprograms --
|
||||
-----------------------
|
||||
|
||||
procedure Lock_Interrupt
|
||||
(Self_ID : Task_ID;
|
||||
Interrupt : Interrupt_ID);
|
||||
-- protect the tables using L or per-task lock. Set the Boolean
|
||||
-- value Task_Lock if the lock is made using per-task lock.
|
||||
-- This information is needed so that Unlock_Interrupt
|
||||
-- performs unlocking on the same lock. The situation we are preventing
|
||||
-- is, for example, when Attach_Handler is called for the first time
|
||||
-- we lock L and create an Server_Task. For a matching unlocking, if we
|
||||
-- rely on the fact that there is a Server_Task, we will unlock the
|
||||
-- per-task lock.
|
||||
|
||||
procedure Unlock_Interrupt
|
||||
(Self_ID : Task_ID;
|
||||
Interrupt : Interrupt_ID);
|
||||
|
||||
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.
|
||||
|
||||
--------------------
|
||||
-- Lock_Interrupt --
|
||||
--------------------
|
||||
|
||||
-- ?????
|
||||
-- This package has been modified several times.
|
||||
-- Do we still need this fancy locking scheme, now that more operations
|
||||
-- are entries of the interrupt manager task?
|
||||
-- ?????
|
||||
-- More likely, we will need to convert one or more entry calls to
|
||||
-- protected operations, because presently we are violating locking order
|
||||
-- rules by calling a task entry from within the runtime system.
|
||||
|
||||
procedure Lock_Interrupt
|
||||
(Self_ID : Task_ID;
|
||||
Interrupt : Interrupt_ID)
|
||||
is
|
||||
begin
|
||||
Initialization.Defer_Abort (Self_ID);
|
||||
|
||||
POP.Write_Lock (L'Access);
|
||||
|
||||
if Task_Lock (Interrupt) then
|
||||
|
||||
-- We need to use per-task lock.
|
||||
|
||||
POP.Unlock (L'Access);
|
||||
POP.Write_Lock (Server_ID (Interrupt));
|
||||
|
||||
-- Rely on the fact that once Server_ID is set to a non-null
|
||||
-- value it will never be set back to null.
|
||||
|
||||
elsif Server_ID (Interrupt) /= Null_Task then
|
||||
|
||||
-- We need to use per-task lock.
|
||||
|
||||
Task_Lock (Interrupt) := True;
|
||||
POP.Unlock (L'Access);
|
||||
POP.Write_Lock (Server_ID (Interrupt));
|
||||
end if;
|
||||
end Lock_Interrupt;
|
||||
|
||||
----------------------
|
||||
-- Unlock_Interrupt --
|
||||
----------------------
|
||||
|
||||
procedure Unlock_Interrupt
|
||||
(Self_ID : Task_ID;
|
||||
Interrupt : Interrupt_ID)
|
||||
is
|
||||
begin
|
||||
if Task_Lock (Interrupt) then
|
||||
POP.Unlock (Server_ID (Interrupt));
|
||||
else
|
||||
POP.Unlock (L'Access);
|
||||
end if;
|
||||
|
||||
Initialization.Undefer_Abort (Self_ID);
|
||||
end Unlock_Interrupt;
|
||||
|
||||
----------------------------------
|
||||
-- Register_Interrupt_Handler --
|
||||
----------------------------------
|
||||
--------------------------------
|
||||
-- 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
|
||||
@ -393,11 +301,7 @@ package body System.Interrupts is
|
||||
-- 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
|
||||
|
||||
type Fat_Ptr is record
|
||||
Object_Addr : System.Address;
|
||||
Handler_Addr : System.Address;
|
||||
@ -529,8 +433,7 @@ package body System.Interrupts is
|
||||
procedure Attach_Handler
|
||||
(New_Handler : in Parameterless_Handler;
|
||||
Interrupt : in Interrupt_ID;
|
||||
Static : in Boolean := False)
|
||||
is
|
||||
Static : in Boolean := False) is
|
||||
begin
|
||||
if Is_Reserved (Interrupt) then
|
||||
Raise_Exception (Program_Error'Identity, "Interrupt" &
|
||||
@ -557,8 +460,7 @@ package body System.Interrupts is
|
||||
(Old_Handler : out Parameterless_Handler;
|
||||
New_Handler : in Parameterless_Handler;
|
||||
Interrupt : in Interrupt_ID;
|
||||
Static : in Boolean := False)
|
||||
is
|
||||
Static : in Boolean := False) is
|
||||
begin
|
||||
if Is_Reserved (Interrupt) then
|
||||
Raise_Exception (Program_Error'Identity, "Interrupt" &
|
||||
@ -583,8 +485,7 @@ package body System.Interrupts is
|
||||
|
||||
procedure Detach_Handler
|
||||
(Interrupt : in Interrupt_ID;
|
||||
Static : in Boolean := False)
|
||||
is
|
||||
Static : in Boolean := False) is
|
||||
begin
|
||||
if Is_Reserved (Interrupt) then
|
||||
Raise_Exception (Program_Error'Identity, "Interrupt" &
|
||||
@ -592,7 +493,6 @@ package body System.Interrupts is
|
||||
end if;
|
||||
|
||||
Interrupt_Manager.Detach_Handler (Interrupt, Static);
|
||||
|
||||
end Detach_Handler;
|
||||
|
||||
---------------
|
||||
@ -623,7 +523,7 @@ package body System.Interrupts is
|
||||
E : Task_Entry_Index;
|
||||
Int_Ref : System.Address)
|
||||
is
|
||||
Interrupt : constant Interrupt_ID :=
|
||||
Interrupt : constant Interrupt_ID :=
|
||||
Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
|
||||
|
||||
begin
|
||||
@ -678,9 +578,7 @@ package body System.Interrupts is
|
||||
------------------
|
||||
|
||||
function Unblocked_By
|
||||
(Interrupt : Interrupt_ID)
|
||||
return System.Tasking.Task_ID
|
||||
is
|
||||
(Interrupt : Interrupt_ID) return System.Tasking.Task_ID is
|
||||
begin
|
||||
if Is_Reserved (Interrupt) then
|
||||
Raise_Exception (Program_Error'Identity, "Interrupt" &
|
||||
@ -724,9 +622,9 @@ package body System.Interrupts is
|
||||
|
||||
task body Interrupt_Manager is
|
||||
|
||||
----------------------
|
||||
-- Local Variables --
|
||||
----------------------
|
||||
---------------------
|
||||
-- Local Variables --
|
||||
---------------------
|
||||
|
||||
Intwait_Mask : aliased IMNG.Interrupt_Mask;
|
||||
Ret_Interrupt : Interrupt_ID;
|
||||
@ -757,15 +655,12 @@ package body System.Interrupts is
|
||||
New_Handler : in Parameterless_Handler;
|
||||
Interrupt : in Interrupt_ID;
|
||||
Static : in Boolean;
|
||||
Restoration : in Boolean := False)
|
||||
is
|
||||
Restoration : in 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).
|
||||
|
||||
Unlock_Interrupt (Self_ID, Interrupt);
|
||||
Raise_Exception (Program_Error'Identity,
|
||||
"An interrupt is already installed");
|
||||
end if;
|
||||
@ -778,7 +673,6 @@ package body System.Interrupts is
|
||||
-- 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
|
||||
|
||||
@ -789,7 +683,6 @@ package body System.Interrupts is
|
||||
|
||||
or else not Is_Registered (New_Handler))
|
||||
then
|
||||
Unlock_Interrupt (Self_ID, Interrupt);
|
||||
Raise_Exception (Program_Error'Identity,
|
||||
"Trying to overwrite a static Interrupt Handler with a " &
|
||||
"dynamic Handler");
|
||||
@ -842,11 +735,9 @@ package body System.Interrupts 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).
|
||||
|
||||
Unlock_Interrupt (Self_ID, Interrupt);
|
||||
Raise_Exception (Program_Error'Identity,
|
||||
"An interrupt entry is already installed");
|
||||
end if;
|
||||
@ -856,11 +747,9 @@ package body System.Interrupts is
|
||||
-- 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.
|
||||
|
||||
Unlock_Interrupt (Self_ID, Interrupt);
|
||||
Raise_Exception (Program_Error'Identity,
|
||||
"Trying to detach a static Interrupt Handler");
|
||||
end if;
|
||||
@ -933,7 +822,6 @@ package body System.Interrupts is
|
||||
|
||||
declare
|
||||
Old_Handler : Parameterless_Handler;
|
||||
|
||||
begin
|
||||
select
|
||||
|
||||
@ -943,10 +831,8 @@ package body System.Interrupts is
|
||||
Static : in Boolean;
|
||||
Restoration : in Boolean := False)
|
||||
do
|
||||
Lock_Interrupt (Self_ID, Interrupt);
|
||||
Unprotected_Exchange_Handler
|
||||
(Old_Handler, New_Handler, Interrupt, Static, Restoration);
|
||||
Unlock_Interrupt (Self_ID, Interrupt);
|
||||
end Attach_Handler;
|
||||
|
||||
or accept Exchange_Handler
|
||||
@ -955,19 +841,15 @@ package body System.Interrupts is
|
||||
Interrupt : in Interrupt_ID;
|
||||
Static : in Boolean)
|
||||
do
|
||||
Lock_Interrupt (Self_ID, Interrupt);
|
||||
Unprotected_Exchange_Handler
|
||||
(Old_Handler, New_Handler, Interrupt, Static);
|
||||
Unlock_Interrupt (Self_ID, Interrupt);
|
||||
end Exchange_Handler;
|
||||
|
||||
or accept Detach_Handler
|
||||
(Interrupt : in Interrupt_ID;
|
||||
Static : in Boolean)
|
||||
do
|
||||
Lock_Interrupt (Self_ID, Interrupt);
|
||||
Unprotected_Detach_Handler (Interrupt, Static);
|
||||
Unlock_Interrupt (Self_ID, Interrupt);
|
||||
end Detach_Handler;
|
||||
|
||||
or accept Bind_Interrupt_To_Entry
|
||||
@ -975,15 +857,12 @@ package body System.Interrupts is
|
||||
E : Task_Entry_Index;
|
||||
Interrupt : Interrupt_ID)
|
||||
do
|
||||
Lock_Interrupt (Self_ID, Interrupt);
|
||||
|
||||
-- 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
|
||||
Unlock_Interrupt (Self_ID, Interrupt);
|
||||
Raise_Exception (Program_Error'Identity,
|
||||
"A binding for this interrupt is already present");
|
||||
end if;
|
||||
@ -1014,16 +893,12 @@ package body System.Interrupts is
|
||||
POP.Wakeup (Server_ID (Interrupt),
|
||||
Interrupt_Server_Idle_Sleep);
|
||||
end if;
|
||||
|
||||
Unlock_Interrupt (Self_ID, Interrupt);
|
||||
end Bind_Interrupt_To_Entry;
|
||||
|
||||
or accept Detach_Interrupt_Entries (T : Task_ID)
|
||||
do
|
||||
for I in Interrupt_ID'Range loop
|
||||
if not Is_Reserved (I) then
|
||||
Lock_Interrupt (Self_ID, I);
|
||||
|
||||
if User_Entry (I).T = T then
|
||||
|
||||
-- The interrupt should no longer be ignored if
|
||||
@ -1034,8 +909,6 @@ package body System.Interrupts is
|
||||
(T => Null_Task, E => Null_Task_Entry);
|
||||
IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (I));
|
||||
end if;
|
||||
|
||||
Unlock_Interrupt (Self_ID, I);
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
@ -1063,7 +936,6 @@ package body System.Interrupts is
|
||||
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.
|
||||
|
||||
@ -1071,15 +943,10 @@ package body System.Interrupts is
|
||||
null;
|
||||
|
||||
when others =>
|
||||
pragma Assert
|
||||
(Shutdown ("Interrupt_Manager---exception not expected"));
|
||||
pragma Assert (False);
|
||||
null;
|
||||
end;
|
||||
|
||||
end loop;
|
||||
|
||||
pragma Assert (Shutdown ("Interrupt_Manager---should not get here"));
|
||||
|
||||
end Interrupt_Manager;
|
||||
|
||||
-----------------
|
||||
@ -1131,6 +998,10 @@ package body System.Interrupts is
|
||||
-- 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
|
||||
@ -1144,7 +1015,6 @@ package body System.Interrupts is
|
||||
Self_ID.Common.State := Runnable;
|
||||
|
||||
else
|
||||
|
||||
Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag;
|
||||
Ret_Interrupt := IMOP.Interrupt_Wait (Intwait_Mask'Access);
|
||||
Self_ID.Common.State := Runnable;
|
||||
@ -1160,9 +1030,17 @@ package body System.Interrupts is
|
||||
|
||||
POP.Unlock (Self_ID);
|
||||
|
||||
if Single_Lock then
|
||||
POP.Unlock_RTS;
|
||||
end if;
|
||||
|
||||
Tmp_Handler.all;
|
||||
POP.Write_Lock (Self_ID);
|
||||
|
||||
if Single_Lock then
|
||||
POP.Lock_RTS;
|
||||
end if;
|
||||
|
||||
elsif User_Entry (Interrupt).T /= Null_Task then
|
||||
Tmp_ID := User_Entry (Interrupt).T;
|
||||
Tmp_Entry_Index := User_Entry (Interrupt).E;
|
||||
@ -1171,22 +1049,33 @@ package body System.Interrupts is
|
||||
|
||||
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);
|
||||
|
||||
POP.Write_Lock (Self_ID);
|
||||
|
||||
if Single_Lock then
|
||||
POP.Lock_RTS;
|
||||
end if;
|
||||
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;
|
||||
|
||||
pragma Assert (Shutdown ("Server_Task---should not get here"));
|
||||
end Server_Task;
|
||||
|
||||
-------------------------------------
|
||||
@ -1239,8 +1128,7 @@ package body System.Interrupts is
|
||||
|
||||
procedure Install_Handlers
|
||||
(Object : access Static_Interrupt_Protection;
|
||||
New_Handlers : in New_Handler_Array)
|
||||
is
|
||||
New_Handlers : in New_Handler_Array) is
|
||||
begin
|
||||
for N in New_Handlers'Range loop
|
||||
|
||||
@ -1268,12 +1156,6 @@ begin
|
||||
|
||||
Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
|
||||
|
||||
-- Initialize the lock L.
|
||||
|
||||
Initialization.Defer_Abort (Self);
|
||||
POP.Initialize_Lock (L'Access, POP.ATCB_Level);
|
||||
Initialization.Undefer_Abort (Self);
|
||||
|
||||
-- During the elaboration of this package body we want RTS to
|
||||
-- inherit the interrupt mask from the Environment Task.
|
||||
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.6 $ --
|
||||
-- $Revision$ --
|
||||
-- --
|
||||
-- Copyright (C) 1991-2000, Florida State University --
|
||||
-- Copyright (C) 1991-2001, Florida State University --
|
||||
-- --
|
||||
-- GNARL is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
@ -50,8 +50,6 @@ package body System.Interrupt_Management is
|
||||
use System.OS_Interface;
|
||||
use type unsigned_long;
|
||||
|
||||
type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
|
||||
|
||||
---------------------------
|
||||
-- Initialize_Interrupts --
|
||||
---------------------------
|
||||
|
||||
@ -7,9 +7,9 @@
|
||||
-- B o d y --
|
||||
-- (Version for Alpha/VMS) --
|
||||
-- --
|
||||
-- $Revision: 1.3 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 2001 Ada Core Technologies, Inc. --
|
||||
-- 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- --
|
||||
@ -65,13 +65,6 @@ package body System.Machine_State_Operations is
|
||||
end record;
|
||||
for ICB_Fflags_Bits_Type'Size use 24;
|
||||
|
||||
ICB_Fflags_Bits_Type_Init : constant ICB_Fflags_Bits_Type :=
|
||||
(ExceptIon_Frame => False,
|
||||
Ast_Frame => False,
|
||||
Bottom_Of_STACK => False,
|
||||
Base_Frame => False,
|
||||
Filler_1 => 0);
|
||||
|
||||
type ICB_Hdr_Quad_Type is record
|
||||
Context_Length : Unsigned_Longword;
|
||||
Fflags_Bits : ICB_Fflags_Bits_Type;
|
||||
@ -85,11 +78,6 @@ package body System.Machine_State_Operations is
|
||||
end record;
|
||||
for ICB_Hdr_Quad_Type'Size use 64;
|
||||
|
||||
ICB_Hdr_Quad_Type_Init : constant ICB_Hdr_Quad_Type :=
|
||||
(Context_Length => 0,
|
||||
Fflags_Bits => ICB_Fflags_Bits_Type_Init,
|
||||
Block_Version => 0);
|
||||
|
||||
type Invo_Context_Blk_Type is record
|
||||
--
|
||||
-- The first quadword contains:
|
||||
@ -150,16 +138,6 @@ package body System.Machine_State_Operations is
|
||||
end record;
|
||||
for Invo_Context_Blk_Type'Size use 4352;
|
||||
|
||||
Invo_Context_Blk_Type_Init : constant Invo_Context_Blk_Type :=
|
||||
(Hdr_Quad => ICB_Hdr_Quad_Type_Init,
|
||||
Procedure_Descriptor => (0, 0),
|
||||
Program_Counter => 0,
|
||||
Processor_Status => 0,
|
||||
Ireg => (others => (0, 0)),
|
||||
Freg => (others => (0, 0)),
|
||||
System_Defined => (others => (0, 0)),
|
||||
Filler_1 => (others => ASCII.NUL));
|
||||
|
||||
subtype Invo_Handle_Type is Unsigned_Longword;
|
||||
|
||||
type Invo_Handle_Access_Type is access all Invo_Handle_Type;
|
||||
@ -172,9 +150,6 @@ package body System.Machine_State_Operations is
|
||||
function To_Machine_State is new Unchecked_Conversion
|
||||
(System.Address, Machine_State);
|
||||
|
||||
function To_Code_Loc is new Unchecked_Conversion
|
||||
(Unsigned_Longword, Code_Loc);
|
||||
|
||||
----------------------------
|
||||
-- Allocate_Machine_State --
|
||||
----------------------------
|
||||
@ -244,11 +219,8 @@ package body System.Machine_State_Operations is
|
||||
------------------------
|
||||
|
||||
procedure Free_Machine_State (M : in out Machine_State) is
|
||||
procedure Gnat_Free (M : in Invo_Handle_Access_Type);
|
||||
pragma Import (C, Gnat_Free, "__gnat_free");
|
||||
|
||||
begin
|
||||
Gnat_Free (To_Invo_Handle_Access (M));
|
||||
Memory.Free (Address (M));
|
||||
M := Machine_State (Null_Address);
|
||||
end Free_Machine_State;
|
||||
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.23 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -133,4 +133,59 @@ pragma Pure (Parameters);
|
||||
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 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);
|
||||
|
||||
--------------------
|
||||
-- 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;
|
||||
|
||||
@ -7,9 +7,9 @@
|
||||
-- S p e c --
|
||||
-- (OpenVMS DEC Threads Version) --
|
||||
-- --
|
||||
-- $Revision: 1.25 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- 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 --
|
||||
@ -60,16 +60,16 @@ pragma Pure (System);
|
||||
Max_Mantissa : constant := 63;
|
||||
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
|
||||
|
||||
Tick : constant := Standard'Tick;
|
||||
Tick : constant := 1.0;
|
||||
|
||||
-- Storage-related Declarations
|
||||
|
||||
type Address is private;
|
||||
Null_Address : constant Address;
|
||||
|
||||
Storage_Unit : constant := Standard'Storage_Unit;
|
||||
Word_Size : constant := Standard'Word_Size;
|
||||
Memory_Size : constant := 2 ** Standard'Address_Size;
|
||||
Storage_Unit : constant := 8;
|
||||
Word_Size : constant := 32;
|
||||
Memory_Size : constant := 2 ** 32;
|
||||
|
||||
-- Address comparison
|
||||
|
||||
@ -92,27 +92,14 @@ pragma Pure (System);
|
||||
|
||||
-- Priority-related Declarations (RM D.1)
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
Max_Interrupt_Priority : constant Positive := 31;
|
||||
|
||||
subtype Any_Priority is Integer
|
||||
range 0 .. Standard'Max_Interrupt_Priority;
|
||||
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;
|
||||
|
||||
subtype Priority is Any_Priority
|
||||
range 0 .. Standard'Max_Priority;
|
||||
|
||||
-- Functional notation is needed in the following to avoid visibility
|
||||
-- problems when this package is compiled through rtsfind in the middle
|
||||
-- of another compilation.
|
||||
|
||||
subtype Interrupt_Priority is Any_Priority
|
||||
range
|
||||
Standard."+" (Standard'Max_Priority, 1) ..
|
||||
Standard'Max_Interrupt_Priority;
|
||||
|
||||
Default_Priority : constant Priority :=
|
||||
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
|
||||
Default_Priority : constant Priority := 15;
|
||||
|
||||
private
|
||||
|
||||
@ -130,8 +117,11 @@ private
|
||||
-- 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;
|
||||
Denorm : constant Boolean := False;
|
||||
Fractional_Fixed_Ops : constant Boolean := False;
|
||||
Frontend_Layout : constant Boolean := False;
|
||||
Functions_Return_By_DSP : constant Boolean := False;
|
||||
Long_Shifts_Inlined : constant Boolean := True;
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001, Florida State University --
|
||||
-- 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -94,8 +93,10 @@ package body System.Task_Primitives.Operations is
|
||||
ATCB_Key : aliased pthread_key_t;
|
||||
-- Key used to find the Ada Task_ID associated with a thread
|
||||
|
||||
All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
|
||||
-- See comments on locking rules in System.Tasking (spec).
|
||||
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.
|
||||
@ -170,7 +171,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- Note: mutexes and cond_variables needed per-task basis are
|
||||
-- initialized in Initialize_TCB and the Storage_Error is
|
||||
-- handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
|
||||
-- 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.
|
||||
@ -244,7 +245,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Finalize_Lock (L : access Lock) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_destroy (L.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
@ -252,7 +252,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Finalize_Lock (L : access RTS_Lock) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_destroy (L);
|
||||
pragma Assert (Result = 0);
|
||||
@ -289,20 +288,24 @@ package body System.Task_Primitives.Operations is
|
||||
-- Set_Priority (Self_ID, System.Any_Priority (L.Prio));
|
||||
end Write_Lock;
|
||||
|
||||
procedure Write_Lock (L : access RTS_Lock) is
|
||||
procedure Write_Lock
|
||||
(L : access RTS_Lock; Global_Lock : Boolean := False)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_lock (L);
|
||||
pragma Assert (Result = 0);
|
||||
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
|
||||
Result := pthread_mutex_lock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutex_lock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
end Write_Lock;
|
||||
|
||||
---------------
|
||||
@ -320,40 +323,47 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
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) is
|
||||
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_unlock (L);
|
||||
pragma Assert (Result = 0);
|
||||
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
|
||||
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
end Unlock;
|
||||
|
||||
-------------
|
||||
-- Sleep --
|
||||
-------------
|
||||
-----------
|
||||
-- Sleep --
|
||||
-----------
|
||||
|
||||
procedure Sleep (Self_ID : Task_ID;
|
||||
Reason : System.Tasking.Task_States) is
|
||||
procedure Sleep
|
||||
(Self_ID : Task_ID;
|
||||
Reason : System.Tasking.Task_States)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
pragma Assert (Self_ID = Self);
|
||||
Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access);
|
||||
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);
|
||||
|
||||
@ -369,10 +379,6 @@ package body System.Task_Primitives.Operations is
|
||||
-- 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;
|
||||
@ -392,7 +398,7 @@ package body System.Task_Primitives.Operations is
|
||||
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
|
||||
or else Self_ID.Pending_Priority_Change
|
||||
then
|
||||
return;
|
||||
end if;
|
||||
@ -407,8 +413,16 @@ package body System.Task_Primitives.Operations is
|
||||
raise Storage_Error;
|
||||
end if;
|
||||
|
||||
Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access);
|
||||
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;
|
||||
|
||||
Yielded := True;
|
||||
|
||||
if not Self_ID.Common.LL.AST_Pending then
|
||||
Timedout := True;
|
||||
@ -416,41 +430,38 @@ package body System.Task_Primitives.Operations is
|
||||
Sys_Cantim (Status, To_Address (Self_ID), 0);
|
||||
pragma Assert ((Status and 1) = 1);
|
||||
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)
|
||||
(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! :(
|
||||
-- check for pending abort and priority change below!
|
||||
|
||||
if Single_Lock then
|
||||
Lock_RTS;
|
||||
end if;
|
||||
|
||||
SSL.Abort_Defer.all;
|
||||
Write_Lock (Self_ID);
|
||||
|
||||
if not (Time = 0.0 and then Mode = Relative) then
|
||||
|
||||
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;
|
||||
|
||||
@ -475,20 +486,33 @@ package body System.Task_Primitives.Operations is
|
||||
exit;
|
||||
end if;
|
||||
|
||||
Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access);
|
||||
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;
|
||||
|
||||
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);
|
||||
Result := sched_yield;
|
||||
|
||||
if Single_Lock then
|
||||
Unlock_RTS;
|
||||
end if;
|
||||
|
||||
if not Yielded then
|
||||
Result := sched_yield;
|
||||
end if;
|
||||
|
||||
SSL.Abort_Undefer.all;
|
||||
end Timed_Delay;
|
||||
|
||||
@ -514,7 +538,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_cond_signal (T.Common.LL.CV'Access);
|
||||
pragma Assert (Result = 0);
|
||||
@ -526,7 +549,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Yield (Do_Yield : Boolean := True) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
if Do_Yield then
|
||||
Result := sched_yield;
|
||||
@ -538,15 +560,15 @@ package body System.Task_Primitives.Operations is
|
||||
------------------
|
||||
|
||||
procedure Set_Priority
|
||||
(T : Task_ID;
|
||||
Prio : System.Any_Priority;
|
||||
(T : Task_ID;
|
||||
Prio : System.Any_Priority;
|
||||
Loss_Of_Inheritance : Boolean := False)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
Param : aliased struct_sched_param;
|
||||
Result : Interfaces.C.int;
|
||||
Param : aliased struct_sched_param;
|
||||
begin
|
||||
T.Common.Current_Priority := Prio;
|
||||
Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
|
||||
Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio));
|
||||
|
||||
if Time_Slice_Val > 0 then
|
||||
Result := pthread_setschedparam
|
||||
@ -579,7 +601,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Enter_Task (Self_ID : Task_ID) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Self_ID.Common.LL.Thread := pthread_self;
|
||||
|
||||
@ -591,15 +612,17 @@ package body System.Task_Primitives.Operations is
|
||||
Result := pthread_setspecific (ATCB_Key, To_Address (Self_ID));
|
||||
pragma Assert (Result = 0);
|
||||
|
||||
Lock_All_Tasks_List;
|
||||
for I in Known_Tasks'Range loop
|
||||
if Known_Tasks (I) = null then
|
||||
Known_Tasks (I) := Self_ID;
|
||||
Self_ID.Known_Tasks_Index := I;
|
||||
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_All_Tasks_List;
|
||||
|
||||
Unlock_RTS;
|
||||
end Enter_Task;
|
||||
|
||||
--------------
|
||||
@ -621,53 +644,34 @@ package body System.Task_Primitives.Operations is
|
||||
Cond_Attr : aliased pthread_condattr_t;
|
||||
|
||||
begin
|
||||
Result := pthread_mutexattr_init (Mutex_Attr'Access);
|
||||
pragma Assert (Result = 0 or else Result = ENOMEM);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutexattr_init (Mutex_Attr'Access);
|
||||
pragma Assert (Result = 0 or else Result = ENOMEM);
|
||||
|
||||
if Result /= 0 then
|
||||
Succeeded := False;
|
||||
return;
|
||||
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;
|
||||
|
||||
-- Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes.
|
||||
-- Result := pthread_mutexattr_settype_np
|
||||
-- (Mutex_Attr'Access, PTHREAD_MUTEX_ERRORCHECK_NP);
|
||||
-- pragma Assert (Result = 0);
|
||||
|
||||
-- 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);
|
||||
|
||||
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;
|
||||
|
||||
Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
|
||||
pragma Assert (Result = 0);
|
||||
|
||||
Result := pthread_condattr_init (Cond_Attr'Access);
|
||||
pragma Assert (Result = 0 or else Result = ENOMEM);
|
||||
|
||||
if Result /= 0 then
|
||||
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
Succeeded := False;
|
||||
return;
|
||||
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;
|
||||
|
||||
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;
|
||||
Self_ID.Common.LL.Exc_Stack_Ptr := new Exc_Stack_T;
|
||||
@ -676,8 +680,11 @@ package body System.Task_Primitives.Operations is
|
||||
Self_ID.Common.LL.Exc_Stack_Ptr (Exc_Stack_T'Last)'Address);
|
||||
|
||||
else
|
||||
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
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;
|
||||
|
||||
@ -777,13 +784,18 @@ package body System.Task_Primitives.Operations is
|
||||
(Exc_Stack_T, Exc_Stack_Ptr_T);
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_destroy (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
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);
|
||||
end Finalize_TCB;
|
||||
@ -851,23 +863,23 @@ package body System.Task_Primitives.Operations is
|
||||
return Environment_Task_ID;
|
||||
end Environment_Task;
|
||||
|
||||
-------------------------
|
||||
-- Lock_All_Tasks_List --
|
||||
-------------------------
|
||||
--------------
|
||||
-- Lock_RTS --
|
||||
--------------
|
||||
|
||||
procedure Lock_All_Tasks_List is
|
||||
procedure Lock_RTS is
|
||||
begin
|
||||
Write_Lock (All_Tasks_L'Access);
|
||||
end Lock_All_Tasks_List;
|
||||
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Lock_RTS;
|
||||
|
||||
---------------------------
|
||||
-- Unlock_All_Tasks_List --
|
||||
---------------------------
|
||||
----------------
|
||||
-- Unlock_RTS --
|
||||
----------------
|
||||
|
||||
procedure Unlock_All_Tasks_List is
|
||||
procedure Unlock_RTS is
|
||||
begin
|
||||
Unlock (All_Tasks_L'Access);
|
||||
end Unlock_All_Tasks_List;
|
||||
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Unlock_RTS;
|
||||
|
||||
------------------
|
||||
-- Suspend_Task --
|
||||
@ -899,7 +911,7 @@ package body System.Task_Primitives.Operations is
|
||||
begin
|
||||
Environment_Task_ID := Environment_Task;
|
||||
|
||||
Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
|
||||
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
|
||||
-- Initialize the lock used to synchronize chain of all ATCBs.
|
||||
|
||||
Enter_Task (Environment_Task);
|
||||
|
||||
@ -2,14 +2,13 @@
|
||||
-- --
|
||||
-- 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 --
|
||||
-- . D E C --
|
||||
-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.1 $ --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 2000 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 2000-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- --
|
||||
@ -34,11 +33,13 @@
|
||||
-- State University (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package is for OpenVMS/Alpha
|
||||
--
|
||||
|
||||
with System.OS_Interface;
|
||||
with System.Tasking;
|
||||
with Unchecked_Conversion;
|
||||
|
||||
package body System.Task_Primitives.Operations.DEC is
|
||||
|
||||
use System.OS_Interface;
|
||||
@ -46,16 +47,15 @@ package body System.Task_Primitives.Operations.DEC is
|
||||
use System.Aux_DEC;
|
||||
use type Interfaces.C.int;
|
||||
|
||||
-- The FAB_RAB_Type specifieds where the context field (the calling
|
||||
-- The FAB_RAB_Type specifies where the context field (the calling
|
||||
-- task) is stored. Other fields defined for FAB_RAB aren't need and
|
||||
-- so are ignored.
|
||||
type FAB_RAB_Type is
|
||||
record
|
||||
|
||||
type FAB_RAB_Type is record
|
||||
CTX : Unsigned_Longword;
|
||||
end record;
|
||||
|
||||
for FAB_RAB_Type use
|
||||
record
|
||||
for FAB_RAB_Type use record
|
||||
CTX at 24 range 0 .. 31;
|
||||
end record;
|
||||
|
||||
@ -81,8 +81,9 @@ package body System.Task_Primitives.Operations.DEC is
|
||||
---------------------------
|
||||
|
||||
procedure Interrupt_AST_Handler (ID : Address) is
|
||||
Result : Interfaces.C.int;
|
||||
AST_Self_ID : Task_ID := To_Task_Id (ID);
|
||||
Result : Interfaces.C.int;
|
||||
AST_Self_ID : Task_ID := To_Task_Id (ID);
|
||||
|
||||
begin
|
||||
Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access);
|
||||
pragma Assert (Result = 0);
|
||||
@ -93,8 +94,9 @@ package body System.Task_Primitives.Operations.DEC is
|
||||
---------------------
|
||||
|
||||
procedure RMS_AST_Handler (ID : Address) is
|
||||
AST_Self_ID : Task_ID := To_Task_Id (To_FAB_RAB (ID).CTX);
|
||||
Result : Interfaces.C.int;
|
||||
AST_Self_ID : 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);
|
||||
@ -107,6 +109,7 @@ package body System.Task_Primitives.Operations.DEC is
|
||||
|
||||
function Self return Unsigned_Longword is
|
||||
Self_ID : Task_ID := Self;
|
||||
|
||||
begin
|
||||
Self_ID.Common.LL.AST_Pending := True;
|
||||
return To_Unsigned_Longword (Self);
|
||||
@ -117,8 +120,9 @@ package body System.Task_Primitives.Operations.DEC is
|
||||
-------------------------
|
||||
|
||||
procedure Starlet_AST_Handler (ID : Address) is
|
||||
Result : Interfaces.C.int;
|
||||
AST_Self_ID : Task_ID := To_Task_Id (ID);
|
||||
Result : Interfaces.C.int;
|
||||
AST_Self_ID : 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);
|
||||
@ -131,12 +135,15 @@ package body System.Task_Primitives.Operations.DEC is
|
||||
|
||||
procedure Task_Synch is
|
||||
Synch_Self_ID : Task_ID := Self;
|
||||
|
||||
begin
|
||||
Write_Lock (Synch_Self_ID);
|
||||
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;
|
||||
Unlock (Synch_Self_ID);
|
||||
end Task_Synch;
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.2 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 2001 Free Software Foundation, Inc. --
|
||||
-- --
|
||||
@ -214,7 +214,7 @@ package body System.Memory is
|
||||
Result := c_realloc (Ptr, Actual_Size);
|
||||
|
||||
if Result /= System.Null_Address then
|
||||
Available_Memory := Available_Memory + Old_Size - msize (Ptr);
|
||||
Available_Memory := Available_Memory + Old_Size - msize (Result);
|
||||
end if;
|
||||
|
||||
Unlock_Task.all;
|
||||
|
||||
@ -7,9 +7,9 @@
|
||||
-- S p e c --
|
||||
-- (NT Version) --
|
||||
-- --
|
||||
-- $Revision: 1.19 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- 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 --
|
||||
@ -60,16 +60,16 @@ pragma Pure (System);
|
||||
Max_Mantissa : constant := 63;
|
||||
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
|
||||
|
||||
Tick : constant := Standard'Tick;
|
||||
Tick : constant := 1.0;
|
||||
|
||||
-- Storage-related Declarations
|
||||
|
||||
type Address is private;
|
||||
Null_Address : constant Address;
|
||||
|
||||
Storage_Unit : constant := Standard'Storage_Unit;
|
||||
Word_Size : constant := Standard'Word_Size;
|
||||
Memory_Size : constant := 2 ** Standard'Address_Size;
|
||||
Storage_Unit : constant := 8;
|
||||
Word_Size : constant := 32;
|
||||
Memory_Size : constant := 2 ** 32;
|
||||
|
||||
-- Address comparison
|
||||
|
||||
@ -92,27 +92,14 @@ pragma Pure (System);
|
||||
|
||||
-- Priority-related Declarations (RM D.1)
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
|
||||
Max_Priority : constant Positive := 30;
|
||||
Max_Interrupt_Priority : constant Positive := 31;
|
||||
|
||||
subtype Any_Priority is Integer
|
||||
range 0 .. Standard'Max_Interrupt_Priority;
|
||||
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;
|
||||
|
||||
subtype Priority is Any_Priority
|
||||
range 0 .. Standard'Max_Priority;
|
||||
|
||||
-- Functional notation is needed in the following to avoid visibility
|
||||
-- problems when this package is compiled through rtsfind in the middle
|
||||
-- of another compilation.
|
||||
|
||||
subtype Interrupt_Priority is Any_Priority
|
||||
range
|
||||
Standard."+" (Standard'Max_Priority, 1) ..
|
||||
Standard'Max_Interrupt_Priority;
|
||||
|
||||
Default_Priority : constant Priority :=
|
||||
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
|
||||
Default_Priority : constant Priority := 15;
|
||||
|
||||
private
|
||||
|
||||
@ -130,8 +117,11 @@ private
|
||||
-- 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;
|
||||
Denorm : constant Boolean := True;
|
||||
Fractional_Fixed_Ops : constant Boolean := False;
|
||||
Frontend_Layout : constant Boolean := False;
|
||||
Functions_Return_By_DSP : constant Boolean := False;
|
||||
Long_Shifts_Inlined : constant Boolean := True;
|
||||
@ -198,4 +188,11 @@ private
|
||||
|
||||
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;
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
|
||||
-- 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -91,7 +90,10 @@ package body System.Task_Primitives.Operations is
|
||||
use System.Parameters;
|
||||
use System.OS_Primitives;
|
||||
|
||||
pragma Linker_Options ("-Xlinker --stack=0x800000,0x1000");
|
||||
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;
|
||||
|
||||
@ -102,8 +104,10 @@ package body System.Task_Primitives.Operations is
|
||||
Environment_Task_ID : Task_ID;
|
||||
-- A variable to hold Task_ID for the environment task.
|
||||
|
||||
All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
|
||||
-- See comments on locking rules in System.Tasking (spec).
|
||||
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");
|
||||
@ -133,7 +137,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
Fake_ATCB_List : Fake_ATCB_Ptr;
|
||||
-- A linear linked list.
|
||||
-- The list is protected by All_Tasks_L;
|
||||
-- The list is protected by Single_RTS_Lock;
|
||||
-- Nodes are added to this list from the front.
|
||||
-- Once a node is added to this list, it is never removed.
|
||||
|
||||
@ -184,7 +188,7 @@ package body System.Task_Primitives.Operations is
|
||||
-- We dare not call anything that might require an ATCB, until
|
||||
-- we have the new ATCB in place.
|
||||
|
||||
Write_Lock (All_Tasks_L'Access);
|
||||
Lock_RTS;
|
||||
Q := null;
|
||||
P := Fake_ATCB_List;
|
||||
|
||||
@ -263,7 +267,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- Must not unlock until Next_ATCB is again allocated.
|
||||
|
||||
Unlock (All_Tasks_L'Access);
|
||||
Unlock_RTS;
|
||||
return Self_ID;
|
||||
end New_Fake_ATCB;
|
||||
|
||||
@ -475,7 +479,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- Note: mutexes and cond_variables needed per-task basis are
|
||||
-- initialized in Initialize_TCB and the Storage_Error is handled.
|
||||
-- Other mutexes (such as All_Tasks_Lock, Memory_Lock...) used in
|
||||
-- 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.
|
||||
@ -526,15 +530,20 @@ package body System.Task_Primitives.Operations is
|
||||
Ceiling_Violation := False;
|
||||
end Write_Lock;
|
||||
|
||||
procedure Write_Lock (L : access RTS_Lock) is
|
||||
procedure Write_Lock
|
||||
(L : access RTS_Lock; Global_Lock : Boolean := False) is
|
||||
begin
|
||||
EnterCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
|
||||
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
|
||||
EnterCriticalSection
|
||||
(CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
|
||||
if not Single_Lock then
|
||||
EnterCriticalSection
|
||||
(CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
|
||||
end if;
|
||||
end Write_Lock;
|
||||
|
||||
---------------
|
||||
@ -555,15 +564,19 @@ package body System.Task_Primitives.Operations is
|
||||
LeaveCriticalSection (L.Mutex'Access);
|
||||
end Unlock;
|
||||
|
||||
procedure Unlock (L : access RTS_Lock) is
|
||||
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
|
||||
begin
|
||||
LeaveCriticalSection (CRITICAL_SECTION (L.all)'Unrestricted_Access);
|
||||
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
|
||||
LeaveCriticalSection
|
||||
(CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
|
||||
if not Single_Lock then
|
||||
LeaveCriticalSection
|
||||
(CRITICAL_SECTION (T.Common.LL.L)'Unrestricted_Access);
|
||||
end if;
|
||||
end Unlock;
|
||||
|
||||
-----------
|
||||
@ -576,7 +589,11 @@ package body System.Task_Primitives.Operations is
|
||||
begin
|
||||
pragma Assert (Self_ID = Self);
|
||||
|
||||
Cond_Wait (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access);
|
||||
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
|
||||
@ -611,7 +628,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
begin
|
||||
Timedout := True;
|
||||
Yielded := False;
|
||||
Yielded := False;
|
||||
|
||||
if Mode = Relative then
|
||||
Rel_Time := Time;
|
||||
@ -626,8 +643,13 @@ package body System.Task_Primitives.Operations is
|
||||
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
|
||||
or else Self_ID.Pending_Priority_Change;
|
||||
|
||||
Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access, Rel_Time, Local_Timedout, Result);
|
||||
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;
|
||||
|
||||
exit when Abs_Time <= Monotonic_Clock;
|
||||
|
||||
@ -660,9 +682,14 @@ package body System.Task_Primitives.Operations is
|
||||
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! :(
|
||||
-- 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
|
||||
@ -685,8 +712,13 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level;
|
||||
|
||||
Cond_Timed_Wait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access, Rel_Time, Timedout, Result);
|
||||
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;
|
||||
|
||||
exit when Abs_Time <= Monotonic_Clock;
|
||||
|
||||
@ -697,6 +729,11 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
|
||||
Unlock (Self_ID);
|
||||
|
||||
if Single_Lock then
|
||||
Unlock_RTS;
|
||||
end if;
|
||||
|
||||
Yield;
|
||||
SSL.Abort_Undefer.all;
|
||||
end Timed_Delay;
|
||||
@ -834,7 +871,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
|
||||
|
||||
Lock_All_Tasks_List;
|
||||
Lock_RTS;
|
||||
|
||||
for J in Known_Tasks'Range loop
|
||||
if Known_Tasks (J) = null then
|
||||
@ -844,7 +881,7 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
Unlock_All_Tasks_List;
|
||||
Unlock_RTS;
|
||||
end Enter_Task;
|
||||
|
||||
--------------
|
||||
@ -856,14 +893,18 @@ package body System.Task_Primitives.Operations is
|
||||
return new Ada_Task_Control_Block (Entry_Num);
|
||||
end New_ATCB;
|
||||
|
||||
----------------------
|
||||
-- Initialize_TCB --
|
||||
----------------------
|
||||
--------------------
|
||||
-- Initialize_TCB --
|
||||
--------------------
|
||||
|
||||
procedure Initialize_TCB (Self_ID : Task_ID; Succeeded : out Boolean) is
|
||||
begin
|
||||
Initialize_Cond (Self_ID.Common.LL.CV'Access);
|
||||
Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
|
||||
|
||||
if not Single_Lock then
|
||||
Initialize_Lock (Self_ID.Common.LL.L'Access, ATCB_Level);
|
||||
end if;
|
||||
|
||||
Succeeded := True;
|
||||
end Initialize_TCB;
|
||||
|
||||
@ -880,12 +921,6 @@ package body System.Task_Primitives.Operations is
|
||||
is
|
||||
hTask : HANDLE;
|
||||
TaskId : aliased DWORD;
|
||||
|
||||
-- ??? The fact that we can't use PVOID because the compiler
|
||||
-- gives a "PVOID is not visible" error is a GNAT bug.
|
||||
-- The strange thing is that the file compiles fine during a regular
|
||||
-- build.
|
||||
|
||||
pTaskParameter : System.OS_Interface.PVOID;
|
||||
dwStackSize : DWORD;
|
||||
Result : DWORD;
|
||||
@ -952,7 +987,10 @@ package body System.Task_Primitives.Operations is
|
||||
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
|
||||
|
||||
begin
|
||||
Finalize_Lock (T.Common.LL.L'Access);
|
||||
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
|
||||
@ -997,23 +1035,23 @@ package body System.Task_Primitives.Operations is
|
||||
return Environment_Task_ID;
|
||||
end Environment_Task;
|
||||
|
||||
-------------------------
|
||||
-- Lock_All_Tasks_List --
|
||||
-------------------------
|
||||
--------------
|
||||
-- Lock_RTS --
|
||||
--------------
|
||||
|
||||
procedure Lock_All_Tasks_List is
|
||||
procedure Lock_RTS is
|
||||
begin
|
||||
Write_Lock (All_Tasks_L'Access);
|
||||
end Lock_All_Tasks_List;
|
||||
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Lock_RTS;
|
||||
|
||||
---------------------------
|
||||
-- Unlock_All_Tasks_List --
|
||||
---------------------------
|
||||
----------------
|
||||
-- Unlock_RTS --
|
||||
----------------
|
||||
|
||||
procedure Unlock_All_Tasks_List is
|
||||
procedure Unlock_RTS is
|
||||
begin
|
||||
Unlock (All_Tasks_L'Access);
|
||||
end Unlock_All_Tasks_List;
|
||||
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Unlock_RTS;
|
||||
|
||||
----------------
|
||||
-- Initialize --
|
||||
@ -1033,7 +1071,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- Initialize the lock used to synchronize chain of all ATCBs.
|
||||
|
||||
Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
|
||||
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
|
||||
|
||||
Environment_Task.Common.LL.Thread := GetCurrentThread;
|
||||
Enter_Task (Environment_Task);
|
||||
|
||||
@ -5,11 +5,11 @@
|
||||
-- S Y S T E M --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- (VXWORKS Version PPC, Sparc64) --
|
||||
-- (VXWORKS Version PPC) --
|
||||
-- --
|
||||
-- $Revision: 1.6 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- 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 --
|
||||
@ -60,16 +60,16 @@ pragma Pure (System);
|
||||
Max_Mantissa : constant := 63;
|
||||
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
|
||||
|
||||
Tick : constant := Standard'Tick;
|
||||
Tick : constant := 1.0;
|
||||
|
||||
-- Storage-related Declarations
|
||||
|
||||
type Address is private;
|
||||
Null_Address : constant Address;
|
||||
|
||||
Storage_Unit : constant := Standard'Storage_Unit;
|
||||
Word_Size : constant := Standard'Word_Size;
|
||||
Memory_Size : constant := 2 ** Standard'Address_Size;
|
||||
Storage_Unit : constant := 8;
|
||||
Word_Size : constant := 32;
|
||||
Memory_Size : constant := 2 ** 32;
|
||||
|
||||
-- Address comparison
|
||||
|
||||
@ -88,40 +88,26 @@ pragma Pure (System);
|
||||
-- Other System-Dependent Declarations
|
||||
|
||||
type Bit_Order is (High_Order_First, Low_Order_First);
|
||||
Default_Bit_Order : constant Bit_Order :=
|
||||
Bit_Order'Val (Standard'Default_Bit_Order);
|
||||
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
|
||||
-- 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;
|
||||
|
||||
Max_Priority : constant Positive := 245;
|
||||
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;
|
||||
|
||||
subtype Any_Priority is Integer
|
||||
range 0 .. Standard'Max_Interrupt_Priority;
|
||||
|
||||
subtype Priority is Any_Priority
|
||||
range 0 .. Standard'Max_Priority;
|
||||
|
||||
-- Functional notation is needed in the following to avoid visibility
|
||||
-- problems when this package is compiled through rtsfind in the middle
|
||||
-- of another compilation.
|
||||
|
||||
subtype Interrupt_Priority is Any_Priority
|
||||
range
|
||||
Standard."+" (Standard'Max_Priority, 1) ..
|
||||
Standard'Max_Interrupt_Priority;
|
||||
|
||||
Default_Priority : constant Priority :=
|
||||
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
|
||||
Default_Priority : constant Priority := 122;
|
||||
|
||||
private
|
||||
|
||||
@ -139,8 +125,11 @@ private
|
||||
-- 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;
|
||||
Denorm : constant Boolean := True;
|
||||
Fractional_Fixed_Ops : constant Boolean := False;
|
||||
Frontend_Layout : constant Boolean := False;
|
||||
Functions_Return_By_DSP : constant Boolean := False;
|
||||
Long_Shifts_Inlined : constant Boolean := False;
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.11 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Florida State University --
|
||||
-- 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -52,42 +51,22 @@
|
||||
-- may be used by the thread library.
|
||||
|
||||
with Interfaces.C;
|
||||
-- used for int and other types
|
||||
|
||||
with System.Error_Reporting;
|
||||
pragma Warnings (Off, System.Error_Reporting);
|
||||
-- used for Shutdown
|
||||
|
||||
with System.OS_Interface;
|
||||
-- used for various Constants, Signal and types
|
||||
|
||||
with Unchecked_Conversion;
|
||||
|
||||
package body System.Interrupt_Management is
|
||||
|
||||
use Interfaces.C;
|
||||
use System.Error_Reporting;
|
||||
use System.OS_Interface;
|
||||
|
||||
function To_Isr is new Unchecked_Conversion (Long_Integer, isr_address);
|
||||
use type Interfaces.C.int;
|
||||
|
||||
type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
|
||||
Exception_Interrupts : constant Interrupt_List :=
|
||||
Exception_Interrupts : constant Interrupt_List (1 .. 4) :=
|
||||
(SIGFPE, SIGILL, SIGSEGV, SIGBUS);
|
||||
|
||||
-- Keep these variables global so that they are initialized only once.
|
||||
|
||||
Exception_Action : aliased struct_sigaction;
|
||||
Default_Action : aliased struct_sigaction;
|
||||
|
||||
-- ????? Use these horrible imports here to solve elaboration order
|
||||
-- problems.
|
||||
|
||||
type Task_Id is access all Integer;
|
||||
|
||||
Interrupt_ID_Map : array (Interrupt_ID) of Task_Id;
|
||||
pragma Import (Ada, Interrupt_ID_Map,
|
||||
"system__task_primitives__interrupt_operations__interrupt_id_map");
|
||||
|
||||
----------------------
|
||||
-- Notify_Exception --
|
||||
@ -99,13 +78,10 @@ package body System.Interrupt_Management is
|
||||
|
||||
procedure Notify_Exception (signo : Signal) is
|
||||
Mask : aliased sigset_t;
|
||||
Result : Interfaces.C.int;
|
||||
My_Id : pthread_t;
|
||||
Result : int;
|
||||
My_Id : t_id;
|
||||
|
||||
begin
|
||||
-- VxWorks will always mask out the signal during the signal
|
||||
-- handler and will reenable it on a longjmp. GNAT does
|
||||
-- not generate a longjmp to return from a signal handler
|
||||
-- so the signal will still be masked unless we unmask it.
|
||||
Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access);
|
||||
Result := sigdelset (Mask'Access, signo);
|
||||
Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null);
|
||||
@ -114,26 +90,11 @@ package body System.Interrupt_Management is
|
||||
-- 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;
|
||||
|
||||
-- As long as we are using a longjmp to return control to the
|
||||
-- exception handler on the runtime stack, we are safe. The original
|
||||
-- signal mask (the one we had before coming into this signal catching
|
||||
-- function) will be restored by the longjmp. Therefore, raising
|
||||
-- an exception in this handler should be a safe operation.
|
||||
|
||||
-- Check that treatment of exception propagation here
|
||||
-- is consistent with treatment of the abort signal in
|
||||
-- System.Task_Primitives.Operations.
|
||||
|
||||
-- How can SIGSEGV be split into constraint and storage errors?
|
||||
-- What should SIGILL really raise ? Some implementations have
|
||||
-- codes for different types of SIGILL and some raise Storage_Error.
|
||||
-- What causes SIGBUS and should it be caught?
|
||||
-- Peter Burwood
|
||||
|
||||
case signo is
|
||||
when SIGFPE =>
|
||||
raise Constraint_Error;
|
||||
@ -144,63 +105,11 @@ package body System.Interrupt_Management is
|
||||
when SIGBUS =>
|
||||
raise Program_Error;
|
||||
when others =>
|
||||
pragma Assert (Shutdown ("Unexpected signal"));
|
||||
null;
|
||||
-- Unexpected signal
|
||||
raise Program_Error;
|
||||
end case;
|
||||
end Notify_Exception;
|
||||
|
||||
-------------------
|
||||
-- Notify_Signal --
|
||||
-------------------
|
||||
|
||||
-- VxWorks needs a special casing here. Each VxWorks task has a completely
|
||||
-- separate signal handling, so the usual signal masking can't work.
|
||||
-- This idea is to handle all the signals in all the tasks, and when
|
||||
-- such a signal occurs, redirect it to the dedicated task (if any) or
|
||||
-- reraise it.
|
||||
|
||||
procedure Notify_Signal (signo : Signal);
|
||||
|
||||
procedure Notify_Signal (signo : Signal) is
|
||||
Mask : aliased sigset_t;
|
||||
Result : Interfaces.C.int;
|
||||
My_Id : pthread_t;
|
||||
old_isr : isr_address;
|
||||
|
||||
function Get_Thread_Id (T : Task_Id) return pthread_t;
|
||||
pragma Import (Ada, Get_Thread_Id,
|
||||
"system__task_primitives__operations__get_thread_id");
|
||||
|
||||
begin
|
||||
-- VxWorks will always mask out the signal during the signal
|
||||
-- handler and will reenable it on a longjmp. GNAT does
|
||||
-- not generate a longjmp to return from a signal handler
|
||||
-- so the signal will still be masked unless we unmask it.
|
||||
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;
|
||||
|
||||
-- ??? Need a lock around this, in case the handler is detached
|
||||
-- between the two following statements.
|
||||
|
||||
if Interrupt_ID_Map (Interrupt_ID (signo)) /= null then
|
||||
Result :=
|
||||
kill (Get_Thread_Id (Interrupt_ID_Map (Interrupt_ID (signo))),
|
||||
Signal (signo));
|
||||
else
|
||||
old_isr := c_signal (signo, To_Isr (SIG_DFL));
|
||||
Result := kill (My_Id, Signal (signo));
|
||||
end if;
|
||||
end Notify_Signal;
|
||||
|
||||
---------------------------
|
||||
-- Initialize_Interrupts --
|
||||
---------------------------
|
||||
@ -209,20 +118,11 @@ package body System.Interrupt_Management is
|
||||
-- to initialize signal handling in each task.
|
||||
|
||||
procedure Initialize_Interrupts is
|
||||
Result : int;
|
||||
old_act : aliased struct_sigaction;
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
for J in Interrupt_ID'First + 1 .. Interrupt_ID'Last loop
|
||||
if J /= Abort_Task_Interrupt then
|
||||
Result := sigaction (Signal (J), Default_Action'Access,
|
||||
old_act'Unchecked_Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
for J in Exception_Interrupts'Range loop
|
||||
Keep_Unmasked (Exception_Interrupts (J)) := True;
|
||||
Result :=
|
||||
sigaction
|
||||
(Signal (Exception_Interrupts (J)), Exception_Action'Access,
|
||||
@ -233,63 +133,23 @@ package body System.Interrupt_Management is
|
||||
|
||||
begin
|
||||
declare
|
||||
mask : aliased sigset_t;
|
||||
default_mask : aliased sigset_t;
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
mask : aliased sigset_t;
|
||||
Result : int;
|
||||
begin
|
||||
-- The VxWorks POSIX threads library currently needs initialization.
|
||||
-- We wish it could be in System.OS_Interface, but that would
|
||||
-- cause an elaboration problem.
|
||||
|
||||
pthread_init;
|
||||
|
||||
Abort_Task_Interrupt := SIGABRT;
|
||||
-- Change this if you want to use another signal for task abort.
|
||||
-- SIGTERM might be a good one.
|
||||
|
||||
Exception_Action.sa_handler := Notify_Exception'Address;
|
||||
Default_Action.sa_handler := Notify_Signal'Address;
|
||||
|
||||
Exception_Action.sa_flags := SA_SIGINFO + SA_ONSTACK;
|
||||
Default_Action.sa_flags := SA_SIGINFO + SA_ONSTACK;
|
||||
-- Send us extra signal information (SA_SIGINFO) on the
|
||||
-- stack (SA_ONSTACK).
|
||||
-- There is no SA_NODEFER in VxWorks. The signal mask is
|
||||
-- restored after a longjmp so the SA_NODEFER option is
|
||||
-- not needed. - Dan Eischen
|
||||
|
||||
Exception_Action.sa_flags := SA_ONSTACK;
|
||||
Result := sigemptyset (mask'Access);
|
||||
pragma Assert (Result = 0);
|
||||
Result := sigemptyset (default_mask'Access);
|
||||
pragma Assert (Result = 0);
|
||||
|
||||
for J in Interrupt_ID'First + 1 .. Interrupt_ID'Last loop
|
||||
Result := sigaddset (default_mask'Access, Signal (J));
|
||||
pragma Assert (Result = 0);
|
||||
end loop;
|
||||
|
||||
for J in Exception_Interrupts'Range loop
|
||||
Result := sigaddset (mask'Access, Signal (Exception_Interrupts (J)));
|
||||
pragma Assert (Result = 0);
|
||||
Result :=
|
||||
sigdelset (default_mask'Access, Signal (Exception_Interrupts (J)));
|
||||
pragma Assert (Result = 0);
|
||||
end loop;
|
||||
|
||||
Exception_Action.sa_mask := mask;
|
||||
Default_Action.sa_mask := default_mask;
|
||||
|
||||
-- Initialize_Interrupts is called for each task in Enter_Task
|
||||
|
||||
Keep_Unmasked (Abort_Task_Interrupt) := True;
|
||||
|
||||
Reserve := Reserve or Keep_Unmasked or Keep_Masked;
|
||||
|
||||
Reserve (0) := True;
|
||||
-- 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.
|
||||
end;
|
||||
end System.Interrupt_Management;
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.15 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1997-2001 Free Software Foundation --
|
||||
-- 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -43,171 +42,22 @@ 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.VxWorks;
|
||||
-- used for Wind_TCB_Ptr
|
||||
|
||||
with Unchecked_Conversion;
|
||||
|
||||
package body System.OS_Interface is
|
||||
|
||||
use System.VxWorks;
|
||||
use type Interfaces.C.int;
|
||||
|
||||
-- Option flags for taskSpawn
|
||||
Low_Priority : constant := 255;
|
||||
-- VxWorks native (default) lowest scheduling priority.
|
||||
|
||||
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 : Thread_Body;
|
||||
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 pthread_t;
|
||||
pragma Import (C, taskSpawn, "taskSpawn");
|
||||
|
||||
procedure taskDelete (tid : pthread_t);
|
||||
pragma Import (C, taskDelete, "taskDelete");
|
||||
|
||||
-- These are the POSIX scheduling priorities. These are enabled
|
||||
-- when the global variable posixPriorityNumbering is 1.
|
||||
|
||||
POSIX_SCHED_FIFO_LOW_PRI : constant := 0;
|
||||
POSIX_SCHED_FIFO_HIGH_PRI : constant := 255;
|
||||
POSIX_SCHED_RR_LOW_PRI : constant := 0;
|
||||
POSIX_SCHED_RR_HIGH_PRI : constant := 255;
|
||||
|
||||
-- These are the VxWorks native (default) scheduling priorities.
|
||||
-- These are used when the global variable posixPriorityNumbering
|
||||
-- is 0.
|
||||
|
||||
SCHED_FIFO_LOW_PRI : constant := 255;
|
||||
SCHED_FIFO_HIGH_PRI : constant := 0;
|
||||
SCHED_RR_LOW_PRI : constant := 255;
|
||||
SCHED_RR_HIGH_PRI : constant := 0;
|
||||
|
||||
-- Global variable to enable POSIX priority numbering.
|
||||
-- By default, it is 0 and VxWorks native priority numbering
|
||||
-- is used.
|
||||
|
||||
posixPriorityNumbering : int;
|
||||
pragma Import (C, posixPriorityNumbering, "posixPriorityNumbering");
|
||||
|
||||
-- VxWorks will let you set round-robin scheduling globally
|
||||
-- for all tasks, but not for individual tasks. Attempting
|
||||
-- to set the scheduling policy for a specific task (using
|
||||
-- sched_setscheduler) to something other than what the system
|
||||
-- is currently using will fail. If you wish to change the
|
||||
-- scheduling policy, then use the following function to set
|
||||
-- it globally for all tasks. When ticks is 0, time slicing
|
||||
-- (round-robin scheduling) is disabled.
|
||||
|
||||
function kernelTimeSlice (ticks : int) return int;
|
||||
pragma Import (C, kernelTimeSlice, "kernelTimeSlice");
|
||||
|
||||
function taskPriorityGet
|
||||
(tid : pthread_t;
|
||||
pPriority : access int)
|
||||
return int;
|
||||
pragma Import (C, taskPriorityGet, "taskPriorityGet");
|
||||
|
||||
function taskPrioritySet
|
||||
(tid : pthread_t;
|
||||
newPriority : int)
|
||||
return int;
|
||||
pragma Import (C, taskPrioritySet, "taskPrioritySet");
|
||||
|
||||
function To_Wind_TCB_Ptr is
|
||||
new Unchecked_Conversion (pthread_t, Wind_TCB_Ptr);
|
||||
|
||||
|
||||
-- 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;
|
||||
|
||||
-- We use two different kinds of VxWorks semaphores: mutex
|
||||
-- and binary semaphores. A null (0) ID is returned when
|
||||
-- a semaphore cannot be created. Binary semaphores and common
|
||||
-- operations are declared in the spec of this package,
|
||||
-- as they are used to implement hardware interrupt handling
|
||||
|
||||
function semMCreate
|
||||
(options : int) return SEM_ID;
|
||||
pragma Import (C, semMCreate, "semMCreate");
|
||||
|
||||
|
||||
function taskLock return int;
|
||||
pragma Import (C, taskLock, "taskLock");
|
||||
|
||||
function taskUnlock return int;
|
||||
pragma Import (C, taskUnlock, "taskUnlock");
|
||||
|
||||
-------------------------------------------------------
|
||||
-- Convenience routines to convert between VxWorks --
|
||||
-- priority and POSIX priority. --
|
||||
-------------------------------------------------------
|
||||
|
||||
function To_Vxworks_Priority (Priority : in int) return int;
|
||||
pragma Inline (To_Vxworks_Priority);
|
||||
|
||||
function To_Posix_Priority (Priority : in int) return int;
|
||||
pragma Inline (To_Posix_Priority);
|
||||
|
||||
function To_Vxworks_Priority (Priority : in int) return int is
|
||||
begin
|
||||
return SCHED_FIFO_LOW_PRI - Priority;
|
||||
end To_Vxworks_Priority;
|
||||
|
||||
function To_Posix_Priority (Priority : in int) return int is
|
||||
begin
|
||||
return SCHED_FIFO_LOW_PRI - Priority;
|
||||
end To_Posix_Priority;
|
||||
|
||||
----------------------------------------
|
||||
-- Implementation of POSIX routines --
|
||||
----------------------------------------
|
||||
|
||||
-----------------------------------------
|
||||
-- Nonstandard Thread Initialization --
|
||||
-----------------------------------------
|
||||
|
||||
procedure pthread_init is
|
||||
begin
|
||||
Keys_Created := 0;
|
||||
Time_Slice := -1;
|
||||
end pthread_init;
|
||||
|
||||
---------------------------
|
||||
-- POSIX.1c Section 3 --
|
||||
---------------------------
|
||||
-------------
|
||||
-- sigwait --
|
||||
-------------
|
||||
|
||||
function sigwait
|
||||
(set : access sigset_t;
|
||||
sig : access Signal) return int
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
Result : int;
|
||||
|
||||
function sigwaitinfo
|
||||
(set : access sigset_t; sigvalue : System.Address) return int;
|
||||
@ -225,532 +75,6 @@ package body System.OS_Interface is
|
||||
end if;
|
||||
end sigwait;
|
||||
|
||||
----------------------------
|
||||
-- POSIX.1c Section 11 --
|
||||
----------------------------
|
||||
|
||||
function pthread_mutexattr_init
|
||||
(attr : access pthread_mutexattr_t) return int is
|
||||
begin
|
||||
-- Let's take advantage of VxWorks priority inversion
|
||||
-- protection.
|
||||
--
|
||||
-- ??? - Do we want to also specify SEM_DELETE_SAFE???
|
||||
|
||||
attr.Flags := int (SEM_Q_PRIORITY + SEM_INVERSION_SAFE);
|
||||
|
||||
-- Initialize the ceiling priority to the maximim priority.
|
||||
-- We will use POSIX priorities since these routines are
|
||||
-- emulating POSIX routines.
|
||||
|
||||
attr.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI;
|
||||
attr.Protocol := PTHREAD_PRIO_INHERIT;
|
||||
return 0;
|
||||
end pthread_mutexattr_init;
|
||||
|
||||
function pthread_mutexattr_destroy
|
||||
(attr : access pthread_mutexattr_t) return int is
|
||||
begin
|
||||
attr.Flags := 0;
|
||||
attr.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI;
|
||||
attr.Protocol := PTHREAD_PRIO_INHERIT;
|
||||
return 0;
|
||||
end pthread_mutexattr_destroy;
|
||||
|
||||
function pthread_mutex_init
|
||||
(mutex : access pthread_mutex_t;
|
||||
attr : access pthread_mutexattr_t) return int
|
||||
is
|
||||
Result : int := 0;
|
||||
|
||||
begin
|
||||
-- A mutex should initially be created full and the task
|
||||
-- protected from deletion while holding the semaphore.
|
||||
|
||||
mutex.Mutex := semMCreate (attr.Flags);
|
||||
mutex.Prio_Ceiling := attr.Prio_Ceiling;
|
||||
mutex.Protocol := attr.Protocol;
|
||||
|
||||
if mutex.Mutex = 0 then
|
||||
Result := errno;
|
||||
end if;
|
||||
|
||||
return Result;
|
||||
end pthread_mutex_init;
|
||||
|
||||
function pthread_mutex_destroy
|
||||
(mutex : access pthread_mutex_t) return int
|
||||
is
|
||||
Result : STATUS;
|
||||
begin
|
||||
Result := semDelete (mutex.Mutex);
|
||||
|
||||
if Result /= 0 then
|
||||
Result := errno;
|
||||
end if;
|
||||
|
||||
mutex.Mutex := 0; -- Ensure the mutex is properly cleaned.
|
||||
mutex.Prio_Ceiling := POSIX_SCHED_FIFO_HIGH_PRI;
|
||||
mutex.Protocol := PTHREAD_PRIO_INHERIT;
|
||||
return Result;
|
||||
end pthread_mutex_destroy;
|
||||
|
||||
function pthread_mutex_lock
|
||||
(mutex : access pthread_mutex_t) return int
|
||||
is
|
||||
Result : int;
|
||||
WTCB_Ptr : Wind_TCB_Ptr;
|
||||
begin
|
||||
WTCB_Ptr := To_Wind_TCB_Ptr (taskIdSelf);
|
||||
|
||||
if WTCB_Ptr = null then
|
||||
return errno;
|
||||
end if;
|
||||
|
||||
-- Check the current inherited priority in the WIND_TCB
|
||||
-- against the mutex ceiling priority and return EINVAL
|
||||
-- upon a ceiling violation.
|
||||
--
|
||||
-- We always convert the VxWorks priority to POSIX priority
|
||||
-- in case the current priority ordering has changed (see
|
||||
-- posixPriorityNumbering). The mutex ceiling priority is
|
||||
-- maintained as POSIX compatible.
|
||||
|
||||
if mutex.Protocol = PTHREAD_PRIO_PROTECT and then
|
||||
To_Posix_Priority (WTCB_Ptr.Priority) > mutex.Prio_Ceiling
|
||||
then
|
||||
return EINVAL;
|
||||
end if;
|
||||
|
||||
Result := semTake (mutex.Mutex, WAIT_FOREVER);
|
||||
|
||||
if Result /= 0 then
|
||||
Result := errno;
|
||||
end if;
|
||||
|
||||
return Result;
|
||||
end pthread_mutex_lock;
|
||||
|
||||
function pthread_mutex_unlock
|
||||
(mutex : access pthread_mutex_t) return int
|
||||
is
|
||||
Result : int;
|
||||
begin
|
||||
Result := semGive (mutex.Mutex);
|
||||
|
||||
if Result /= 0 then
|
||||
Result := errno;
|
||||
end if;
|
||||
|
||||
return Result;
|
||||
end pthread_mutex_unlock;
|
||||
|
||||
function pthread_condattr_init
|
||||
(attr : access pthread_condattr_t) return int is
|
||||
begin
|
||||
attr.Flags := SEM_Q_PRIORITY;
|
||||
return 0;
|
||||
end pthread_condattr_init;
|
||||
|
||||
function pthread_condattr_destroy
|
||||
(attr : access pthread_condattr_t) return int is
|
||||
begin
|
||||
attr.Flags := 0;
|
||||
return 0;
|
||||
end pthread_condattr_destroy;
|
||||
|
||||
function pthread_cond_init
|
||||
(cond : access pthread_cond_t;
|
||||
attr : access pthread_condattr_t) return int
|
||||
is
|
||||
Result : int := 0;
|
||||
|
||||
begin
|
||||
-- Condition variables should be initially created
|
||||
-- empty.
|
||||
|
||||
cond.Sem := semBCreate (attr.Flags, SEM_EMPTY);
|
||||
cond.Waiting := 0;
|
||||
|
||||
if cond.Sem = 0 then
|
||||
Result := errno;
|
||||
end if;
|
||||
|
||||
return Result;
|
||||
end pthread_cond_init;
|
||||
|
||||
function pthread_cond_destroy (cond : access pthread_cond_t) return int is
|
||||
Result : int;
|
||||
|
||||
begin
|
||||
Result := semDelete (cond.Sem);
|
||||
|
||||
if Result /= 0 then
|
||||
Result := errno;
|
||||
end if;
|
||||
|
||||
return Result;
|
||||
end pthread_cond_destroy;
|
||||
|
||||
function pthread_cond_signal
|
||||
(cond : access pthread_cond_t) return int
|
||||
is
|
||||
Result : int := 0;
|
||||
Status : int;
|
||||
|
||||
begin
|
||||
-- Disable task scheduling.
|
||||
|
||||
Status := taskLock;
|
||||
|
||||
-- Iff someone is currently waiting on the condition variable
|
||||
-- then release the semaphore; we don't want to leave the
|
||||
-- semaphore in the full state because the next guy to do
|
||||
-- a condition wait operation would not block.
|
||||
|
||||
if cond.Waiting > 0 then
|
||||
Result := semGive (cond.Sem);
|
||||
|
||||
-- One less thread waiting on the CV.
|
||||
|
||||
cond.Waiting := cond.Waiting - 1;
|
||||
|
||||
if Result /= 0 then
|
||||
Result := errno;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Reenable task scheduling.
|
||||
|
||||
Status := taskUnlock;
|
||||
|
||||
return Result;
|
||||
end pthread_cond_signal;
|
||||
|
||||
function pthread_cond_wait
|
||||
(cond : access pthread_cond_t;
|
||||
mutex : access pthread_mutex_t) return int
|
||||
is
|
||||
Result : int;
|
||||
Status : int;
|
||||
begin
|
||||
-- Disable task scheduling.
|
||||
|
||||
Status := taskLock;
|
||||
|
||||
-- Release the mutex as required by POSIX.
|
||||
|
||||
Result := semGive (mutex.Mutex);
|
||||
|
||||
-- Indicate that there is another thread waiting on the CV.
|
||||
|
||||
cond.Waiting := cond.Waiting + 1;
|
||||
|
||||
-- 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 (cond.Sem, WAIT_FOREVER);
|
||||
|
||||
if Result /= 0 then
|
||||
cond.Waiting := cond.Waiting - 1;
|
||||
Result := EINVAL;
|
||||
end if;
|
||||
|
||||
-- Take the mutex as required by POSIX.
|
||||
|
||||
Status := semTake (mutex.Mutex, WAIT_FOREVER);
|
||||
|
||||
if Status /= 0 then
|
||||
Result := EINVAL;
|
||||
end if;
|
||||
|
||||
-- Reenable task scheduling.
|
||||
|
||||
Status := taskUnlock;
|
||||
|
||||
return Result;
|
||||
end pthread_cond_wait;
|
||||
|
||||
function pthread_cond_timedwait
|
||||
(cond : access pthread_cond_t;
|
||||
mutex : access pthread_mutex_t;
|
||||
abstime : access timespec) return int
|
||||
is
|
||||
Result : int;
|
||||
Status : int;
|
||||
Ticks : int;
|
||||
TS : aliased timespec;
|
||||
begin
|
||||
Status := clock_gettime (CLOCK_REALTIME, TS'Unchecked_Access);
|
||||
|
||||
-- Calculate the number of clock ticks for the timeout.
|
||||
|
||||
Ticks := To_Clock_Ticks (To_Duration (abstime.all) - To_Duration (TS));
|
||||
|
||||
if Ticks <= 0 then
|
||||
-- It is not worth the time to try to perform a semTake,
|
||||
-- because we know it will always fail. A semTake with
|
||||
-- ticks = 0 (NO_WAIT) will not block and therefore not
|
||||
-- allow another task to give the semaphore. And if we've
|
||||
-- designed pthread_cond_signal correctly, the semaphore
|
||||
-- should never be left in a full state.
|
||||
--
|
||||
-- Make sure we give up the CPU.
|
||||
|
||||
Status := taskDelay (0);
|
||||
return ETIMEDOUT;
|
||||
end if;
|
||||
|
||||
-- Disable task scheduling.
|
||||
|
||||
Status := taskLock;
|
||||
|
||||
-- Release the mutex as required by POSIX.
|
||||
|
||||
Result := semGive (mutex.Mutex);
|
||||
|
||||
-- Indicate that there is another thread waiting on the CV.
|
||||
|
||||
cond.Waiting := cond.Waiting + 1;
|
||||
|
||||
-- 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 (cond.Sem, Ticks);
|
||||
|
||||
if Result /= 0 then
|
||||
if errno = S_objLib_OBJ_TIMEOUT then
|
||||
Result := ETIMEDOUT;
|
||||
else
|
||||
Result := EINVAL;
|
||||
end if;
|
||||
cond.Waiting := cond.Waiting - 1;
|
||||
end if;
|
||||
|
||||
-- Take the mutex as required by POSIX.
|
||||
|
||||
Status := semTake (mutex.Mutex, WAIT_FOREVER);
|
||||
|
||||
if Status /= 0 then
|
||||
Result := EINVAL;
|
||||
end if;
|
||||
|
||||
-- Reenable task scheduling.
|
||||
|
||||
Status := taskUnlock;
|
||||
|
||||
return Result;
|
||||
end pthread_cond_timedwait;
|
||||
|
||||
----------------------------
|
||||
-- POSIX.1c Section 13 --
|
||||
----------------------------
|
||||
|
||||
function pthread_mutexattr_setprotocol
|
||||
(attr : access pthread_mutexattr_t;
|
||||
protocol : int) return int is
|
||||
begin
|
||||
if protocol < PTHREAD_PRIO_NONE
|
||||
or protocol > PTHREAD_PRIO_PROTECT
|
||||
then
|
||||
return EINVAL;
|
||||
end if;
|
||||
|
||||
attr.Protocol := protocol;
|
||||
return 0;
|
||||
end pthread_mutexattr_setprotocol;
|
||||
|
||||
function pthread_mutexattr_setprioceiling
|
||||
(attr : access pthread_mutexattr_t;
|
||||
prioceiling : int) return int is
|
||||
begin
|
||||
-- Our interface to the rest of the world is meant
|
||||
-- to be POSIX compliant; keep the priority in POSIX
|
||||
-- format.
|
||||
|
||||
attr.Prio_Ceiling := prioceiling;
|
||||
return 0;
|
||||
end pthread_mutexattr_setprioceiling;
|
||||
|
||||
function pthread_setschedparam
|
||||
(thread : pthread_t;
|
||||
policy : int;
|
||||
param : access struct_sched_param) return int
|
||||
is
|
||||
Result : int;
|
||||
begin
|
||||
-- Convert the POSIX priority to VxWorks native
|
||||
-- priority.
|
||||
|
||||
Result := taskPrioritySet (thread,
|
||||
To_Vxworks_Priority (param.sched_priority));
|
||||
return 0;
|
||||
end pthread_setschedparam;
|
||||
|
||||
function sched_yield return int is
|
||||
begin
|
||||
return taskDelay (0);
|
||||
end sched_yield;
|
||||
|
||||
function pthread_sched_rr_set_interval (usecs : int) return int is
|
||||
Result : int := 0;
|
||||
D_Slice : Duration;
|
||||
begin
|
||||
-- Check to see if round-robin scheduling (time slicing)
|
||||
-- is enabled. If the time slice is the default value (-1)
|
||||
-- or any negative number, we will leave the kernel time
|
||||
-- slice unchanged. If the time slice is 0, we disable
|
||||
-- kernel time slicing by setting it to 0. Otherwise, we
|
||||
-- set the kernel time slice to the specified value converted
|
||||
-- to clock ticks.
|
||||
|
||||
Time_Slice := usecs;
|
||||
|
||||
if Time_Slice > 0 then
|
||||
D_Slice := Duration (Time_Slice) / Duration (1_000_000.0);
|
||||
Result := kernelTimeSlice (To_Clock_Ticks (D_Slice));
|
||||
|
||||
else
|
||||
if Time_Slice = 0 then
|
||||
Result := kernelTimeSlice (0);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
return Result;
|
||||
end pthread_sched_rr_set_interval;
|
||||
|
||||
function pthread_attr_init (attr : access pthread_attr_t) return int is
|
||||
begin
|
||||
attr.Stacksize := 100000; -- What else can I do?
|
||||
attr.Detachstate := PTHREAD_CREATE_DETACHED;
|
||||
attr.Priority := POSIX_SCHED_FIFO_LOW_PRI;
|
||||
attr.Taskname := System.Null_Address;
|
||||
return 0;
|
||||
end pthread_attr_init;
|
||||
|
||||
function pthread_attr_destroy (attr : access pthread_attr_t) return int is
|
||||
begin
|
||||
attr.Stacksize := 0;
|
||||
attr.Detachstate := 0;
|
||||
attr.Priority := POSIX_SCHED_FIFO_LOW_PRI;
|
||||
attr.Taskname := System.Null_Address;
|
||||
return 0;
|
||||
end pthread_attr_destroy;
|
||||
|
||||
function pthread_attr_setdetachstate
|
||||
(attr : access pthread_attr_t;
|
||||
detachstate : int) return int is
|
||||
begin
|
||||
attr.Detachstate := detachstate;
|
||||
return 0;
|
||||
end pthread_attr_setdetachstate;
|
||||
|
||||
function pthread_attr_setstacksize
|
||||
(attr : access pthread_attr_t;
|
||||
stacksize : size_t) return int is
|
||||
begin
|
||||
attr.Stacksize := stacksize;
|
||||
return 0;
|
||||
end pthread_attr_setstacksize;
|
||||
|
||||
-- In VxWorks tasks, we can set the task name. This
|
||||
-- makes it really convenient for debugging.
|
||||
|
||||
function pthread_attr_setname_np
|
||||
(attr : access pthread_attr_t;
|
||||
name : System.Address) return int is
|
||||
begin
|
||||
attr.Taskname := name;
|
||||
return 0;
|
||||
end pthread_attr_setname_np;
|
||||
|
||||
function pthread_create
|
||||
(thread : access pthread_t;
|
||||
attr : access pthread_attr_t;
|
||||
start_routine : Thread_Body;
|
||||
arg : System.Address) return int is
|
||||
begin
|
||||
thread.all := taskSpawn (attr.Taskname,
|
||||
To_Vxworks_Priority (attr.Priority), VX_FP_TASK, attr.Stacksize,
|
||||
start_routine, arg);
|
||||
|
||||
if thread.all = -1 then
|
||||
return -1;
|
||||
else
|
||||
return 0;
|
||||
end if;
|
||||
end pthread_create;
|
||||
|
||||
function pthread_detach (thread : pthread_t) return int is
|
||||
begin
|
||||
return 0;
|
||||
end pthread_detach;
|
||||
|
||||
procedure pthread_exit (status : System.Address) is
|
||||
begin
|
||||
taskDelete (0);
|
||||
end pthread_exit;
|
||||
|
||||
function pthread_self return pthread_t is
|
||||
begin
|
||||
return taskIdSelf;
|
||||
end pthread_self;
|
||||
|
||||
function pthread_equal (t1 : pthread_t; t2 : pthread_t) return int is
|
||||
begin
|
||||
if t1 = t2 then
|
||||
return 1;
|
||||
else
|
||||
return 0;
|
||||
end if;
|
||||
end pthread_equal;
|
||||
|
||||
function pthread_setspecific
|
||||
(key : pthread_key_t;
|
||||
value : System.Address) return int
|
||||
is
|
||||
Result : int;
|
||||
begin
|
||||
if Integer (key) not in Key_Storage'Range then
|
||||
return EINVAL;
|
||||
end if;
|
||||
|
||||
Key_Storage (Integer (key)) := value;
|
||||
Result := taskVarAdd (taskIdSelf, Key_Storage (Integer (key))'Access);
|
||||
|
||||
-- We should be able to directly set the key with the following:
|
||||
-- Key_Storage (key) := value;
|
||||
-- but we'll be safe and use taskVarSet.
|
||||
-- ??? Come back and revisit this.
|
||||
|
||||
Result := taskVarSet (taskIdSelf,
|
||||
Key_Storage (Integer (key))'Access, value);
|
||||
return Result;
|
||||
end pthread_setspecific;
|
||||
|
||||
function pthread_getspecific (key : pthread_key_t) return System.Address is
|
||||
begin
|
||||
return Key_Storage (Integer (key));
|
||||
end pthread_getspecific;
|
||||
|
||||
function pthread_key_create
|
||||
(key : access pthread_key_t;
|
||||
destructor : destructor_pointer) return int is
|
||||
begin
|
||||
Keys_Created := Keys_Created + 1;
|
||||
|
||||
if Keys_Created not in Key_Storage'Range then
|
||||
return ENOMEM;
|
||||
end if;
|
||||
|
||||
key.all := pthread_key_t (Keys_Created);
|
||||
return 0;
|
||||
end pthread_key_create;
|
||||
|
||||
-----------------
|
||||
-- To_Duration --
|
||||
-----------------
|
||||
@ -777,21 +101,31 @@ package body System.OS_Interface is
|
||||
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
|
||||
-- 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
|
||||
-- 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.
|
||||
@ -800,7 +134,11 @@ package body System.OS_Interface 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.
|
||||
@ -809,10 +147,7 @@ package body System.OS_Interface is
|
||||
|
||||
if D > (Duration'Last / Rate_Duration) then
|
||||
Ticks := Long_Long_Integer (int'Last);
|
||||
|
||||
else
|
||||
-- We always want to round up to the nearest clock tick.
|
||||
|
||||
Ticks_Duration := D * Rate_Duration;
|
||||
Ticks := Long_Long_Integer (Ticks_Duration);
|
||||
|
||||
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -50,19 +49,15 @@
|
||||
|
||||
with Interfaces.C;
|
||||
with System.VxWorks;
|
||||
|
||||
package System.OS_Interface is
|
||||
pragma Preelaborate;
|
||||
|
||||
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 is Interfaces.C.char;
|
||||
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 --
|
||||
@ -83,14 +78,6 @@ package System.OS_Interface is
|
||||
-- Signals and Interrupts --
|
||||
----------------------------
|
||||
|
||||
-- In order to support both signal and hardware interrupt handling,
|
||||
-- the ranges of "interrupt IDs" for the vectored hardware interrupts
|
||||
-- and the signals are catenated. In other words, the external IDs
|
||||
-- used to designate signals are relocated beyond the range of the
|
||||
-- vectored interrupts. The IDs given in Ada.Interrupts.Names should
|
||||
-- be used to designate signals; vectored interrupts are designated
|
||||
-- by their interrupt number.
|
||||
|
||||
NSIG : constant := 32;
|
||||
-- Number of signals on the target OS
|
||||
type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1);
|
||||
@ -98,7 +85,7 @@ package System.OS_Interface is
|
||||
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 + NSIG;
|
||||
Max_Interrupt : constant := Max_HW_Interrupt;
|
||||
|
||||
SIGILL : constant := 4; -- illegal instruction (not reset)
|
||||
SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
|
||||
@ -116,10 +103,9 @@ package System.OS_Interface is
|
||||
SIG_SETMASK : constant := 3;
|
||||
|
||||
-- The sa_flags in struct sigaction.
|
||||
SA_SIGINFO : constant := 16#0002#;
|
||||
SA_ONSTACK : constant := 16#0004#;
|
||||
SA_SIGINFO : constant := 16#0002#;
|
||||
SA_ONSTACK : constant := 16#0004#;
|
||||
|
||||
-- ANSI args and returns from signal().
|
||||
SIG_DFL : constant := 0;
|
||||
SIG_IGN : constant := 1;
|
||||
|
||||
@ -170,6 +156,17 @@ package System.OS_Interface is
|
||||
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 --
|
||||
----------
|
||||
@ -199,261 +196,104 @@ package System.OS_Interface is
|
||||
(clock_id : clockid_t; tp : access timespec) return int;
|
||||
pragma Import (C, clock_gettime, "clock_gettime");
|
||||
|
||||
-------------------------
|
||||
-- Priority Scheduling --
|
||||
-------------------------
|
||||
type ULONG is new unsigned_long;
|
||||
|
||||
-- Scheduling policies.
|
||||
SCHED_FIFO : constant := 1;
|
||||
SCHED_RR : constant := 2;
|
||||
SCHED_OTHER : constant := 4;
|
||||
procedure tickSet (ticks : ULONG);
|
||||
pragma Import (C, tickSet, "tickSet");
|
||||
|
||||
-------------
|
||||
-- Threads --
|
||||
-------------
|
||||
function tickGet return ULONG;
|
||||
pragma Import (C, tickGet, "tickGet");
|
||||
|
||||
type Thread_Body is access
|
||||
function (arg : System.Address) return System.Address;
|
||||
-----------------------------------------------------
|
||||
-- Convenience routine to convert between VxWorks --
|
||||
-- priority and Ada priority. --
|
||||
-----------------------------------------------------
|
||||
|
||||
type pthread_t is private;
|
||||
subtype Thread_Id is pthread_t;
|
||||
function To_VxWorks_Priority (Priority : in int) return int;
|
||||
pragma Inline (To_VxWorks_Priority);
|
||||
|
||||
null_pthread : constant pthread_t;
|
||||
--------------------------
|
||||
-- VxWorks specific API --
|
||||
--------------------------
|
||||
|
||||
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;
|
||||
PTHREAD_CREATE_JOINABLE : constant := 1;
|
||||
|
||||
function kill (pid : pthread_t; sig : Signal) return int;
|
||||
pragma Import (C, kill, "kill");
|
||||
|
||||
-- VxWorks doesn't have getpid; taskIdSelf is the equivalent
|
||||
-- routine.
|
||||
function getpid return pthread_t;
|
||||
pragma Import (C, getpid, "taskIdSelf");
|
||||
|
||||
---------------------------------
|
||||
-- Nonstandard Thread Routines --
|
||||
---------------------------------
|
||||
|
||||
procedure pthread_init;
|
||||
pragma Inline (pthread_init);
|
||||
-- Vxworks requires this for the moment.
|
||||
|
||||
function taskIdSelf return pthread_t;
|
||||
function taskIdSelf return t_id;
|
||||
pragma Import (C, taskIdSelf, "taskIdSelf");
|
||||
|
||||
function taskSuspend (tid : pthread_t) return int;
|
||||
function taskSuspend (tid : t_id) return int;
|
||||
pragma Import (C, taskSuspend, "taskSuspend");
|
||||
|
||||
function taskResume (tid : pthread_t) return int;
|
||||
function taskResume (tid : t_id) return int;
|
||||
pragma Import (C, taskResume, "taskResume");
|
||||
|
||||
function taskIsSuspended (tid : pthread_t) return int;
|
||||
function taskIsSuspended (tid : t_id) return int;
|
||||
pragma Import (C, taskIsSuspended, "taskIsSuspended");
|
||||
|
||||
function taskVarAdd
|
||||
(tid : pthread_t;
|
||||
pVar : access System.Address) return int;
|
||||
(tid : t_id; pVar : System.Address) return int;
|
||||
pragma Import (C, taskVarAdd, "taskVarAdd");
|
||||
|
||||
function taskVarDelete
|
||||
(tid : pthread_t;
|
||||
pVar : access System.Address) return int;
|
||||
(tid : t_id; pVar : access System.Address) return int;
|
||||
pragma Import (C, taskVarDelete, "taskVarDelete");
|
||||
|
||||
function taskVarSet
|
||||
(tid : pthread_t;
|
||||
(tid : t_id;
|
||||
pVar : access System.Address;
|
||||
value : System.Address) return int;
|
||||
pragma Import (C, taskVarSet, "taskVarSet");
|
||||
|
||||
function taskVarGet
|
||||
(tid : pthread_t;
|
||||
pVar : access System.Address) return int;
|
||||
(tid : t_id;
|
||||
pVar : access System.Address) return int;
|
||||
pragma Import (C, taskVarGet, "taskVarGet");
|
||||
|
||||
function taskInfoGet
|
||||
(tid : pthread_t;
|
||||
pTaskDesc : access System.VxWorks.TASK_DESC) return int;
|
||||
pragma Import (C, taskInfoGet, "taskInfoGet");
|
||||
|
||||
function taskDelay (ticks : int) return int;
|
||||
procedure taskDelay (ticks : int);
|
||||
pragma Import (C, taskDelay, "taskDelay");
|
||||
|
||||
function sysClkRateGet return int;
|
||||
pragma Import (C, sysClkRateGet, "sysClkRateGet");
|
||||
|
||||
--------------------------
|
||||
-- POSIX.1c Section 11 --
|
||||
--------------------------
|
||||
-- Option flags for taskSpawn
|
||||
|
||||
function pthread_mutexattr_init
|
||||
(attr : access pthread_mutexattr_t) return int;
|
||||
pragma Inline (pthread_mutexattr_init);
|
||||
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 pthread_mutexattr_destroy
|
||||
(attr : access pthread_mutexattr_t) return int;
|
||||
pragma Inline (pthread_mutexattr_destroy);
|
||||
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");
|
||||
|
||||
function pthread_mutex_init
|
||||
(mutex : access pthread_mutex_t;
|
||||
attr : access pthread_mutexattr_t) return int;
|
||||
pragma Inline (pthread_mutex_init);
|
||||
procedure taskDelete (tid : t_id);
|
||||
pragma Import (C, taskDelete, "taskDelete");
|
||||
|
||||
function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int;
|
||||
pragma Inline (pthread_mutex_destroy);
|
||||
function kernelTimeSlice (ticks : int) return int;
|
||||
pragma Import (C, kernelTimeSlice, "kernelTimeSlice");
|
||||
|
||||
function pthread_mutex_lock (mutex : access pthread_mutex_t) return int;
|
||||
pragma Inline (pthread_mutex_lock);
|
||||
|
||||
function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int;
|
||||
pragma Inline (pthread_mutex_unlock);
|
||||
|
||||
function pthread_condattr_init
|
||||
(attr : access pthread_condattr_t) return int;
|
||||
pragma Inline (pthread_condattr_init);
|
||||
|
||||
function pthread_condattr_destroy
|
||||
(attr : access pthread_condattr_t) return int;
|
||||
pragma Inline (pthread_condattr_destroy);
|
||||
|
||||
function pthread_cond_init
|
||||
(cond : access pthread_cond_t;
|
||||
attr : access pthread_condattr_t) return int;
|
||||
pragma Inline (pthread_cond_init);
|
||||
|
||||
function pthread_cond_destroy (cond : access pthread_cond_t) return int;
|
||||
pragma Inline (pthread_cond_destroy);
|
||||
|
||||
function pthread_cond_signal (cond : access pthread_cond_t) return int;
|
||||
pragma Inline (pthread_cond_signal);
|
||||
|
||||
function pthread_cond_wait
|
||||
(cond : access pthread_cond_t;
|
||||
mutex : access pthread_mutex_t) return int;
|
||||
pragma Inline (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);
|
||||
|
||||
--------------------------
|
||||
-- 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 Inline (pthread_mutexattr_setprotocol);
|
||||
|
||||
function pthread_mutexattr_setprioceiling
|
||||
(attr : access pthread_mutexattr_t;
|
||||
prioceiling : int) return int;
|
||||
pragma Inline (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 Inline (pthread_setschedparam);
|
||||
|
||||
function sched_yield return int;
|
||||
pragma Inline (sched_yield);
|
||||
|
||||
function pthread_sched_rr_set_interval (usecs : int) return int;
|
||||
pragma Inline (pthread_sched_rr_set_interval);
|
||||
|
||||
---------------------------
|
||||
-- P1003.1c - Section 16 --
|
||||
---------------------------
|
||||
|
||||
function pthread_attr_init (attr : access pthread_attr_t) return int;
|
||||
pragma Inline (pthread_attr_init);
|
||||
|
||||
function pthread_attr_destroy (attr : access pthread_attr_t) return int;
|
||||
pragma Inline (pthread_attr_destroy);
|
||||
|
||||
function pthread_attr_setdetachstate
|
||||
(attr : access pthread_attr_t;
|
||||
detachstate : int) return int;
|
||||
pragma Inline (pthread_attr_setdetachstate);
|
||||
|
||||
function pthread_attr_setstacksize
|
||||
(attr : access pthread_attr_t;
|
||||
stacksize : size_t) return int;
|
||||
pragma Inline (pthread_attr_setstacksize);
|
||||
|
||||
function pthread_attr_setname_np
|
||||
(attr : access pthread_attr_t;
|
||||
name : System.Address) return int;
|
||||
-- In VxWorks tasks, we have a non-portable routine to set the
|
||||
-- task name. This makes it really convenient for debugging.
|
||||
pragma Inline (pthread_attr_setname_np);
|
||||
|
||||
function pthread_create
|
||||
(thread : access pthread_t;
|
||||
attr : access pthread_attr_t;
|
||||
start_routine : Thread_Body;
|
||||
arg : System.Address) return int;
|
||||
pragma Inline (pthread_create);
|
||||
|
||||
function pthread_detach (thread : pthread_t) return int;
|
||||
pragma Inline (pthread_detach);
|
||||
|
||||
procedure pthread_exit (status : System.Address);
|
||||
pragma Inline (pthread_exit);
|
||||
|
||||
function pthread_self return pthread_t;
|
||||
pragma Inline (pthread_self);
|
||||
|
||||
function pthread_equal (t1 : pthread_t; t2 : pthread_t) return int;
|
||||
pragma Inline (pthread_equal);
|
||||
-- be careful not to use "=" on thread_t!
|
||||
|
||||
--------------------------
|
||||
-- POSIX.1c Section 17 --
|
||||
--------------------------
|
||||
|
||||
function pthread_setspecific
|
||||
(key : pthread_key_t;
|
||||
value : System.Address) return int;
|
||||
pragma Inline (pthread_setspecific);
|
||||
|
||||
function pthread_getspecific (key : pthread_key_t) return System.Address;
|
||||
pragma Inline (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);
|
||||
|
||||
-- VxWorks binary semaphores. These are exported for use by the
|
||||
-- implementation of hardware interrupt handling.
|
||||
function taskPrioritySet
|
||||
(tid : t_id; newPriority : int) return int;
|
||||
pragma Import (C, taskPrioritySet, "taskPrioritySet");
|
||||
|
||||
subtype STATUS is int;
|
||||
-- Equivalent of the C type STATUS
|
||||
|
||||
OK : constant STATUS := 0;
|
||||
ERROR : constant STATUS := Interfaces.C."-" (1);
|
||||
ERROR : constant STATUS := Interfaces.C.int (-1);
|
||||
|
||||
-- Semaphore creation flags.
|
||||
|
||||
@ -462,7 +302,7 @@ package System.OS_Interface is
|
||||
SEM_DELETE_SAFE : constant := 4; -- only valid for binary semaphore
|
||||
SEM_INVERSION_SAFE : constant := 8; -- only valid for binary semaphore
|
||||
|
||||
-- Semaphore initial state flags;
|
||||
-- Semaphore initial state flags
|
||||
|
||||
SEM_EMPTY : constant := 0;
|
||||
SEM_FULL : constant := 1;
|
||||
@ -472,36 +312,57 @@ package System.OS_Interface is
|
||||
WAIT_FOREVER : constant := -1;
|
||||
NO_WAIT : constant := 0;
|
||||
|
||||
type SEM_ID is new long;
|
||||
-- The VxWorks semaphore ID is an integer which is really just
|
||||
-- a pointer to a semaphore structure.
|
||||
-- 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.
|
||||
|
||||
function semBCreate (Options : int; Initial_State : int) return SEM_ID;
|
||||
-- Create a binary semaphore. Returns ID, or 0 if memory could not
|
||||
-- be allocated
|
||||
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 semTake (SemID : SEM_ID; Timeout : int) return STATUS;
|
||||
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 semGive (SemID : SEM_ID) return STATUS;
|
||||
-- Release one thread blocked on the semaphore
|
||||
pragma Import (C, semGive, "semGive");
|
||||
|
||||
function semFlush (SemID : SEM_ID) return STATUS;
|
||||
-- Release all threads blocked on the semaphore
|
||||
pragma Import (C, semFlush, "semFlush");
|
||||
|
||||
function semDelete (SemID : SEM_ID) return STATUS;
|
||||
-- Delete a semaphore
|
||||
pragma Import (C, semDelete, "semDelete");
|
||||
function taskLock return int;
|
||||
pragma Import (C, taskLock, "taskLock");
|
||||
|
||||
function taskUnlock return int;
|
||||
pragma Import (C, taskUnlock, "taskUnlock");
|
||||
|
||||
private
|
||||
-- This interface assumes that "unsigned" and "int" are 32-bit entities.
|
||||
|
||||
type sigset_t is new long;
|
||||
|
||||
type pid_t is new int;
|
||||
@ -511,49 +372,4 @@ private
|
||||
type clockid_t is new int;
|
||||
CLOCK_REALTIME : constant clockid_t := 0;
|
||||
|
||||
-- Priority ceilings are now implemented in the body of
|
||||
-- this package.
|
||||
|
||||
type pthread_mutexattr_t is record
|
||||
Flags : int; -- mutex semaphore creation flags
|
||||
Prio_Ceiling : int; -- priority ceiling
|
||||
Protocol : int;
|
||||
end record;
|
||||
|
||||
type pthread_mutex_t is record
|
||||
Mutex : SEM_ID;
|
||||
Protocol : int;
|
||||
Prio_Ceiling : int; -- priority ceiling of lock
|
||||
end record;
|
||||
|
||||
type pthread_condattr_t is record
|
||||
Flags : int;
|
||||
end record;
|
||||
|
||||
type pthread_cond_t is record
|
||||
Sem : SEM_ID; -- VxWorks semaphore ID
|
||||
Waiting : Integer; -- Number of queued tasks waiting
|
||||
end record;
|
||||
|
||||
type pthread_attr_t is record
|
||||
Stacksize : size_t;
|
||||
Detachstate : int;
|
||||
Priority : int;
|
||||
Taskname : System.Address;
|
||||
end record;
|
||||
|
||||
type pthread_t is new long;
|
||||
|
||||
null_pthread : constant pthread_t := 0;
|
||||
|
||||
type pthread_key_t is new int;
|
||||
|
||||
-- These are to store the pthread_keys that are created with
|
||||
-- pthread_key_create. Currently, we only need one key.
|
||||
|
||||
Key_Storage : array (1 .. 10) of aliased System.Address;
|
||||
Keys_Created : Integer;
|
||||
|
||||
Time_Slice : int;
|
||||
|
||||
end System.OS_Interface;
|
||||
|
||||
@ -1,135 +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 --
|
||||
-- --
|
||||
-- $Revision: 1.13 $
|
||||
-- --
|
||||
-- Copyright (C) 1992-2000 Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 2, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
||||
-- for more details. You should have received a copy of the GNU General --
|
||||
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This is the VxWorks/68k version of this package
|
||||
|
||||
-- This package defines some system dependent parameters for GNAT. These
|
||||
-- are values that are referenced by the runtime library and are therefore
|
||||
-- relevant to the target machine.
|
||||
|
||||
-- The parameters whose value is defined in the spec are not generally
|
||||
-- expected to be changed. If they are changed, it will be necessary to
|
||||
-- recompile the run-time library.
|
||||
|
||||
-- The parameters which are defined by functions can be changed by modifying
|
||||
-- the body of System.Parameters in file s-parame.adb. A change to this body
|
||||
-- requires only rebinding and relinking of the application.
|
||||
|
||||
-- Note: do not introduce any pragma Inline statements into this unit, since
|
||||
-- otherwise the relinking and rebinding capability would be deactivated.
|
||||
|
||||
package System.Parameters is
|
||||
pragma Pure (Parameters);
|
||||
|
||||
---------------------------------------
|
||||
-- Task And Stack Allocation Control --
|
||||
---------------------------------------
|
||||
|
||||
type Task_Storage_Size is new Integer;
|
||||
-- Type used in tasking units for task storage size
|
||||
|
||||
type Size_Type is new Task_Storage_Size;
|
||||
-- Type used to provide task storage size to runtime
|
||||
|
||||
Unspecified_Size : constant Size_Type := Size_Type'First;
|
||||
-- Value used to indicate that no size type is set
|
||||
|
||||
subtype Ratio is Size_Type range -1 .. 100;
|
||||
Dynamic : constant Size_Type := -1;
|
||||
-- Secondary_Stack_Ratio is a constant between 0 and 100 wich
|
||||
-- determines the percentage of the allocate 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 := -1;
|
||||
-- This constant defines the handling of the secondary stack
|
||||
|
||||
Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Ratio = Dynamic;
|
||||
-- Convenient Boolean for testing for dynmaic secondary stack
|
||||
|
||||
function Default_Stack_Size return Size_Type;
|
||||
-- Default task stack size used if none is specified
|
||||
|
||||
function Minimum_Stack_Size return Size_Type;
|
||||
-- Minimum task stack size permitted
|
||||
|
||||
function Adjust_Storage_Size (Size : Size_Type) return Size_Type;
|
||||
-- Given the storage size stored in the TCB, return the Storage_Size
|
||||
-- value required by the RM for the Storage_Size attribute. The
|
||||
-- required adjustment is as follows:
|
||||
--
|
||||
-- when Size = Unspecified_Size, return Default_Stack_Size
|
||||
-- when Size < Minimum_Stack_Size, return Minimum_Stack_Size
|
||||
-- otherwise return given Size
|
||||
|
||||
Stack_Grows_Down : constant Boolean := 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)
|
||||
|
||||
end System.Parameters;
|
||||
@ -5,11 +5,11 @@
|
||||
-- S Y S T E M --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- (VXWORKS Version Alpha, Mips) --
|
||||
-- (VXWORKS Version Alpha) --
|
||||
-- --
|
||||
-- $Revision: 1.14 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- 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 --
|
||||
@ -60,16 +60,16 @@ pragma Pure (System);
|
||||
Max_Mantissa : constant := 63;
|
||||
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
|
||||
|
||||
Tick : constant := Standard'Tick;
|
||||
Tick : constant := 1.0;
|
||||
|
||||
-- Storage-related Declarations
|
||||
|
||||
type Address is private;
|
||||
Null_Address : constant Address;
|
||||
|
||||
Storage_Unit : constant := Standard'Storage_Unit;
|
||||
Word_Size : constant := Standard'Word_Size;
|
||||
Memory_Size : constant := 2 ** Standard'Address_Size;
|
||||
Storage_Unit : constant := 8;
|
||||
Word_Size : constant := 64;
|
||||
Memory_Size : constant := 2 ** 64;
|
||||
|
||||
-- Address comparison
|
||||
|
||||
@ -88,40 +88,26 @@ pragma Pure (System);
|
||||
-- Other System-Dependent Declarations
|
||||
|
||||
type Bit_Order is (High_Order_First, Low_Order_First);
|
||||
Default_Bit_Order : constant Bit_Order :=
|
||||
Bit_Order'Val (Standard'Default_Bit_Order);
|
||||
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;
|
||||
-- 256 is reserved for the VxWorks kernel
|
||||
-- 248 - 255 correspond to hardware interrupt levels 0 .. 7
|
||||
-- 247 is a catchall default "interrupt" priority for signals,
|
||||
-- allowing higher priority than normal tasks, but lower than
|
||||
-- hardware priority levels. Protected Object ceilings can
|
||||
-- override these values.
|
||||
-- 246 is used by the Interrupt_Manager task
|
||||
|
||||
Max_Priority : constant Positive := 245;
|
||||
Max_Interrupt_Priority : constant Positive := 255;
|
||||
|
||||
subtype Any_Priority is Integer
|
||||
range 0 .. Standard'Max_Interrupt_Priority;
|
||||
subtype Any_Priority is Integer range 0 .. 255;
|
||||
subtype Priority is Any_Priority range 0 .. 245;
|
||||
subtype Interrupt_Priority is Any_Priority range 246 .. 255;
|
||||
|
||||
subtype Priority is Any_Priority
|
||||
range 0 .. Standard'Max_Priority;
|
||||
|
||||
-- Functional notation is needed in the following to avoid visibility
|
||||
-- problems when this package is compiled through rtsfind in the middle
|
||||
-- of another compilation.
|
||||
|
||||
subtype Interrupt_Priority is Any_Priority
|
||||
range
|
||||
Standard."+" (Standard'Max_Priority, 1) ..
|
||||
Standard'Max_Interrupt_Priority;
|
||||
|
||||
Default_Priority : constant Priority :=
|
||||
Standard."/" (Standard."+" (Priority'First, Priority'Last), 2);
|
||||
Default_Priority : constant Priority := 122;
|
||||
|
||||
private
|
||||
|
||||
@ -139,19 +125,22 @@ private
|
||||
-- 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;
|
||||
Frontend_Layout : constant Boolean := False;
|
||||
Use_Ada_Main_Program_Name : constant Boolean := True;
|
||||
Stack_Check_Probes : constant Boolean := False;
|
||||
Stack_Check_Default : constant Boolean := False;
|
||||
Denorm : constant Boolean := False;
|
||||
Machine_Rounds : constant Boolean := True;
|
||||
Machine_Overflows : constant Boolean := False;
|
||||
OpenVMS : constant Boolean := False;
|
||||
Signed_Zeros : constant Boolean := True;
|
||||
Fractional_Fixed_Ops : constant Boolean := False;
|
||||
Frontend_Layout : constant Boolean := False;
|
||||
Functions_Return_By_DSP : constant Boolean := False;
|
||||
Long_Shifts_Inlined : constant Boolean := False;
|
||||
High_Integrity_Mode : constant Boolean := False;
|
||||
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;
|
||||
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;
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 2000, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 2000-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- --
|
||||
@ -76,13 +76,9 @@ package body Interfaces.CPP is
|
||||
function To_Type_Specific_Data_Ptr is
|
||||
new Unchecked_Conversion (Address, Type_Specific_Data_Ptr);
|
||||
|
||||
function To_Address is new Unchecked_Conversion (Vtable_Ptr, Address);
|
||||
function To_Address is
|
||||
new Unchecked_Conversion (Type_Specific_Data_Ptr, Address);
|
||||
|
||||
function To_Vtable_Ptr is new Unchecked_Conversion (Tag, Vtable_Ptr);
|
||||
function To_Tag is new Unchecked_Conversion (Vtable_Ptr, Tag);
|
||||
|
||||
---------------------------------------------
|
||||
-- Unchecked Conversions for String Fields --
|
||||
---------------------------------------------
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1996-1999 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1996-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- --
|
||||
@ -35,6 +35,7 @@
|
||||
|
||||
-- This is the Alpha/VMS version.
|
||||
|
||||
with Unchecked_Conversion;
|
||||
package body Interfaces.C_Streams is
|
||||
|
||||
------------
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001, Florida State University --
|
||||
-- Copyright (C) 1991-2002, Florida State University --
|
||||
-- --
|
||||
-- GNARL is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
@ -189,13 +189,6 @@ begin
|
||||
act.sa_mask := Signal_Mask;
|
||||
|
||||
Keep_Unmasked (Abort_Task_Interrupt) := True;
|
||||
Keep_Unmasked (SIGXCPU) := True;
|
||||
Keep_Unmasked (SIGFPE) := True;
|
||||
Result :=
|
||||
sigaction
|
||||
(Signal (SIGFPE), act'Unchecked_Access,
|
||||
old_act'Unchecked_Access);
|
||||
pragma Assert (Result = 0);
|
||||
|
||||
-- By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but at
|
||||
-- the same time, disable the ability of handling this signal via
|
||||
@ -208,18 +201,14 @@ begin
|
||||
Keep_Unmasked (SIGINT) := True;
|
||||
end if;
|
||||
|
||||
for J in
|
||||
Exception_Interrupts'First + 1 .. Exception_Interrupts'Last
|
||||
loop
|
||||
for J in Exception_Interrupts'Range loop
|
||||
Keep_Unmasked (Exception_Interrupts (J)) := True;
|
||||
|
||||
if Unreserve_All_Interrupts = 0 then
|
||||
Result :=
|
||||
sigaction
|
||||
(Signal (Exception_Interrupts (J)), act'Unchecked_Access,
|
||||
old_act'Unchecked_Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
Result :=
|
||||
sigaction
|
||||
(Signal (Exception_Interrupts (J)), act'Unchecked_Access,
|
||||
old_act'Unchecked_Access);
|
||||
pragma Assert (Result = 0);
|
||||
end loop;
|
||||
|
||||
for J in Unmasked'Range loop
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.1 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001, Florida State University --
|
||||
-- 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- --
|
||||
@ -101,15 +101,17 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
package SSL renames System.Soft_Links;
|
||||
|
||||
------------------
|
||||
-- Local Data --
|
||||
------------------
|
||||
----------------
|
||||
-- Local Data --
|
||||
----------------
|
||||
|
||||
-- The followings are logically constants, but need to be initialized
|
||||
-- at run time.
|
||||
|
||||
All_Tasks_L : aliased System.Task_Primitives.RTS_Lock;
|
||||
-- See comments on locking rules in System.Tasking (spec).
|
||||
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.
|
||||
@ -143,8 +145,7 @@ package body System.Task_Primitives.Operations is
|
||||
-- Local Subprograms --
|
||||
-----------------------
|
||||
|
||||
procedure Abort_Handler
|
||||
(Sig : Signal);
|
||||
procedure Abort_Handler (Sig : Signal);
|
||||
|
||||
function To_Task_ID is new Unchecked_Conversion (System.Address, Task_ID);
|
||||
|
||||
@ -252,15 +253,13 @@ package body System.Task_Primitives.Operations is
|
||||
-- Context.PC := Raise_Abort_Signal'Address;
|
||||
-- return;
|
||||
-- end if;
|
||||
|
||||
end Abort_Handler;
|
||||
|
||||
-------------------
|
||||
-- Stack_Guard --
|
||||
-------------------
|
||||
-----------------
|
||||
-- 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;
|
||||
|
||||
@ -304,7 +303,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- Note: mutexes and cond_variables needed per-task basis are
|
||||
-- initialized in Initialize_TCB and the Storage_Error is
|
||||
-- handled. Other mutexes (such as All_Tasks_Lock, Memory_Lock...)
|
||||
-- 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.
|
||||
@ -395,7 +394,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Finalize_Lock (L : access Lock) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_destroy (L);
|
||||
pragma Assert (Result = 0);
|
||||
@ -403,7 +401,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Finalize_Lock (L : access RTS_Lock) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_destroy (L);
|
||||
pragma Assert (Result = 0);
|
||||
@ -415,7 +412,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Write_Lock (L : access Lock; Ceiling_Violation : out Boolean) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_lock (L);
|
||||
|
||||
@ -425,20 +421,24 @@ package body System.Task_Primitives.Operations is
|
||||
pragma Assert (Result = 0 or else Result = EINVAL);
|
||||
end Write_Lock;
|
||||
|
||||
procedure Write_Lock (L : access RTS_Lock) is
|
||||
procedure Write_Lock
|
||||
(L : access RTS_Lock; Global_Lock : Boolean := False)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_lock (L);
|
||||
pragma Assert (Result = 0);
|
||||
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
|
||||
Result := pthread_mutex_lock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutex_lock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
end Write_Lock;
|
||||
|
||||
---------------
|
||||
@ -456,40 +456,46 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
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) is
|
||||
procedure Unlock (L : access RTS_Lock; Global_Lock : Boolean := False) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_unlock (L);
|
||||
pragma Assert (Result = 0);
|
||||
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
|
||||
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutex_unlock (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
end if;
|
||||
end Unlock;
|
||||
|
||||
-------------
|
||||
-- Sleep --
|
||||
-------------
|
||||
-----------
|
||||
-- Sleep --
|
||||
-----------
|
||||
|
||||
procedure Sleep (Self_ID : Task_ID;
|
||||
Reason : System.Tasking.Task_States) is
|
||||
procedure Sleep
|
||||
(Self_ID : Task_ID;
|
||||
Reason : System.Tasking.Task_States)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
pragma Assert (Self_ID = Self);
|
||||
Result := pthread_cond_wait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access);
|
||||
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.
|
||||
|
||||
@ -548,8 +554,16 @@ package body System.Task_Primitives.Operations is
|
||||
exit when Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level
|
||||
or else Self_ID.Pending_Priority_Change;
|
||||
|
||||
Result := pthread_cond_timedwait (Self_ID.Common.LL.CV'Access,
|
||||
Self_ID.Common.LL.L'Access, Request'Access);
|
||||
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;
|
||||
|
||||
@ -591,6 +605,11 @@ package body System.Task_Primitives.Operations is
|
||||
-- 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
|
||||
@ -626,8 +645,14 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
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);
|
||||
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
|
||||
@ -639,6 +664,11 @@ package body System.Task_Primitives.Operations is
|
||||
end if;
|
||||
|
||||
Unlock (Self_ID);
|
||||
|
||||
if Single_Lock then
|
||||
Unlock_RTS;
|
||||
end if;
|
||||
|
||||
Result := sched_yield;
|
||||
SSL.Abort_Undefer.all;
|
||||
end Timed_Delay;
|
||||
@ -673,7 +703,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Wakeup (T : Task_ID; Reason : System.Tasking.Task_States) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_cond_signal (T.Common.LL.CV'Access);
|
||||
pragma Assert (Result = 0);
|
||||
@ -685,7 +714,6 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
procedure Yield (Do_Yield : Boolean := True) is
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
if Do_Yield then
|
||||
Result := sched_yield;
|
||||
@ -697,8 +725,8 @@ package body System.Task_Primitives.Operations is
|
||||
------------------
|
||||
|
||||
procedure Set_Priority
|
||||
(T : Task_ID;
|
||||
Prio : System.Any_Priority;
|
||||
(T : Task_ID;
|
||||
Prio : System.Any_Priority;
|
||||
Loss_Of_Inheritance : Boolean := False)
|
||||
is
|
||||
Result : Interfaces.C.int;
|
||||
@ -744,17 +772,17 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
Specific.Set (Self_ID);
|
||||
|
||||
Lock_All_Tasks_List;
|
||||
Lock_RTS;
|
||||
|
||||
for I in Known_Tasks'Range loop
|
||||
if Known_Tasks (I) = null then
|
||||
Known_Tasks (I) := Self_ID;
|
||||
Self_ID.Known_Tasks_Index := I;
|
||||
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_All_Tasks_List;
|
||||
Unlock_RTS;
|
||||
end Enter_Task;
|
||||
|
||||
--------------
|
||||
@ -772,8 +800,8 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
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;
|
||||
Result : Interfaces.C.int;
|
||||
Cond_Attr : aliased pthread_condattr_t;
|
||||
|
||||
begin
|
||||
-- Give the task a unique serial number.
|
||||
@ -782,53 +810,50 @@ package body System.Task_Primitives.Operations is
|
||||
Next_Serial_Number := Next_Serial_Number + 1;
|
||||
pragma Assert (Next_Serial_Number /= 0);
|
||||
|
||||
Result := pthread_mutexattr_init (Mutex_Attr'Access);
|
||||
pragma Assert (Result = 0 or else Result = ENOMEM);
|
||||
if not Single_Lock then
|
||||
Result := pthread_mutexattr_init (Mutex_Attr'Access);
|
||||
pragma Assert (Result = 0 or else Result = ENOMEM);
|
||||
|
||||
if Result /= 0 then
|
||||
Succeeded := False;
|
||||
return;
|
||||
if Result = 0 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);
|
||||
|
||||
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_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);
|
||||
|
||||
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;
|
||||
|
||||
Result := pthread_mutexattr_destroy (Mutex_Attr'Access);
|
||||
pragma Assert (Result = 0);
|
||||
|
||||
Result := pthread_condattr_init (Cond_Attr'Access);
|
||||
pragma Assert (Result = 0 or else Result = ENOMEM);
|
||||
|
||||
if Result /= 0 then
|
||||
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
Succeeded := False;
|
||||
return;
|
||||
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;
|
||||
|
||||
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
|
||||
Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
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;
|
||||
|
||||
@ -936,8 +961,10 @@ package body System.Task_Primitives.Operations is
|
||||
Unchecked_Deallocation (Ada_Task_Control_Block, Task_ID);
|
||||
|
||||
begin
|
||||
Result := pthread_mutex_destroy (T.Common.LL.L'Access);
|
||||
pragma Assert (Result = 0);
|
||||
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);
|
||||
@ -1001,23 +1028,23 @@ package body System.Task_Primitives.Operations is
|
||||
return Environment_Task_ID;
|
||||
end Environment_Task;
|
||||
|
||||
-------------------------
|
||||
-- Lock_All_Tasks_List --
|
||||
-------------------------
|
||||
--------------
|
||||
-- Lock_RTS --
|
||||
--------------
|
||||
|
||||
procedure Lock_All_Tasks_List is
|
||||
procedure Lock_RTS is
|
||||
begin
|
||||
Write_Lock (All_Tasks_L'Access);
|
||||
end Lock_All_Tasks_List;
|
||||
Write_Lock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Lock_RTS;
|
||||
|
||||
---------------------------
|
||||
-- Unlock_All_Tasks_List --
|
||||
---------------------------
|
||||
----------------
|
||||
-- Unlock_RTS --
|
||||
----------------
|
||||
|
||||
procedure Unlock_All_Tasks_List is
|
||||
procedure Unlock_RTS is
|
||||
begin
|
||||
Unlock (All_Tasks_L'Access);
|
||||
end Unlock_All_Tasks_List;
|
||||
Unlock (Single_RTS_Lock'Access, Global_Lock => True);
|
||||
end Unlock_RTS;
|
||||
|
||||
------------------
|
||||
-- Suspend_Task --
|
||||
@ -1056,7 +1083,7 @@ package body System.Task_Primitives.Operations is
|
||||
|
||||
-- Initialize the lock used to synchronize chain of all ATCBs.
|
||||
|
||||
Initialize_Lock (All_Tasks_L'Access, All_Tasks_Level);
|
||||
Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level);
|
||||
|
||||
Specific.Initialize (Environment_Task);
|
||||
|
||||
@ -1083,7 +1110,6 @@ package body System.Task_Primitives.Operations is
|
||||
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
|
||||
@ -1104,5 +1130,4 @@ begin
|
||||
end if;
|
||||
end loop;
|
||||
end;
|
||||
|
||||
end System.Task_Primitives.Operations;
|
||||
|
||||
@ -2,14 +2,13 @@
|
||||
-- --
|
||||
-- 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 . --
|
||||
-- S P E C I F I C --
|
||||
-- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC --
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.1 $ --
|
||||
-- $Revision$ --
|
||||
-- --
|
||||
-- Copyright (C) 1991-1998, Florida State University --
|
||||
-- Copyright (C) 1991-2001, Florida State University --
|
||||
-- --
|
||||
-- GNARL is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
@ -68,7 +67,7 @@ package body Specific is
|
||||
---------
|
||||
|
||||
procedure Set (Self_Id : Task_ID) is
|
||||
Result : Interfaces.C.int;
|
||||
Result : Interfaces.C.int;
|
||||
|
||||
begin
|
||||
Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id));
|
||||
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.1 $ --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
@ -33,6 +33,8 @@
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- Version for ???
|
||||
|
||||
with Unchecked_Deallocation;
|
||||
with Ada.Streams;
|
||||
|
||||
@ -43,6 +45,10 @@ pragma Elaborate (System.RPC.Garlic);
|
||||
|
||||
package body System.RPC is
|
||||
|
||||
-- ??? general note: the debugging calls are very heavy, especially
|
||||
-- those that create exception handlers in every procedure. Do we
|
||||
-- really still need all this stuff?
|
||||
|
||||
use type Ada.Streams.Stream_Element_Count;
|
||||
use type Ada.Streams.Stream_Element_Offset;
|
||||
|
||||
@ -52,7 +58,7 @@ package body System.RPC is
|
||||
Max_Of_Message_Id : constant := 127;
|
||||
|
||||
subtype Message_Id_Type is
|
||||
Integer range -Max_Of_Message_Id .. Max_Of_Message_Id;
|
||||
Integer range -Max_Of_Message_Id .. Max_Of_Message_Id;
|
||||
-- A message id is either a request id or reply id. A message id is
|
||||
-- provided with a message to a receiving stub which uses the opposite
|
||||
-- as a reply id. A message id helps to retrieve to which task is
|
||||
@ -67,9 +73,9 @@ package body System.RPC is
|
||||
type Message_Length_Per_Request is array (Request_Id_Type)
|
||||
of Ada.Streams.Stream_Element_Count;
|
||||
|
||||
Header_Size : Ada.Streams.Stream_Element_Count
|
||||
:= Streams.Get_Integer_Initial_Size +
|
||||
Streams.Get_SEC_Initial_Size;
|
||||
Header_Size : Ada.Streams.Stream_Element_Count :=
|
||||
Streams.Get_Integer_Initial_Size +
|
||||
Streams.Get_SEC_Initial_Size;
|
||||
-- Initial size needed for frequently used header streams
|
||||
|
||||
Stream_Error : exception;
|
||||
@ -94,33 +100,30 @@ package body System.RPC is
|
||||
Params_Size : in Ada.Streams.Stream_Element_Count;
|
||||
Result_Size : in Ada.Streams.Stream_Element_Count;
|
||||
Protocol : in Garlic.Protocol_Access);
|
||||
-- This entry provides an anonymous task a remote call to perform
|
||||
-- This task calls for a
|
||||
-- Request id is provided to construct the reply id by using
|
||||
-- -Request. Partition is used to send the reply message. Params_Size
|
||||
-- is the size of the calling stub Params stream. Then, Protocol
|
||||
-- (used by the environment task previously) allows to extract the
|
||||
-- message following the header (The header is extracted by the
|
||||
-- environment task)
|
||||
-- This entry provides an anonymous task a remote call to perform.
|
||||
-- This task calls for a Request id is provided to construct the
|
||||
-- reply id by using -Request. Partition is used to send the reply
|
||||
-- message. Params_Size is the size of the calling stub Params stream.
|
||||
-- Then Protocol (used by the environment task previously) allows
|
||||
-- extraction of the message following the header (The header is
|
||||
-- extracted by the environment task)
|
||||
-- Note: grammar in above is obscure??? needs cleanup
|
||||
|
||||
end Anonymous_Task_Type;
|
||||
|
||||
type Anonymous_Task_Access is access Anonymous_Task_Type;
|
||||
|
||||
type Anonymous_Task_List is
|
||||
record
|
||||
Head : Anonymous_Task_Node_Access;
|
||||
Tail : Anonymous_Task_Node_Access;
|
||||
end record;
|
||||
type Anonymous_Task_List is record
|
||||
Head : Anonymous_Task_Node_Access;
|
||||
Tail : Anonymous_Task_Node_Access;
|
||||
end record;
|
||||
|
||||
type Anonymous_Task_Node is
|
||||
record
|
||||
Element : Anonymous_Task_Access;
|
||||
Next : Anonymous_Task_Node_Access;
|
||||
end record;
|
||||
-- Types we need to construct a singly linked list of anonymous tasks
|
||||
-- This pool is maintained to avoid a task creation each time a RPC
|
||||
-- occurs
|
||||
type Anonymous_Task_Node is record
|
||||
Element : Anonymous_Task_Access;
|
||||
Next : Anonymous_Task_Node_Access;
|
||||
end record;
|
||||
-- Types we need to construct a singly linked list of anonymous tasks.
|
||||
-- This pool is maintained to avoid a task creation each time a RPC occurs.
|
||||
|
||||
protected Garbage_Collector is
|
||||
|
||||
@ -133,6 +136,7 @@ package body System.RPC is
|
||||
(Item : in out Anonymous_Task_Node_Access);
|
||||
-- Anonymous task pool management : queue this task in the pool
|
||||
-- of inactive anonymous tasks.
|
||||
|
||||
private
|
||||
|
||||
Anonymous_List : Anonymous_Task_Node_Access;
|
||||
@ -230,13 +234,16 @@ package body System.RPC is
|
||||
---------------
|
||||
|
||||
procedure Head_Node
|
||||
(Index : out Packet_Node_Access;
|
||||
Stream : in Params_Stream_Type) is
|
||||
(Index : out Packet_Node_Access;
|
||||
Stream : Params_Stream_Type)
|
||||
is
|
||||
begin
|
||||
Index := Stream.Extra.Head;
|
||||
exception when others =>
|
||||
D (D_Exception, "exception in Head_Node");
|
||||
raise;
|
||||
|
||||
exception
|
||||
when others =>
|
||||
D (D_Exception, "exception in Head_Node");
|
||||
raise;
|
||||
end Head_Node;
|
||||
|
||||
---------------
|
||||
@ -244,34 +251,37 @@ package body System.RPC is
|
||||
---------------
|
||||
|
||||
procedure Tail_Node
|
||||
(Index : out Packet_Node_Access;
|
||||
Stream : in Params_Stream_Type) is
|
||||
(Index : out Packet_Node_Access;
|
||||
Stream : Params_Stream_Type)
|
||||
is
|
||||
begin
|
||||
Index := Stream.Extra.Tail;
|
||||
exception when others =>
|
||||
D (D_Exception, "exception in Tail_Node");
|
||||
raise;
|
||||
|
||||
exception
|
||||
when others =>
|
||||
D (D_Exception, "exception in Tail_Node");
|
||||
raise;
|
||||
end Tail_Node;
|
||||
|
||||
---------------
|
||||
-- Null_Node --
|
||||
---------------
|
||||
|
||||
function Null_Node
|
||||
(Index : in Packet_Node_Access) return Boolean is
|
||||
function Null_Node (Index : in Packet_Node_Access) return Boolean is
|
||||
begin
|
||||
return Index = null;
|
||||
exception when others =>
|
||||
D (D_Exception, "exception in Null_Node");
|
||||
raise;
|
||||
|
||||
exception
|
||||
when others =>
|
||||
D (D_Exception, "exception in Null_Node");
|
||||
raise;
|
||||
end Null_Node;
|
||||
|
||||
----------------------
|
||||
-- Delete_Head_Node --
|
||||
----------------------
|
||||
|
||||
procedure Delete_Head_Node
|
||||
(Stream : in out Params_Stream_Type) is
|
||||
procedure Delete_Head_Node (Stream : in out Params_Stream_Type) is
|
||||
|
||||
procedure Free is
|
||||
new Unchecked_Deallocation
|
||||
@ -280,7 +290,6 @@ package body System.RPC is
|
||||
Next_Node : Packet_Node_Access := Stream.Extra.Head.Next;
|
||||
|
||||
begin
|
||||
|
||||
-- Delete head node and free memory usage
|
||||
|
||||
Free (Stream.Extra.Head);
|
||||
@ -292,19 +301,18 @@ package body System.RPC is
|
||||
Stream.Extra.Tail := null;
|
||||
end if;
|
||||
|
||||
exception when others =>
|
||||
D (D_Exception, "exception in Delete_Head_Node");
|
||||
raise;
|
||||
exception
|
||||
when others =>
|
||||
D (D_Exception, "exception in Delete_Head_Node");
|
||||
raise;
|
||||
end Delete_Head_Node;
|
||||
|
||||
---------------
|
||||
-- Next_Node --
|
||||
---------------
|
||||
|
||||
procedure Next_Node
|
||||
(Node : in out Packet_Node_Access) is
|
||||
procedure Next_Node (Node : in out Packet_Node_Access) is
|
||||
begin
|
||||
|
||||
-- Node is set to the next node
|
||||
-- If not possible, Stream_Error is raised
|
||||
|
||||
@ -314,20 +322,20 @@ package body System.RPC is
|
||||
Node := Node.Next;
|
||||
end if;
|
||||
|
||||
exception when others =>
|
||||
D (D_Exception, "exception in Next_Node");
|
||||
raise;
|
||||
exception
|
||||
when others =>
|
||||
D (D_Exception, "exception in Next_Node");
|
||||
raise;
|
||||
end Next_Node;
|
||||
|
||||
---------------------
|
||||
-- Append_New_Node --
|
||||
---------------------
|
||||
|
||||
procedure Append_New_Node
|
||||
(Stream : in out Params_Stream_Type) is
|
||||
procedure Append_New_Node (Stream : in out Params_Stream_Type) is
|
||||
Index : Packet_Node_Access;
|
||||
begin
|
||||
|
||||
begin
|
||||
-- Set Index to the end of the linked list
|
||||
|
||||
Tail_Node (Index, Stream);
|
||||
@ -340,7 +348,6 @@ package body System.RPC is
|
||||
Stream.Extra.Tail := Stream.Extra.Head;
|
||||
|
||||
else
|
||||
|
||||
-- The list is not empty : link new node with tail
|
||||
|
||||
Stream.Extra.Tail.Next := new Packet_Node;
|
||||
@ -348,9 +355,10 @@ package body System.RPC is
|
||||
|
||||
end if;
|
||||
|
||||
exception when others =>
|
||||
D (D_Exception, "exception in Append_New_Node");
|
||||
raise;
|
||||
exception
|
||||
when others =>
|
||||
D (D_Exception, "exception in Append_New_Node");
|
||||
raise;
|
||||
end Append_New_Node;
|
||||
|
||||
----------
|
||||
@ -360,8 +368,8 @@ package body System.RPC is
|
||||
procedure Read
|
||||
(Stream : in out Params_Stream_Type;
|
||||
Item : out Ada.Streams.Stream_Element_Array;
|
||||
Last : out Ada.Streams.Stream_Element_Offset) renames
|
||||
System.RPC.Streams.Read;
|
||||
Last : out Ada.Streams.Stream_Element_Offset)
|
||||
renames System.RPC.Streams.Read;
|
||||
|
||||
-----------
|
||||
-- Write --
|
||||
@ -369,8 +377,8 @@ package body System.RPC is
|
||||
|
||||
procedure Write
|
||||
(Stream : in out Params_Stream_Type;
|
||||
Item : in Ada.Streams.Stream_Element_Array) renames
|
||||
System.RPC.Streams.Write;
|
||||
Item : in Ada.Streams.Stream_Element_Array)
|
||||
renames System.RPC.Streams.Write;
|
||||
|
||||
-----------------------
|
||||
-- Garbage_Collector --
|
||||
@ -382,12 +390,11 @@ package body System.RPC is
|
||||
-- Garbage_Collector.Allocate --
|
||||
--------------------------------
|
||||
|
||||
procedure Allocate
|
||||
(Item : out Anonymous_Task_Node_Access) is
|
||||
procedure Allocate (Item : out Anonymous_Task_Node_Access) is
|
||||
New_Anonymous_Task_Node : Anonymous_Task_Node_Access;
|
||||
Anonymous_Task : Anonymous_Task_Access;
|
||||
begin
|
||||
|
||||
begin
|
||||
-- If the list is empty, allocate a new anonymous task
|
||||
-- Otherwise, reuse the first queued anonymous task
|
||||
|
||||
@ -404,7 +411,6 @@ package body System.RPC is
|
||||
New_Anonymous_Task_Node.all := (Anonymous_Task, null);
|
||||
|
||||
else
|
||||
|
||||
-- Extract one task from the list
|
||||
-- Set the Next field to null to avoid possible bugs
|
||||
|
||||
@ -418,27 +424,27 @@ package body System.RPC is
|
||||
|
||||
Item := New_Anonymous_Task_Node;
|
||||
|
||||
exception when others =>
|
||||
D (D_Exception, "exception in Allocate (Anonymous Task)");
|
||||
raise;
|
||||
exception
|
||||
when others =>
|
||||
D (D_Exception, "exception in Allocate (Anonymous Task)");
|
||||
raise;
|
||||
end Allocate;
|
||||
|
||||
----------------------------------
|
||||
-- Garbage_Collector.Deallocate --
|
||||
----------------------------------
|
||||
|
||||
procedure Deallocate
|
||||
(Item : in out Anonymous_Task_Node_Access) is
|
||||
procedure Deallocate (Item : in out Anonymous_Task_Node_Access) is
|
||||
begin
|
||||
|
||||
-- Enqueue the task in the free list
|
||||
|
||||
Item.Next := Anonymous_List;
|
||||
Anonymous_List := Item;
|
||||
|
||||
exception when others =>
|
||||
D (D_Exception, "exception in Deallocate (Anonymous Task)");
|
||||
raise;
|
||||
exception
|
||||
when others =>
|
||||
D (D_Exception, "exception in Deallocate (Anonymous Task)");
|
||||
raise;
|
||||
end Deallocate;
|
||||
|
||||
end Garbage_Collector;
|
||||
@ -448,15 +454,16 @@ package body System.RPC is
|
||||
------------
|
||||
|
||||
procedure Do_RPC
|
||||
(Partition : in Partition_ID;
|
||||
(Partition : Partition_ID;
|
||||
Params : access Params_Stream_Type;
|
||||
Result : access Params_Stream_Type) is
|
||||
Result : access Params_Stream_Type)
|
||||
is
|
||||
Protocol : Protocol_Access;
|
||||
Request : Request_Id_Type;
|
||||
Header : aliased Params_Stream_Type (Header_Size);
|
||||
R_Length : Ada.Streams.Stream_Element_Count;
|
||||
begin
|
||||
|
||||
begin
|
||||
-- Parameters order :
|
||||
-- Opcode (provided and used by garlic)
|
||||
-- (1) Size (provided by s-rpc and used by garlic)
|
||||
@ -538,7 +545,6 @@ package body System.RPC is
|
||||
declare
|
||||
New_Result : aliased Params_Stream_Type (R_Length);
|
||||
begin
|
||||
|
||||
-- Adjust the Result stream size right now to be able to load
|
||||
-- the stream in one receive call. Create a temporary resutl
|
||||
-- that will be substituted to Do_RPC one
|
||||
@ -570,7 +576,6 @@ package body System.RPC is
|
||||
end;
|
||||
|
||||
else
|
||||
|
||||
-- Do RPC locally and first wait for Partition_RPC_Receiver to be
|
||||
-- set
|
||||
|
||||
@ -580,9 +585,10 @@ package body System.RPC is
|
||||
|
||||
end if;
|
||||
|
||||
exception when others =>
|
||||
D (D_Exception, "exception in Do_RPC");
|
||||
raise;
|
||||
exception
|
||||
when others =>
|
||||
D (D_Exception, "exception in Do_RPC");
|
||||
raise;
|
||||
end Do_RPC;
|
||||
|
||||
------------
|
||||
@ -590,13 +596,14 @@ package body System.RPC is
|
||||
------------
|
||||
|
||||
procedure Do_APC
|
||||
(Partition : in Partition_ID;
|
||||
Params : access Params_Stream_Type) is
|
||||
(Partition : Partition_ID;
|
||||
Params : access Params_Stream_Type)
|
||||
is
|
||||
Message_Id : Message_Id_Type := 0;
|
||||
Protocol : Protocol_Access;
|
||||
Header : aliased Params_Stream_Type (Header_Size);
|
||||
begin
|
||||
|
||||
begin
|
||||
-- For more informations, see above
|
||||
-- Request = 0 as we are not waiting for a reply message
|
||||
-- Result length = 0 as we don't expect a result at all
|
||||
@ -660,7 +667,6 @@ package body System.RPC is
|
||||
declare
|
||||
Result : aliased Params_Stream_Type (0);
|
||||
begin
|
||||
|
||||
-- Result is here a dummy parameter
|
||||
-- No reason to deallocate as it is not allocated at all
|
||||
|
||||
@ -672,29 +678,31 @@ package body System.RPC is
|
||||
|
||||
end if;
|
||||
|
||||
exception when others =>
|
||||
D (D_Exception, "exception in Do_APC");
|
||||
raise;
|
||||
exception
|
||||
when others =>
|
||||
D (D_Exception, "exception in Do_APC");
|
||||
raise;
|
||||
end Do_APC;
|
||||
|
||||
----------------------------
|
||||
-- Establish_RPC_Receiver --
|
||||
----------------------------
|
||||
|
||||
procedure Establish_RPC_Receiver (
|
||||
Partition : in Partition_ID;
|
||||
Receiver : in RPC_Receiver) is
|
||||
procedure Establish_RPC_Receiver
|
||||
(Partition : in Partition_ID;
|
||||
Receiver : in RPC_Receiver)
|
||||
is
|
||||
begin
|
||||
|
||||
-- Set Partition_RPC_Receiver and allow RPC mechanism
|
||||
|
||||
Partition_RPC_Receiver := Receiver;
|
||||
Partition_Receiver.Set;
|
||||
D (D_Elaborate, "Partition_Receiver is set");
|
||||
|
||||
exception when others =>
|
||||
D (D_Exception, "exception in Establish_RPC_Receiver");
|
||||
raise;
|
||||
exception
|
||||
when others =>
|
||||
D (D_Exception, "exception in Establish_RPC_Receiver");
|
||||
raise;
|
||||
end Establish_RPC_Receiver;
|
||||
|
||||
----------------
|
||||
@ -705,24 +713,24 @@ package body System.RPC is
|
||||
Last_Request : Request_Id_Type := Request_Id_Type'First;
|
||||
Current_Rqst : Request_Id_Type := Request_Id_Type'First;
|
||||
Current_Size : Ada.Streams.Stream_Element_Count;
|
||||
|
||||
begin
|
||||
|
||||
loop
|
||||
-- Three services:
|
||||
|
||||
-- Three services :
|
||||
-- New_Request to get an entry in Dispatcher table
|
||||
-- Wait_On for Do_RPC calls
|
||||
-- Wake_Up called by environment task when a Do_RPC receives
|
||||
-- the result of its remote call
|
||||
-- New_Request to get an entry in Dispatcher table
|
||||
|
||||
-- Wait_On for Do_RPC calls
|
||||
|
||||
-- Wake_Up called by environment task when a Do_RPC receives
|
||||
-- the result of its remote call
|
||||
|
||||
select
|
||||
|
||||
accept New_Request
|
||||
(Request : out Request_Id_Type) do
|
||||
accept New_Request (Request : out Request_Id_Type) do
|
||||
Request := Last_Request;
|
||||
|
||||
-- << TODO >>
|
||||
-- Avaibility check
|
||||
-- ??? Avaibility check
|
||||
|
||||
if Last_Request = Request_Id_Type'Last then
|
||||
Last_Request := Request_Id_Type'First;
|
||||
@ -733,11 +741,10 @@ package body System.RPC is
|
||||
end New_Request;
|
||||
|
||||
or
|
||||
|
||||
accept Wake_Up
|
||||
(Request : in Request_Id_Type;
|
||||
Length : in Ada.Streams.Stream_Element_Count) do
|
||||
|
||||
(Request : Request_Id_Type;
|
||||
Length : Ada.Streams.Stream_Element_Count)
|
||||
do
|
||||
-- The environment reads the header and has been notified
|
||||
-- of the reply id and the size of the result message
|
||||
|
||||
@ -747,17 +754,17 @@ package body System.RPC is
|
||||
end Wake_Up;
|
||||
|
||||
-- << TODO >>
|
||||
-- Must be select with delay for aborted tasks
|
||||
-- ??? Must be select with delay for aborted tasks
|
||||
|
||||
select
|
||||
|
||||
accept Wait_On (Current_Rqst)
|
||||
(Length : out Ada.Streams.Stream_Element_Count) do
|
||||
(Length : out Ada.Streams.Stream_Element_Count)
|
||||
do
|
||||
Length := Current_Size;
|
||||
end Wait_On;
|
||||
|
||||
or
|
||||
|
||||
-- To free the Dispatcher when a task is aborted
|
||||
|
||||
delay 1.0;
|
||||
@ -765,16 +772,15 @@ package body System.RPC is
|
||||
end select;
|
||||
|
||||
or
|
||||
|
||||
terminate;
|
||||
|
||||
end select;
|
||||
|
||||
end loop;
|
||||
|
||||
exception when others =>
|
||||
D (D_Exception, "exception in Dispatcher body");
|
||||
raise;
|
||||
exception
|
||||
when others =>
|
||||
D (D_Exception, "exception in Dispatcher body");
|
||||
raise;
|
||||
end Dispatcher;
|
||||
|
||||
-------------------------
|
||||
@ -788,10 +794,9 @@ package body System.RPC is
|
||||
Params_S : Ada.Streams.Stream_Element_Count; -- Params message size
|
||||
Result_S : Ada.Streams.Stream_Element_Count; -- Result message size
|
||||
C_Protocol : Protocol_Access; -- Current Protocol
|
||||
|
||||
begin
|
||||
|
||||
loop
|
||||
|
||||
-- Get a new RPC to execute
|
||||
|
||||
select
|
||||
@ -800,7 +805,8 @@ package body System.RPC is
|
||||
Partition : in Partition_ID;
|
||||
Params_Size : in Ada.Streams.Stream_Element_Count;
|
||||
Result_Size : in Ada.Streams.Stream_Element_Count;
|
||||
Protocol : in Protocol_Access) do
|
||||
Protocol : in Protocol_Access)
|
||||
do
|
||||
C_Message_Id := Message_Id;
|
||||
C_Partition := Partition;
|
||||
Params_S := Params_Size;
|
||||
@ -812,11 +818,11 @@ package body System.RPC is
|
||||
end select;
|
||||
|
||||
declare
|
||||
Params : aliased Params_Stream_Type (Params_S);
|
||||
Result : aliased Params_Stream_Type (Result_S);
|
||||
Header : aliased Params_Stream_Type (Header_Size);
|
||||
begin
|
||||
Params : aliased Params_Stream_Type (Params_S);
|
||||
Result : aliased Params_Stream_Type (Result_S);
|
||||
Header : aliased Params_Stream_Type (Header_Size);
|
||||
|
||||
begin
|
||||
-- We reconstruct all the client context : Params and Result
|
||||
-- with the SAME size, then we receive Params from calling stub
|
||||
|
||||
@ -863,7 +869,6 @@ package body System.RPC is
|
||||
(Header'Access,
|
||||
Streams.Get_Stream_Size (Result'Access));
|
||||
|
||||
|
||||
-- Get a protocol method to comunicate with the remote
|
||||
-- partition and give the message size
|
||||
|
||||
@ -903,12 +908,10 @@ package body System.RPC is
|
||||
(C_Protocol.all,
|
||||
C_Partition);
|
||||
Streams.Deallocate (Header);
|
||||
|
||||
end if;
|
||||
|
||||
Streams.Deallocate (Params);
|
||||
Streams.Deallocate (Result);
|
||||
|
||||
end;
|
||||
|
||||
-- Enqueue into the anonymous task free list : become inactive
|
||||
@ -917,9 +920,10 @@ package body System.RPC is
|
||||
|
||||
end loop;
|
||||
|
||||
exception when others =>
|
||||
D (D_Exception, "exception in Anonymous_Task_Type body");
|
||||
raise;
|
||||
exception
|
||||
when others =>
|
||||
D (D_Exception, "exception in Anonymous_Task_Type body");
|
||||
raise;
|
||||
end Anonymous_Task_Type;
|
||||
|
||||
-----------------
|
||||
@ -934,15 +938,14 @@ package body System.RPC is
|
||||
Header : aliased Params_Stream_Type (Header_Size);
|
||||
Protocol : Protocol_Access;
|
||||
Anonymous : Anonymous_Task_Node_Access;
|
||||
begin
|
||||
|
||||
begin
|
||||
-- Wait the Partition_RPC_Receiver to be set
|
||||
|
||||
accept Start;
|
||||
D (D_Elaborate, "Environment task elaborated");
|
||||
|
||||
loop
|
||||
|
||||
-- We receive first a fixed size message : the header
|
||||
-- Header = Message Id + Message Size
|
||||
|
||||
@ -952,10 +955,10 @@ package body System.RPC is
|
||||
-- protocol to use to communicate with the calling partition
|
||||
|
||||
Garlic.Initiate_Receive
|
||||
(Partition,
|
||||
Message_Size,
|
||||
Protocol,
|
||||
Garlic.Remote_Call);
|
||||
(Partition,
|
||||
Message_Size,
|
||||
Protocol,
|
||||
Garlic.Remote_Call);
|
||||
D (D_Communication,
|
||||
"Environment task - Receive protocol to talk to active partition" &
|
||||
Partition_ID'Image (Partition));
|
||||
@ -968,9 +971,9 @@ package body System.RPC is
|
||||
"Environment task - Receive Header from partition" &
|
||||
Partition_ID'Image (Partition));
|
||||
Garlic.Receive
|
||||
(Protocol.all,
|
||||
Partition,
|
||||
Header'Access);
|
||||
(Protocol.all,
|
||||
Partition,
|
||||
Header'Access);
|
||||
|
||||
-- Evaluate the remaining size of the message
|
||||
|
||||
@ -1001,7 +1004,6 @@ package body System.RPC is
|
||||
Dispatcher.Wake_Up (-Message_Id, Result_Size);
|
||||
|
||||
else
|
||||
|
||||
-- The message was send by a calling stub : get an anonymous
|
||||
-- task to perform the job
|
||||
|
||||
@ -1027,13 +1029,13 @@ package body System.RPC is
|
||||
|
||||
end loop;
|
||||
|
||||
exception when others =>
|
||||
D (D_Exception, "exception in Environment");
|
||||
raise;
|
||||
exception
|
||||
when others =>
|
||||
D (D_Exception, "exception in Environment");
|
||||
raise;
|
||||
end Environnement;
|
||||
|
||||
begin
|
||||
|
||||
-- Set debugging information
|
||||
|
||||
Debugging.Set_Environment_Variable ("RPC");
|
||||
|
||||
@ -1,3 +1,117 @@
|
||||
2002-03-07 Geert Bosch <bosch@gnat.com>
|
||||
|
||||
* 41intnam.ads, 42intnam.ads, 4aintnam.ads, 4cintnam.ads,
|
||||
4dintnam.ads, 4gintnam.ads, 4hintnam.ads, 4lintnam.ads,
|
||||
4mintnam.ads, 4pintnam.ads, 4rintnam.ads, 4sintnam.ads,
|
||||
4uintnam.ads, 4vcalend.adb, 4zintnam.ads, 52system.ads,
|
||||
5amastop.adb, 5asystem.ads, 5ataprop.adb, 5atpopsp.adb,
|
||||
5avxwork.ads, 5bosinte.adb, 5bsystem.ads, 5esystem.ads,
|
||||
5fsystem.ads, 5ftaprop.adb, 5ginterr.adb, 5gmastop.adb,
|
||||
5gsystem.ads, 5gtaprop.adb, 5gtasinf.adb, 5gtasinf.ads,
|
||||
5hparame.ads, 5hsystem.ads, 5htaprop.adb, 5htraceb.adb,
|
||||
5itaprop.adb, 5ksystem.ads, 5kvxwork.ads, 5lintman.adb,
|
||||
5lsystem.ads, 5mvxwork.ads, 5ninmaop.adb, 5nosinte.ads,
|
||||
5ntaprop.adb, 5ointerr.adb, 5omastop.adb, 5oosinte.adb,
|
||||
5osystem.ads, 5otaprop.adb, 5otaspri.ads, 5pvxwork.ads,
|
||||
5qtaprop.adb, 5sintman.adb, 5ssystem.ads, 5staprop.adb,
|
||||
5stpopse.adb, 5svxwork.ads, 5tosinte.ads, 5uintman.adb,
|
||||
5vasthan.adb, 5vinmaop.adb, 5vinterr.adb, 5vintman.adb,
|
||||
5vmastop.adb, 5vparame.ads, 5vsystem.ads, 5vtaprop.adb,
|
||||
5vtpopde.adb, 5wmemory.adb, 5wsystem.ads, 5wtaprop.adb,
|
||||
5ysystem.ads, 5zinterr.adb, 5zintman.adb, 5zosinte.adb,
|
||||
5zosinte.ads, 5zsystem.ads, 5ztaprop.adb, 6vcpp.adb, 6vcstrea.adb,
|
||||
7sintman.adb, 7staprop.adb, 7stpopsp.adb, 9drpc.adb,
|
||||
Make-lang.in, Makefile.in, a-caldel.adb, a-comlin.ads,
|
||||
a-dynpri.adb, a-except.adb, a-except.ads, a-finali.adb,
|
||||
a-ncelfu.ads, a-reatim.adb, a-retide.adb, a-stream.ads,
|
||||
a-ststio.adb, a-ststio.ads, a-stwifi.adb, a-tags.adb, a-tasatt.adb,
|
||||
a-textio.adb, a-tideau.adb, a-tiflau.adb, a-tigeau.adb,
|
||||
a-tigeau.ads, a-tiinau.adb, a-timoau.adb, a-witeio.adb,
|
||||
a-wtdeau.adb, a-wtenau.adb, a-wtflau.adb, a-wtgeau.adb,
|
||||
a-wtgeau.ads, a-wtinau.adb, a-wtmoau.adb, ada-tree.def, ada-tree.h,
|
||||
adaint.c, adaint.h, ali-util.adb, ali.adb, ali.ads, atree.adb,
|
||||
atree.ads, atree.h, back_end.adb, bcheck.adb, bindgen.adb,
|
||||
bindusg.adb, checks.adb, comperr.adb, config-lang.in, csets.adb,
|
||||
csets.ads, cstand.adb, cstreams.c, debug.adb, debug.ads, decl.c,
|
||||
einfo.adb, einfo.ads, einfo.h, elists.h, errout.adb, errout.ads,
|
||||
eval_fat.adb, exp_aggr.adb, exp_attr.adb, exp_ch11.adb,
|
||||
exp_ch12.adb, exp_ch13.adb, exp_ch2.adb, exp_ch3.adb, exp_ch3.ads,
|
||||
exp_ch4.adb, exp_ch5.adb, exp_ch6.adb, exp_ch7.adb, exp_ch7.ads,
|
||||
exp_ch9.adb, exp_ch9.ads, exp_dbug.adb, exp_dbug.ads, exp_disp.ads,
|
||||
exp_dist.adb, exp_fixd.adb, exp_intr.adb, exp_pakd.adb,
|
||||
exp_prag.adb, exp_strm.adb, exp_util.adb, exp_util.ads,
|
||||
expander.adb, expect.c, fe.h, fmap.adb, fmap.ads, fname-uf.adb,
|
||||
freeze.adb, frontend.adb, g-awk.adb, g-cgideb.adb, g-comlin.adb,
|
||||
g-comlin.ads, g-debpoo.adb, g-dirope.adb, g-dirope.ads,
|
||||
g-dyntab.adb, g-expect.adb, g-expect.ads, g-io.ads, g-io_aux.adb,
|
||||
g-io_aux.ads, g-locfil.adb, g-locfil.ads, g-os_lib.adb,
|
||||
g-os_lib.ads, g-regexp.adb, g-regpat.adb, g-socket.adb,
|
||||
g-socket.ads, g-spipat.adb, g-table.adb, g-trasym.adb,
|
||||
g-trasym.ads, gigi.h, gmem.c, gnat1drv.adb, gnatbind.adb, gnatbl.c,
|
||||
gnatchop.adb, gnatcmd.adb, gnatdll.adb, gnatfind.adb, gnatlbr.adb,
|
||||
gnatlink.adb, gnatls.adb, gnatmem.adb, gnatprep.adb, gnatvsn.ads,
|
||||
gnatxref.adb, hlo.adb, hostparm.ads, i-cobol.adb, i-cpp.adb,
|
||||
i-cstrea.ads, i-cstrin.adb, i-pacdec.adb, i-vxwork.ads,
|
||||
impunit.adb, init.c, inline.adb, io-aux.c, layout.adb, lib-load.adb,
|
||||
lib-util.adb, lib-writ.adb, lib-writ.ads, lib-xref.adb,
|
||||
lib-xref.ads, lib.adb, lib.ads, make.adb, makeusg.adb, mdll.adb,
|
||||
memroot.adb, misc.c, mlib-tgt.adb, mlib-utl.adb, mlib-utl.ads,
|
||||
mlib.adb, namet.adb, namet.ads, namet.h, nlists.h, nmake.adb,
|
||||
nmake.ads, nmake.adt, opt.adb, opt.ads, osint.adb, osint.ads,
|
||||
output.adb, output.ads, par-ch2.adb, par-ch3.adb, par-ch5.adb,
|
||||
par-prag.adb, par-tchk.adb, par-util.adb, par.adb, prj-attr.adb,
|
||||
prj-dect.adb, prj-env.adb, prj-env.ads, prj-nmsc.adb, prj-part.adb,
|
||||
prj-proc.adb, prj-strt.adb, prj-tree.adb, prj-tree.ads, prj.adb,
|
||||
prj.ads, raise.c, raise.h, repinfo.adb, restrict.adb, restrict.ads,
|
||||
rident.ads, rtsfind.adb, rtsfind.ads, s-arit64.adb, s-asthan.adb,
|
||||
s-atacco.adb, s-atacco.ads, s-auxdec.adb, s-crc32.adb, s-crc32.ads,
|
||||
s-direio.adb, s-fatgen.adb, s-fileio.adb, s-finimp.adb,
|
||||
s-gloloc.adb, s-gloloc.ads, s-interr.adb, s-mastop.adb,
|
||||
s-mastop.ads, s-memory.adb, s-parame.ads, s-parint.adb,
|
||||
s-pooglo.adb, s-pooloc.adb, s-rpc.adb, s-secsta.adb, s-sequio.adb,
|
||||
s-shasto.adb, s-soflin.adb, s-soflin.ads, s-stache.adb,
|
||||
s-taasde.adb, s-taasde.ads, s-tadeca.adb, s-tadeca.ads,
|
||||
s-tadert.adb, s-tadert.ads, s-taenca.adb, s-taenca.ads,
|
||||
s-taprob.adb, s-taprop.ads, s-tarest.adb, s-tasdeb.adb,
|
||||
s-tasini.adb, s-tasini.ads, s-taskin.adb, s-taskin.ads,
|
||||
s-tasque.adb, s-tasque.ads, s-tasren.adb, s-tasren.ads,
|
||||
s-tassta.adb, s-tasuti.adb, s-tasuti.ads, s-tataat.adb,
|
||||
s-tataat.ads, s-tpoben.adb, s-tpoben.ads, s-tpobop.adb,
|
||||
s-tposen.adb, s-tposen.ads, s-traceb.adb, s-traceb.ads,
|
||||
s-unstyp.ads, s-widenu.adb, scn-nlit.adb, scn.adb, sem.adb,
|
||||
sem_aggr.adb, sem_attr.adb, sem_attr.ads, sem_case.adb,
|
||||
sem_ch10.adb, sem_ch11.adb, sem_ch11.ads, sem_ch12.adb,
|
||||
sem_ch13.adb, sem_ch13.ads, sem_ch2.adb, sem_ch3.adb, sem_ch3.ads,
|
||||
sem_ch4.adb, sem_ch5.adb, sem_ch6.adb, sem_ch6.ads, sem_ch7.adb,
|
||||
sem_ch8.adb, sem_ch8.ads, sem_ch9.adb, sem_disp.adb, sem_dist.adb,
|
||||
sem_elab.adb, sem_elim.adb, sem_elim.ads, sem_eval.adb,
|
||||
sem_intr.adb, sem_mech.adb, sem_prag.adb, sem_res.adb,
|
||||
sem_type.adb, sem_util.adb, sem_util.ads, sem_vfpt.adb,
|
||||
sem_warn.adb, sinfo.adb, sinfo.ads, sinfo.h, sinput-l.adb,
|
||||
sinput-l.ads, sinput.adb, sinput.ads, snames.adb, snames.ads,
|
||||
snames.h, sprint.adb, sprint.ads, stringt.adb, stringt.ads,
|
||||
stringt.h, style.adb, switch.adb, switch.ads, sysdep.c, system.ads,
|
||||
table.adb, targparm.adb, targparm.ads, targtyps.c, tbuild.adb,
|
||||
tbuild.ads, tracebak.c, trans.c, tree_gen.adb, tree_io.adb,
|
||||
treepr.adb, treepr.ads, treeprs.ads, treeprs.adt, ttypes.ads,
|
||||
types.adb, types.ads, types.h, uintp.ads, urealp.ads, usage.adb,
|
||||
utils.c, utils2.c, validsw.adb, xnmake.adb, xr_tabls.adb,
|
||||
xr_tabls.ads, xref_lib.adb, xref_lib.ads : Merge in ACT changes.
|
||||
|
||||
* 1ssecsta.adb, 1ssecsta.ads, a-chlat9.ads, a-cwila9.ads,
|
||||
g-enblsp.adb, g-md5.adb, g-md5.ads, gnatname.adb, gnatname.ads,
|
||||
mkdir.c, osint-b.adb, osint-b.ads, osint-c.adb, osint-c.ads,
|
||||
osint-l.adb, osint-l.ads, osint-m.adb, osint-m.ads : New files
|
||||
|
||||
* 3lsoccon.ads, 5qparame.ads, 5qvxwork.ads, 5smastop.adb,
|
||||
5zparame.ads, gnatmain.adb, gnatmain.ads, gnatpsys.adb : Removed
|
||||
|
||||
* mdllfile.adb, mdllfile.ads, mdlltool.adb, mdlltool.ads : Renamed
|
||||
to mdll-fil.ad[bs] and mdll-util.ad[bs]
|
||||
|
||||
* mdll-fil.adb, mdll-fil.ads, mdll-utl.adb, mdll-utl.ads : Renamed
|
||||
from mdllfile.ad[bs] and mdlltool.ad[bs]
|
||||
|
||||
2002-03-03 Kaveh R. Ghazi <ghazi@caip.rutgers.edu>
|
||||
|
||||
* utils.c (init_gnat_to_gnu, init_gigi_decls): Use ARRAY_SIZE in
|
||||
@ -92,19 +206,19 @@
|
||||
|
||||
* prj-env.ads: Minor reformatting
|
||||
|
||||
* switch.adb: Minor reformatting. Do proper raise of Bad_Switch if
|
||||
error found (there were odd exceptions to this general rule in
|
||||
* switch.adb: Minor reformatting. Do proper raise of Bad_Switch if
|
||||
error found (there were odd exceptions to this general rule in
|
||||
-gnatec/-gnatem processing)
|
||||
|
||||
2001-12-19 Olivier Hainque <hainque@gnat.com>
|
||||
|
||||
* raise.c (__gnat_eh_personality): Exception handling personality
|
||||
routine for Ada. Still in rough state, inspired from the C++ version
|
||||
* raise.c (__gnat_eh_personality): Exception handling personality
|
||||
routine for Ada. Still in rough state, inspired from the C++ version
|
||||
and still containing a bunch of debugging artifacts.
|
||||
(parse_lsda_header, get_ttype_entry): Local (static) helpers, also
|
||||
(parse_lsda_header, get_ttype_entry): Local (static) helpers, also
|
||||
inspired from the C++ library.
|
||||
|
||||
* raise.c (eh_personality): Add comments. Part of work for the GCC 3
|
||||
* raise.c (eh_personality): Add comments. Part of work for the GCC 3
|
||||
exception handling integration.
|
||||
|
||||
2001-12-19 Arnaud Charlet <charlet@gnat.com>
|
||||
@ -112,7 +226,7 @@
|
||||
* Makefile.in: Remove use of 5smastop.adb which is obsolete.
|
||||
(HIE_SOURCES): Add s-secsta.ad{s,b}.
|
||||
(HIE_OBJS): Add s-fat*.o
|
||||
(RAVEN_SOURCES): Remove files that are no longer required. Add
|
||||
(RAVEN_SOURCES): Remove files that are no longer required. Add
|
||||
interrupt handling files.
|
||||
(RAVEN_MOD): Removed, no longer needed.
|
||||
|
||||
@ -121,12 +235,12 @@
|
||||
* a-ngelfu.adb: Remove ??? comment for inappropriate Inline_Always
|
||||
Add 2001 to copyright date
|
||||
|
||||
* g-regpat.adb: Change pragma Inline_Always to Inline. There is no
|
||||
* g-regpat.adb: Change pragma Inline_Always to Inline. There is no
|
||||
need to force universal inlining for these cases.
|
||||
|
||||
2001-12-19 Arnaud Charlet <charlet@gnat.com>
|
||||
|
||||
* s-taprob.adb: Minor clean ups so that this unit can be used in
|
||||
* s-taprob.adb: Minor clean ups so that this unit can be used in
|
||||
Ravenscar HI.
|
||||
|
||||
* exp_ch7.adb: Allow use of secondary stack in HI mode.
|
||||
@ -134,7 +248,7 @@
|
||||
|
||||
2001-12-19 Vincent Celier <celier@gnat.com>
|
||||
|
||||
* prj-tree.ads (Project_Node_Record): Add comments for components
|
||||
* prj-tree.ads (Project_Node_Record): Add comments for components
|
||||
Pkg_Id and Case_Insensitive.
|
||||
|
||||
2001-12-19 Pascal Obry <obry@gnat.com>
|
||||
@ -151,20 +265,20 @@
|
||||
|
||||
2001-12-17 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_res.adb (Resolve_Selected_Component): do not generate a
|
||||
discriminant check if the selected component is a component of
|
||||
* sem_res.adb (Resolve_Selected_Component): do not generate a
|
||||
discriminant check if the selected component is a component of
|
||||
the argument of an initialization procedure.
|
||||
|
||||
* trans.c (tree_transform, case of arithmetic operators): If result
|
||||
type is private, the gnu_type is the base type of the full view,
|
||||
* trans.c (tree_transform, case of arithmetic operators): If result
|
||||
type is private, the gnu_type is the base type of the full view,
|
||||
given that the full view itself may be a subtype.
|
||||
|
||||
2001-12-17 Robert Dewar <dewar@gnat.com>
|
||||
|
||||
* sem_res.adb: Minor reformatting
|
||||
|
||||
* trans.c (tree_transform, case N_Real_Literal): Add missing third
|
||||
parameter in call to Machine (unknown horrible effects from this
|
||||
* trans.c (tree_transform, case N_Real_Literal): Add missing third
|
||||
parameter in call to Machine (unknown horrible effects from this
|
||||
omission).
|
||||
|
||||
* urealp.h: Add definition of Round_Even for call to Machine
|
||||
@ -172,7 +286,7 @@
|
||||
|
||||
2001-12-17 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_warn.adb (Check_One_Unit): Suppress warnings completely on
|
||||
* sem_warn.adb (Check_One_Unit): Suppress warnings completely on
|
||||
predefined units in No_Run_Time mode.
|
||||
|
||||
2001-12-17 Richard Kenner <kenner@gnat.com>
|
||||
@ -181,7 +295,7 @@
|
||||
|
||||
2001-12-17 Olivier Hainque <hainque@gnat.com>
|
||||
|
||||
* a-except.adb: Preparation work for future integration of the GCC 3
|
||||
* a-except.adb: Preparation work for future integration of the GCC 3
|
||||
exception handling mechanism
|
||||
(Notify_Handled_Exception, Notify_Unhandled_Exception): New routines
|
||||
to factorize previous code sequences and make them externally callable,
|
||||
@ -195,10 +309,10 @@
|
||||
|
||||
2001-12-17 Arnaud Charlet <charlet@gnat.com>
|
||||
|
||||
* bindgen.adb (Gen_Ada_Init_*): Set priority of environment task in
|
||||
* bindgen.adb (Gen_Ada_Init_*): Set priority of environment task in
|
||||
HI-E mode, in order to support Ravenscar profile properly.
|
||||
|
||||
* cstand.adb (Create_Standard): Duration is a 32 bit type in HI-E
|
||||
* cstand.adb (Create_Standard): Duration is a 32 bit type in HI-E
|
||||
mode on 32 bits targets.
|
||||
|
||||
2001-12-17 Vincent Celier <celier@gnat.com>
|
||||
@ -225,7 +339,7 @@
|
||||
|
||||
* prj-env.ads (Create_Mapping_File): New procedure.
|
||||
|
||||
* switch.adb (Scan_Front_End_Switches): Add processing for -gnatem
|
||||
* switch.adb (Scan_Front_End_Switches): Add processing for -gnatem
|
||||
(Mapping_File)
|
||||
|
||||
* usage.adb: Add entry for new switch -gnatem.
|
||||
@ -234,7 +348,7 @@
|
||||
|
||||
2001-12-17 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_ch10.adb (Analyze_With_Clause): Retrieve proper entity when unit
|
||||
* sem_ch10.adb (Analyze_With_Clause): Retrieve proper entity when unit
|
||||
is a package instantiation rewritten as a package body.
|
||||
(Install_Withed_Unit): Undo previous change, now redundant.
|
||||
|
||||
@ -247,7 +361,7 @@
|
||||
(Layout_Array_Type): Convert Len expression to Unsigned after calls to
|
||||
Compute_Length and Determine_Range.
|
||||
Above changes fix problem with length computation for supernull arrays
|
||||
where Max (Len, 0) wasn't getting applied due to the Unsigned
|
||||
where Max (Len, 0) wasn't getting applied due to the Unsigned
|
||||
conversion used by Compute_Length.
|
||||
|
||||
2001-12-17 Arnaud Charlet <charlet@gnat.com>
|
||||
@ -265,14 +379,14 @@
|
||||
|
||||
2001-12-17 Joel Brobecker <brobecke@gnat.com>
|
||||
|
||||
* gnat_rm.texi: Fix minor typos. Found while reading the section
|
||||
* gnat_rm.texi: Fix minor typos. Found while reading the section
|
||||
regarding "Bit_Order Clauses" that was sent to a customer.
|
||||
Very interesting documentation!
|
||||
|
||||
2001-12-17 Robert Dewar <dewar@gnat.com>
|
||||
|
||||
* sem_case.adb (Choice_Image): Avoid creating improper character
|
||||
literal names by using the routine Set_Character_Literal_Name. This
|
||||
* sem_case.adb (Choice_Image): Avoid creating improper character
|
||||
literal names by using the routine Set_Character_Literal_Name. This
|
||||
fixes bombs in certain error message cases.
|
||||
|
||||
2001-12-17 Arnaud Charlet <charlet@gnat.com>
|
||||
@ -281,20 +395,20 @@
|
||||
|
||||
2001-12-17 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_ch12.adb (Validate_Derived_Type_Instance): Handle properly the
|
||||
case where the formal is an extension of another formal in the current
|
||||
* sem_ch12.adb (Validate_Derived_Type_Instance): Handle properly the
|
||||
case where the formal is an extension of another formal in the current
|
||||
unit or in a parent generic unit.
|
||||
|
||||
2001-12-17 Arnaud Charlet <charlet@gnat.com>
|
||||
|
||||
* s-tposen.adb: Update comments. Minor reformatting.
|
||||
* s-tposen.adb: Update comments. Minor reformatting.
|
||||
Minor code clean up.
|
||||
|
||||
* s-tarest.adb: Update comments. Minor code reorganization.
|
||||
|
||||
2001-12-17 Gary Dismukes <dismukes@gnat.com>
|
||||
|
||||
* exp_attr.adb (Attribute_Tag): Suppress expansion of <type_name>'Tag
|
||||
* exp_attr.adb (Attribute_Tag): Suppress expansion of <type_name>'Tag
|
||||
when Java_VM.
|
||||
|
||||
2001-12-17 Robert Dewar <dewar@gnat.com>
|
||||
@ -303,7 +417,7 @@
|
||||
|
||||
2001-12-17 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_ch3.adb (Build_Derived_Private_Type): Refine check to handle
|
||||
* sem_ch3.adb (Build_Derived_Private_Type): Refine check to handle
|
||||
derivations nested within a child unit: verify that the parent
|
||||
type is declared in an outer scope.
|
||||
|
||||
@ -313,8 +427,8 @@
|
||||
|
||||
2001-12-17 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_warn.adb (Check_One_Unit): In No_Run_Time mode, do not post
|
||||
warning if current unit is a predefined one, from which bodies may
|
||||
* sem_warn.adb (Check_One_Unit): In No_Run_Time mode, do not post
|
||||
warning if current unit is a predefined one, from which bodies may
|
||||
have been deleted.
|
||||
|
||||
2001-12-17 Robert Dewar <dewar@gnat.com>
|
||||
@ -322,7 +436,7 @@
|
||||
* eval_fat.ads: Add comment that Round_Even is referenced in Ada code
|
||||
Fix header format. Add 2001 to copyright date.
|
||||
|
||||
* exp_dbug.adb (Get_Encoded_Name): Fix out of bounds reference,
|
||||
* exp_dbug.adb (Get_Encoded_Name): Fix out of bounds reference,
|
||||
which caused CE during compilation if checks were enabled.
|
||||
|
||||
2001-12-17 Vincent Celier <celier@gnat.com>
|
||||
@ -334,13 +448,13 @@
|
||||
(Collect_Arguments_And_Compile): Use new function Switches_Of.
|
||||
When using a project file, test if there are any relative
|
||||
search path. Fail if there are any.
|
||||
(Gnatmake): Only add switches for the primary directory when not using
|
||||
a project file. When using a project file, change directory to the
|
||||
object directory of the main project file. When using a project file,
|
||||
test if there are any relative search path. Fail if there are any.
|
||||
When using a project file, fail if specified executable is relative
|
||||
path with directory information, and prepend executable, if not
|
||||
specified as an absolute path, with the exec directory. Make sure
|
||||
(Gnatmake): Only add switches for the primary directory when not using
|
||||
a project file. When using a project file, change directory to the
|
||||
object directory of the main project file. When using a project file,
|
||||
test if there are any relative search path. Fail if there are any.
|
||||
When using a project file, fail if specified executable is relative
|
||||
path with directory information, and prepend executable, if not
|
||||
specified as an absolute path, with the exec directory. Make sure
|
||||
that only one -o switch is transmitted to the linker.
|
||||
|
||||
* prj-attr.adb (Initialization_Data): Add project attribute Exec_Dir
|
||||
@ -375,23 +489,23 @@
|
||||
|
||||
2001-12-17 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* trans.c (process_freeze_entity): Do nothing if the entity is a
|
||||
* trans.c (process_freeze_entity): Do nothing if the entity is a
|
||||
subprogram that was already elaborated.
|
||||
|
||||
2001-12-17 Richard Kenner <kenner@gnat.com>
|
||||
|
||||
* decl.c (gnat_to_gnu_entity, object): Do not back-annotate Alignment
|
||||
* decl.c (gnat_to_gnu_entity, object): Do not back-annotate Alignment
|
||||
and Esize if object is referenced via pointer.
|
||||
|
||||
2001-12-17 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_ch3.adb (Analyze_Variant_Part): check that type of discriminant
|
||||
* sem_ch3.adb (Analyze_Variant_Part): check that type of discriminant
|
||||
is discrete before analyzing choices.
|
||||
|
||||
2001-12-17 Joel Brobecker <brobecke@gnat.com>
|
||||
|
||||
* bindgen.adb (Gen_Output_File_Ada): Generate a new C-like string
|
||||
containing the name of the Ada Main Program. This string is mainly
|
||||
* bindgen.adb (Gen_Output_File_Ada): Generate a new C-like string
|
||||
containing the name of the Ada Main Program. This string is mainly
|
||||
intended for the debugger.
|
||||
(Gen_Output_File_C): Do the equivalent change when generating a C file.
|
||||
|
||||
@ -439,10 +553,10 @@
|
||||
|
||||
2001-12-17 Robert Dewar <dewar@gnat.com>
|
||||
|
||||
* frontend.adb: Move call to Check_Unused_Withs from Frontend, so
|
||||
* frontend.adb: Move call to Check_Unused_Withs from Frontend, so
|
||||
that it happens before modification of Sloc values for -gnatD.
|
||||
|
||||
* gnat1drv.adb: Move call to Check_Unused_Withs to Frontend,
|
||||
* gnat1drv.adb: Move call to Check_Unused_Withs to Frontend,
|
||||
so that it happens before modification of Sloc values for -gnatD.
|
||||
|
||||
* switch.adb: Minor reformatting
|
||||
@ -481,19 +595,19 @@
|
||||
|
||||
2001-12-14 Vincent Celier <celier@gnat.com>
|
||||
|
||||
* osint.adb(Create_Debug_File): When an object file is specified,
|
||||
* osint.adb(Create_Debug_File): When an object file is specified,
|
||||
put the .dg file in the same directory as the object file.
|
||||
|
||||
2001-12-14 Robert Dewar <dewar@gnat.com>
|
||||
|
||||
* osint.adb: Minor reformatting
|
||||
|
||||
* lib-xref.adb (Output_Instantiation): New procedure to generate
|
||||
* lib-xref.adb (Output_Instantiation): New procedure to generate
|
||||
instantiation references.
|
||||
|
||||
* lib-xref.ads: Add documentation of handling of generic references.
|
||||
|
||||
* ali.adb (Read_Instantiation_Ref): New procedure to read
|
||||
* ali.adb (Read_Instantiation_Ref): New procedure to read
|
||||
instantiation references
|
||||
|
||||
* ali.ads: Add spec for storing instantiation references
|
||||
@ -515,23 +629,23 @@
|
||||
|
||||
2001-12-14 Matt Gingell <gingell@gnat.com>
|
||||
|
||||
* adaint.c: mktemp is a macro on Lynx and can not be used as an
|
||||
* adaint.c: mktemp is a macro on Lynx and can not be used as an
|
||||
expression.
|
||||
|
||||
2001-12-14 Richard Kenner <kenner@gnat.com>
|
||||
|
||||
* misc.c (gnat_expand_constant): Do not strip UNCHECKED_CONVERT_EXPR
|
||||
* misc.c (gnat_expand_constant): Do not strip UNCHECKED_CONVERT_EXPR
|
||||
if operand is CONSTRUCTOR.
|
||||
|
||||
2001-12-14 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* trans.c (tree_transform, case N_Assignment_Statement): Set lineno
|
||||
before emiting check on right-hand side, so that exception information
|
||||
* trans.c (tree_transform, case N_Assignment_Statement): Set lineno
|
||||
before emiting check on right-hand side, so that exception information
|
||||
is correct.
|
||||
|
||||
2001-12-14 Richard Kenner <kenner@gnat.com>
|
||||
|
||||
* utils.c (create_var_decl): Throw away initializing expression
|
||||
* utils.c (create_var_decl): Throw away initializing expression
|
||||
if just annotating types and non-constant.
|
||||
|
||||
2001-12-14 Vincent Celier <celier@gnat.com>
|
||||
@ -539,11 +653,11 @@
|
||||
* prj-nmsc.adb: (Ada_Check): Migrate drom Ada_Default_... to
|
||||
Default_Ada_...
|
||||
|
||||
* prj.adb: (Ada_Default_Spec_Suffix, Ada_Default_Impl_Suffix):
|
||||
* prj.adb: (Ada_Default_Spec_Suffix, Ada_Default_Impl_Suffix):
|
||||
Remove functions.
|
||||
(Default_Ada_Spec_Suffix, Default_Ada_Impl_Suffix): Move to spec.
|
||||
|
||||
* prj.ads: (Ada_Default_Spec_Suffix, Ada_Default_Impl_Suffix):
|
||||
* prj.ads: (Ada_Default_Spec_Suffix, Ada_Default_Impl_Suffix):
|
||||
Remove functions.
|
||||
(Default_Ada_Spec_Suffix, Default_Ada_Impl_Suffix): Move from body.
|
||||
|
||||
@ -577,7 +691,7 @@
|
||||
|
||||
2001-12-12 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_ch12.adb (Save_Entity_Descendant): Use syntactic field names
|
||||
* sem_ch12.adb (Save_Entity_Descendant): Use syntactic field names
|
||||
on known node types, rather than untyped fields. Further cleanups.
|
||||
|
||||
2001-12-12 Robert Dewar <dewar@gnat.com>
|
||||
@ -585,9 +699,9 @@
|
||||
* sem_ch12.adb:
|
||||
(Save_Entity_Descendant): Minor comment update.
|
||||
(Copy_Generic_Node): Deal with incorrect reference to Associated_Node
|
||||
of an N_Attribute_Reference node. As per note below, this does not
|
||||
of an N_Attribute_Reference node. As per note below, this does not
|
||||
eliminate need for Associated_Node in attribute ref nodes.
|
||||
(Associated_Node): Documentation explicitly mentions attribute
|
||||
(Associated_Node): Documentation explicitly mentions attribute
|
||||
reference nodes, since this field is used in such nodes.
|
||||
|
||||
* sem_ch12.adb (Associated_Node): Minor documentation cleanup.
|
||||
@ -600,26 +714,26 @@
|
||||
|
||||
* prj-dect.ads: Fix copyright header
|
||||
|
||||
* s-arit64.adb (Multiply_With_Ovflo_Check): Fix case where both
|
||||
* s-arit64.adb (Multiply_With_Ovflo_Check): Fix case where both
|
||||
inputs fit in 32 bits, but the result still overflows.
|
||||
|
||||
* s-fatgen.ads: Minor comment improvement
|
||||
|
||||
2001-12-12 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_ch4.adb (Analyze_Selected_Component): If the prefix is of a
|
||||
formal derived type, look for an inherited component from the full
|
||||
* sem_ch4.adb (Analyze_Selected_Component): If the prefix is of a
|
||||
formal derived type, look for an inherited component from the full
|
||||
view of the parent, if any.
|
||||
|
||||
2001-12-12 Robert Dewar <dewar@gnat.com>
|
||||
|
||||
* checks.ads (Apply_Alignment_Check): New procedure.
|
||||
|
||||
* exp_ch13.adb (Expand_N_Freeze_Entity): Generate dynamic check to
|
||||
ensure that the alignment of objects with address clauses is
|
||||
* exp_ch13.adb (Expand_N_Freeze_Entity): Generate dynamic check to
|
||||
ensure that the alignment of objects with address clauses is
|
||||
appropriate, and raise PE if not.
|
||||
|
||||
* exp_util.ads (Must_Be_Aligned): Removed, replaced by
|
||||
* exp_util.ads (Must_Be_Aligned): Removed, replaced by
|
||||
Exp_Pakd.Known_Aligned_Enough
|
||||
|
||||
* mdllfile.ads: Minor reformatting
|
||||
@ -628,18 +742,18 @@
|
||||
|
||||
2001-12-12 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* exp_ch8.adb (Expand_N_Object_Renaming_Declaration): Extend previous
|
||||
fix to any component reference if enclosing record has non-standard
|
||||
* exp_ch8.adb (Expand_N_Object_Renaming_Declaration): Extend previous
|
||||
fix to any component reference if enclosing record has non-standard
|
||||
representation.
|
||||
|
||||
2001-12-12 Vincent Celier <celier@gnat.com>
|
||||
|
||||
* g-dirope.ads (Find, Wildcard_Iterator): Moved to child package
|
||||
* g-dirope.ads (Find, Wildcard_Iterator): Moved to child package
|
||||
Iteration
|
||||
|
||||
2001-12-12 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* freeze.ads: Make Freeze_Fixed_Point_Type visible, for use in
|
||||
* freeze.ads: Make Freeze_Fixed_Point_Type visible, for use in
|
||||
sem_attr.
|
||||
|
||||
2001-12-12 Robert Dewar <dewar@gnat.com>
|
||||
@ -653,14 +767,14 @@
|
||||
|
||||
2001-12-12 Pascal Obry <obry@gnat.com>
|
||||
|
||||
* g-dirope.adb (Expand_Path.Var): Correctly detect end of
|
||||
* g-dirope.adb (Expand_Path.Var): Correctly detect end of
|
||||
variable name.
|
||||
|
||||
2001-12-11 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_ch10.adb (Install_Withed_Unit): If the unit is a generic instance
|
||||
that is the parent of other generics, the instance body replaces the
|
||||
instance node. Retrieve the instance of the spec, which is the one
|
||||
that is the parent of other generics, the instance body replaces the
|
||||
instance node. Retrieve the instance of the spec, which is the one
|
||||
that is visible in clients and within the body.
|
||||
|
||||
2001-12-11 Vincent Celier <celier@gnat.com>
|
||||
@ -677,7 +791,7 @@
|
||||
|
||||
2001-12-11 Vincent Celier <celier@gnat.com>
|
||||
|
||||
* prj-attr.adb (Initialization_Data): Change name from
|
||||
* prj-attr.adb (Initialization_Data): Change name from
|
||||
Initialisation_Data.
|
||||
|
||||
2001-12-11 Emmanuel Briot <briot@gnat.com>
|
||||
@ -687,7 +801,7 @@
|
||||
|
||||
2001-12-11 Vasiliy Fofanov <fofanov@gnat.com>
|
||||
|
||||
* g-os_lib.ads: String_List type added, Argument_List type is now
|
||||
* g-os_lib.ads: String_List type added, Argument_List type is now
|
||||
subtype of String_List.
|
||||
|
||||
2001-12-11 Robert Dewar <dewar@gnat.com>
|
||||
@ -697,7 +811,7 @@
|
||||
|
||||
2001-12-11 Vincent Celier <celier@gnat.com>
|
||||
|
||||
* g-dirope.adb (Expand_Path): Fix bug. (wrong length when adding a
|
||||
* g-dirope.adb (Expand_Path): Fix bug. (wrong length when adding a
|
||||
string to the buffer).
|
||||
|
||||
2001-12-11 Ed Schonberg <schonber@gnat.com>
|
||||
@ -706,18 +820,18 @@
|
||||
sem_attr.
|
||||
|
||||
* sem_attr.adb: Simplify previous fix for Address.
|
||||
(Set_Bounds): If prefix is a non-frozen fixed-point type, freeze now,
|
||||
to avoid anomalies where the bound of the type appears to raise
|
||||
(Set_Bounds): If prefix is a non-frozen fixed-point type, freeze now,
|
||||
to avoid anomalies where the bound of the type appears to raise
|
||||
constraint error.
|
||||
|
||||
2001-12-11 Robert Dewar <dewar@gnat.com>
|
||||
|
||||
* lib-xref.adb (Output_Refs): Make sure pointers are always properly
|
||||
* lib-xref.adb (Output_Refs): Make sure pointers are always properly
|
||||
handled.
|
||||
|
||||
2001-12-11 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_ch12.adb (Analyze_Subprogram_Instantiation): Check for a
|
||||
* sem_ch12.adb (Analyze_Subprogram_Instantiation): Check for a
|
||||
renamed unit before checking for recursive instantiations.
|
||||
|
||||
2001-12-11 Emmanuel Briot <briot@gnat.com>
|
||||
@ -726,15 +840,15 @@
|
||||
|
||||
2001-12-11 Robert Dewar <dewar@gnat.com>
|
||||
|
||||
* lib-xref.adb (Output_Refs): Don't output type references outside
|
||||
* lib-xref.adb (Output_Refs): Don't output type references outside
|
||||
the main unit if they are not otherwise referenced.
|
||||
|
||||
2001-12-11 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_attr.adb (Analyze_attribute, case Address and Size): Simplify
|
||||
* sem_attr.adb (Analyze_attribute, case Address and Size): Simplify
|
||||
code and diagnose additional illegal uses
|
||||
|
||||
* sem_util.adb (Is_Object_Reference): An indexed component is an
|
||||
* sem_util.adb (Is_Object_Reference): An indexed component is an
|
||||
object only if the prefix is.
|
||||
|
||||
2001-12-11 Vincent Celier <celier@gnat.com>
|
||||
@ -759,10 +873,10 @@
|
||||
|
||||
2001-12-11 Robert Dewar <dewar@gnat.com>
|
||||
|
||||
* exp_util.adb (Must_Be_Aligned): Removed, replaced by
|
||||
* exp_util.adb (Must_Be_Aligned): Removed, replaced by
|
||||
Exp_Pakd.Known_Aligned_Enough
|
||||
|
||||
* sem_ch13.adb (Check_Address_Alignment): Removed, extended
|
||||
* sem_ch13.adb (Check_Address_Alignment): Removed, extended
|
||||
version is moved to Exp_Ch13.
|
||||
|
||||
2001-12-11 Robert Dewar <dewar@gnat.com>
|
||||
@ -781,18 +895,18 @@
|
||||
|
||||
* exp_pakd.adb (Known_Aligned_Enough): Replaces Known_Aligned_Enough.
|
||||
|
||||
* lib-xref.adb: Extend generation of <..> notation to cover
|
||||
subtype/object types. Note that this is a complete rewrite,
|
||||
getting rid of the very nasty quadratic algorithm previously
|
||||
* lib-xref.adb: Extend generation of <..> notation to cover
|
||||
subtype/object types. Note that this is a complete rewrite,
|
||||
getting rid of the very nasty quadratic algorithm previously
|
||||
used for derived type output.
|
||||
|
||||
* lib-xref.ads: Extend description of <..> notation to cover
|
||||
subtype/object types. Uses {..} for these other cases.
|
||||
* lib-xref.ads: Extend description of <..> notation to cover
|
||||
subtype/object types. Uses {..} for these other cases.
|
||||
Also use (..) for pointer types.
|
||||
|
||||
* sem_util.adb (Check_Potentially_Blocking_Operation): Slight cleanup.
|
||||
|
||||
* exp_pakd.adb: Minor reformatting. Note that prevous RH should say:
|
||||
* exp_pakd.adb: Minor reformatting. Note that prevous RH should say:
|
||||
(Known_Aligned_Enough): Replaces Must_Be_Aligned.
|
||||
|
||||
2001-12-11 Vincent Celier <celier@gnat.com>
|
||||
@ -816,26 +930,26 @@
|
||||
|
||||
2001-12-11 Robert Dewar <dewar@gnat.com>
|
||||
|
||||
* checks.adb (Insert_Valid_Check): Apply validity check to expression
|
||||
* checks.adb (Insert_Valid_Check): Apply validity check to expression
|
||||
of conversion, not to result of conversion.
|
||||
|
||||
2001-12-11 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_ch3.adb (Build_Derived_Record_Type): set Controlled flag
|
||||
before freezing parent. If the declarations are mutually recursive,
|
||||
an access to the current record type may be frozen before the
|
||||
* sem_ch3.adb (Build_Derived_Record_Type): set Controlled flag
|
||||
before freezing parent. If the declarations are mutually recursive,
|
||||
an access to the current record type may be frozen before the
|
||||
derivation is complete.
|
||||
|
||||
2001-12-05 Vincent Celier <celier@gnat.com>
|
||||
|
||||
* gnatcmd.adb: (MAKE): Add new translations: -b /BIND_ONLY,
|
||||
* gnatcmd.adb: (MAKE): Add new translations: -b /BIND_ONLY,
|
||||
-c /COMPILE_ONLY, -l /LINK_ONLY
|
||||
|
||||
* opt.ads:
|
||||
(Bind_Only): New Flag
|
||||
(Link_Only): New flag
|
||||
|
||||
* switch.adb (Scan_Make_Switches): Add processing for -b (Bind_Only)
|
||||
* switch.adb (Scan_Make_Switches): Add processing for -b (Bind_Only)
|
||||
and -l (Link_Only)
|
||||
|
||||
* makeusg.adb: Add new switches -b and -l. Update Copyright notice.
|
||||
@ -849,28 +963,28 @@
|
||||
|
||||
2001-12-05 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_eval.adb (Eval_Concatenation): If left operand is a null string,
|
||||
* sem_eval.adb (Eval_Concatenation): If left operand is a null string,
|
||||
get bounds from right operand.
|
||||
|
||||
* sem_eval.adb: Minor reformatting
|
||||
|
||||
* exp_util.adb (Make_Literal_Range): use bound of literal rather
|
||||
* exp_util.adb (Make_Literal_Range): use bound of literal rather
|
||||
than Index'First, its lower bound may be different from 1.
|
||||
|
||||
* exp_util.adb: Undo earlier change, fixes ACVC regressions C48009B
|
||||
* exp_util.adb: Undo earlier change, fixes ACVC regressions C48009B
|
||||
and C48009J
|
||||
|
||||
2001-12-05 Vincent Celier <celier@gnat.com>
|
||||
|
||||
* prj-nmsc.adb Minor reformatting
|
||||
|
||||
* prj-nmsc.adb (Language_Independent_Check): Reset Library flag if
|
||||
* prj-nmsc.adb (Language_Independent_Check): Reset Library flag if
|
||||
set and libraries are not supported.
|
||||
|
||||
2001-12-05 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_ch3.adb (Build_Derived_Private_Type): set Public status of
|
||||
private view explicitly, so the back-end can treat as a global
|
||||
* sem_ch3.adb (Build_Derived_Private_Type): set Public status of
|
||||
private view explicitly, so the back-end can treat as a global
|
||||
when appropriate.
|
||||
|
||||
2001-12-05 Ed Schonberg <schonber@gnat.com>
|
||||
@ -880,11 +994,11 @@
|
||||
|
||||
2001-12-05 Vincent Celier <celier@gnat.com>
|
||||
|
||||
* prj-nmsc.adb (Language_Independent_Check): Issue a warning if
|
||||
libraries are not supported and both attributes Library_Name and
|
||||
* prj-nmsc.adb (Language_Independent_Check): Issue a warning if
|
||||
libraries are not supported and both attributes Library_Name and
|
||||
Library_Dir are specified.
|
||||
|
||||
* prj-proc.adb (Expression): Set location of Result to location of
|
||||
* prj-proc.adb (Expression): Set location of Result to location of
|
||||
first term.
|
||||
|
||||
* Makefile.in: Add mlib.o, mlib-fil.o, mlib-tgt and mlib-utl to GNATLS.
|
||||
@ -905,7 +1019,7 @@
|
||||
|
||||
2001-12-05 Robert Dewar <dewar@gnat.com>
|
||||
|
||||
* checks.adb (Determine_Range): Increase cache size for checks.
|
||||
* checks.adb (Determine_Range): Increase cache size for checks.
|
||||
Minor reformatting
|
||||
|
||||
* exp_ch6.adb: Minor reformatting
|
||||
@ -914,20 +1028,20 @@
|
||||
subprograms as pure in the code generator is almost surely a mistake
|
||||
that will lead to unexpected results.
|
||||
|
||||
* exp_util.adb (Remove_Side_Effects): Clean up old ??? comment and
|
||||
* exp_util.adb (Remove_Side_Effects): Clean up old ??? comment and
|
||||
change handling of conversions.
|
||||
|
||||
* g-regexp.adb: Use System.IO instead of Ada.Text_IO.
|
||||
|
||||
2001-12-05 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_ch3.adb (Analyze_Object_Declaration): If expression is an
|
||||
aggregate with static wrong size, attach generated Raise node to
|
||||
* sem_ch3.adb (Analyze_Object_Declaration): If expression is an
|
||||
aggregate with static wrong size, attach generated Raise node to
|
||||
declaration.
|
||||
|
||||
2001-12-05 Robert Dewar <dewar@gnat.com>
|
||||
|
||||
* sem_attr.adb (Analyze_Attribute): Defend against bad Val attribute.
|
||||
* sem_attr.adb (Analyze_Attribute): Defend against bad Val attribute.
|
||||
Fixes compilation abandoned bomb in B24009B.
|
||||
|
||||
2001-12-05 Ed Schonberg <schonber@gnat.com>
|
||||
@ -962,7 +1076,7 @@
|
||||
|
||||
* prj-nmsc.adb: Minor comment changes (modifying -> extends).
|
||||
|
||||
* prj-part.adb (Parse_Single_Project): Change Tok_Modifying to
|
||||
* prj-part.adb (Parse_Single_Project): Change Tok_Modifying to
|
||||
Tok_Extends.
|
||||
|
||||
* prj.adb (Initialize): Change Modifying to Extends.
|
||||
@ -975,10 +1089,10 @@
|
||||
|
||||
2001-12-05 Robert Dewar <dewar@gnat.com>
|
||||
|
||||
* sem_warn.adb: Remove stuff for conditionals, we are not going to
|
||||
* sem_warn.adb: Remove stuff for conditionals, we are not going to
|
||||
do this after all.
|
||||
|
||||
* sem_warn.ads: Remove stuff for conditionals, we are not going to
|
||||
* sem_warn.ads: Remove stuff for conditionals, we are not going to
|
||||
do this after all. Add 2001 to copyright notice
|
||||
|
||||
2001-12-04 Geert Bosch <bosch@gnat.com>
|
||||
@ -987,8 +1101,8 @@
|
||||
|
||||
2001-12-04 Robert Dewar <dewar@gnat.com>
|
||||
|
||||
* errout.adb (Error_Msg): Ignore attempt to put error msg at junk
|
||||
location if we already have errors. Stops some cases of cascaded
|
||||
* errout.adb (Error_Msg): Ignore attempt to put error msg at junk
|
||||
location if we already have errors. Stops some cases of cascaded
|
||||
errors.
|
||||
|
||||
* errout.adb: Improve comment.
|
||||
@ -999,7 +1113,7 @@
|
||||
(Analyze_Formal_Type_Definition): Defend against Error.
|
||||
(Analyze_Formal_Subprogram): Defend against Error.
|
||||
|
||||
* par-ch12.adb (F_Formal_Type_Declaration): In case of error,
|
||||
* par-ch12.adb (F_Formal_Type_Declaration): In case of error,
|
||||
remove following semicolon if present. Removes cascaded error.
|
||||
|
||||
2001-12-04 Douglas B. Rupp <rupp@gnat.com>
|
||||
@ -1016,14 +1130,14 @@
|
||||
|
||||
2001-12-04 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* einfo.ads: Block_Node points to the identifier of the block, not to
|
||||
the block node itself, to preserve the link when the block is
|
||||
rewritten, e.g. within an if-statement with a static condition.
|
||||
* einfo.ads: Block_Node points to the identifier of the block, not to
|
||||
the block node itself, to preserve the link when the block is
|
||||
rewritten, e.g. within an if-statement with a static condition.
|
||||
|
||||
* inline.adb (Cleanup_Scopes): recover block statement from block
|
||||
* inline.adb (Cleanup_Scopes): recover block statement from block
|
||||
entity using new meaning of Block_Node.
|
||||
|
||||
* sem_ch5.adb (Analyze_Block_Statement): set Block_Node to point to
|
||||
* sem_ch5.adb (Analyze_Block_Statement): set Block_Node to point to
|
||||
identifier of block node, rather than to node itself.
|
||||
|
||||
2001-12-04 Gary Dismukes <dismukes@gnat.com>
|
||||
@ -1031,7 +1145,7 @@
|
||||
* layout.adb:
|
||||
(Get_Max_Size): Fix "start of processing" comment to say Get_Max_Size.
|
||||
(Discrimify): Go back to setting the Etypes of the selected component
|
||||
because the Vname component does not exist at this point and will
|
||||
because the Vname component does not exist at this point and will
|
||||
fail name resolution. Also set Analyzed.
|
||||
Remove with and use of Sem_Res.
|
||||
|
||||
@ -1048,28 +1162,28 @@
|
||||
|
||||
2001-12-04 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_ch7.adb (New_Private_Type): Set Is_Tagged_Type flag before
|
||||
* sem_ch7.adb (New_Private_Type): Set Is_Tagged_Type flag before
|
||||
processing discriminants to diagnose illegal default values.
|
||||
|
||||
2001-12-04 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_attr.adb (Resolve_Attribute): Handle properly an non-classwide
|
||||
access discriminant within a type extension that constrains its
|
||||
* sem_attr.adb (Resolve_Attribute): Handle properly an non-classwide
|
||||
access discriminant within a type extension that constrains its
|
||||
parent discriminants.
|
||||
|
||||
2001-12-04 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_ch3.adb (Find_Type_Of_Subtype_Indic): If subtype indication
|
||||
* sem_ch3.adb (Find_Type_Of_Subtype_Indic): If subtype indication
|
||||
is malformed, use instance of Any_Id to allow analysis to proceed.
|
||||
|
||||
* par-ch12.adb (P_Formal_Type_Declaration): Propagate Error if
|
||||
* par-ch12.adb (P_Formal_Type_Declaration): Propagate Error if
|
||||
type definition is illegal.
|
||||
(P_Formal_Derived_Type_Definition): Better recovery when TAGGED is
|
||||
misplaced.
|
||||
|
||||
2001-12-04 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_warn.adb (Output_Unreferenced_Messages): Extend previous fix to
|
||||
* sem_warn.adb (Output_Unreferenced_Messages): Extend previous fix to
|
||||
constants.
|
||||
|
||||
2001-12-04 Robert Dewar <dewar@gnat.com>
|
||||
@ -1080,13 +1194,13 @@
|
||||
|
||||
* exp_util.adb: Minor reformatting from last change
|
||||
|
||||
* errout.adb (Check_For_Warning): For a Raised_Constraint_Error node
|
||||
which is a rewriting of an expression, traverse the original
|
||||
* errout.adb (Check_For_Warning): For a Raised_Constraint_Error node
|
||||
which is a rewriting of an expression, traverse the original
|
||||
expression to remove warnings that may have been posted on it.
|
||||
|
||||
2001-12-04 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* exp_util.adb (Must_Be_Aligned): Return false for a component of a
|
||||
* exp_util.adb (Must_Be_Aligned): Return false for a component of a
|
||||
record that has other packed components.
|
||||
|
||||
2001-12-04 Douglass B. Rupp <rupp@gnat.com>
|
||||
@ -1099,7 +1213,7 @@
|
||||
|
||||
2001-12-04 Arnaud Charlet <charlet@gnat.com>
|
||||
|
||||
* Makefile.adalib: Clarify step 3 (use of gnat.adc) as it causes
|
||||
* Makefile.adalib: Clarify step 3 (use of gnat.adc) as it causes
|
||||
more confusion than it solves.
|
||||
|
||||
2001-12-04 Geert bosch <bosch@gnat.com>
|
||||
@ -1108,12 +1222,12 @@
|
||||
|
||||
2001-12-04 Geert Bosch <bosch@gnat.com>
|
||||
|
||||
* Makefile.in (update-sources): New target.
|
||||
* Makefile.in (update-sources): New target.
|
||||
For use by gcc_release script.
|
||||
|
||||
2001-12-04 Ed Schonberg <schonber@gnat.com>
|
||||
|
||||
* sem_prag.adb (Analyze_Pragma, case Validity_Checks): do not treat as
|
||||
* sem_prag.adb (Analyze_Pragma, case Validity_Checks): do not treat as
|
||||
a configuration pragma, it is now legal wherever a pragma can appear.
|
||||
|
||||
2001-12-04 Zack Weinberg <zack@codesourcery.com>
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
# Top level makefile fragment for GNU Ada (GNAT).
|
||||
# Copyright (C) 1994, 1995, 1996, 1997, 1997, 1999, 2000, 2001
|
||||
# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
|
||||
# Free Software Foundation, Inc.
|
||||
|
||||
#This file is part of GNU CC.
|
||||
@ -22,7 +22,7 @@
|
||||
# This file provides the language dependent support in the main Makefile.
|
||||
# Each language makefile fragment must provide the following targets:
|
||||
#
|
||||
# foo.all.build, foo.all.cross, foo.start.encap, foo.rest.encap,
|
||||
# foo.all.cross, foo.start.encap, foo.rest.encap,
|
||||
# foo.info, foo.dvi,
|
||||
# foo.install-normal, foo.install-common, foo.install-info, foo.install-man,
|
||||
# foo.uninstall, foo.mostlyclean, foo.clean, foo.distclean, foo.extraclean,
|
||||
@ -47,21 +47,21 @@ shext =
|
||||
|
||||
# Extra flags to pass to recursive makes.
|
||||
BOOT_ADAFLAGS= $(ADAFLAGS)
|
||||
ADAFLAGS= -W -Wall -gnatpg -gnata
|
||||
ADAFLAGS= -gnatpg -gnata
|
||||
GNATLIBFLAGS= -W -Wall -gnatpg
|
||||
GNATLIBCFLAGS= -g -O2
|
||||
ADA_INCLUDE_DIR = $(libsubdir)/adainclude
|
||||
ADA_RTL_OBJ_DIR = $(libsubdir)/adalib
|
||||
THREAD_KIND=native
|
||||
TRACE=no
|
||||
GNATBIND = gnatbind
|
||||
ADA_FLAGS_TO_PASS = \
|
||||
"ADA_CFLAGS=$(CFLAGS)" \
|
||||
"ADA_FOR_BUILD=$(ADA_FOR_BUILD)" \
|
||||
"ADA_INCLUDE_DIR=$(ADA_INCLUDE_DIR)" \
|
||||
"ADA_RTL_OBJ_DIR=$(ADA_RTL_OBJ_DIR)" \
|
||||
"ADAFLAGS=$(ADAFLAGS)" \
|
||||
"ADA_FOR_TARGET=$(ADA_FOR_TARGET)" \
|
||||
"INSTALL_DATA=$(INSTALL_DATA)" \
|
||||
"ADA_FOR_BUILD=$(ADA_FOR_BUILD)" \
|
||||
"ADA_INCLUDE_DIR=$(ADA_INCLUDE_DIR)" \
|
||||
"ADA_RTL_OBJ_DIR=$(ADA_RTL_OBJ_DIR)" \
|
||||
"ADAFLAGS=$(ADAFLAGS)" \
|
||||
"ADA_FOR_TARGET=$(ADA_FOR_TARGET)" \
|
||||
"INSTALL_DATA=$(INSTALL_DATA)" \
|
||||
"INSTALL_PROGRAM=$(INSTALL_PROGRAM)"
|
||||
|
||||
# Define the names for selecting Ada in LANGUAGES.
|
||||
@ -72,110 +72,79 @@ Ada ada: gnat1$(exeext) gnatbind$(exeext)
|
||||
|
||||
# There are too many Ada sources to check against here. Let's
|
||||
# always force the recursive make.
|
||||
ADA_TOOLS_FLAGS_TO_PASS=\
|
||||
"CC=../../xgcc -B../../" \
|
||||
"CFLAGS=$(CFLAGS)" \
|
||||
"exeext=$(exeext)" \
|
||||
"ADAFLAGS=$(ADAFLAGS)" \
|
||||
"ADA_INCLUDES=-I../rts" \
|
||||
"GNATMAKE=../../gnatmake" \
|
||||
"GNATLINK=../../gnatlink" \
|
||||
"GNATBIND=../../gnatbind"
|
||||
|
||||
gnat1$(exeext): prefix.o attribs.o $(LIBDEPS) $(BACKEND) force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
$(MAKE) -C ada $(SUBDIR_FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
../gnat1$(exeext)
|
||||
|
||||
gnatbind$(exeext): $(CONFIG_H) prefix.o force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
gnatbind$(exeext): force
|
||||
$(MAKE) -C ada $(SUBDIR_FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
../gnatbind$(exeext)
|
||||
|
||||
gnatmake$(exeext): $(CONFIG_H) prefix.o force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
../gnatmake$(exeext)
|
||||
|
||||
gnatbl$(exeext): $(CONFIG_H) prefix.o force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
../gnatbl$(exeext)
|
||||
|
||||
gnatchop$(exeext): $(CONFIG_H) prefix.o force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
../gnatchop$(exeext)
|
||||
|
||||
gnatcmd$(exeext): $(CONFIG_H) prefix.o force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
../gnatcmd$(exeext)
|
||||
|
||||
gnatlink$(exeext): $(CONFIG_H) prefix.o force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
../gnatlink$(exeext)
|
||||
|
||||
gnatkr$(exeext): $(CONFIG_H) prefix.o force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
../gnatkr$(exeext)
|
||||
|
||||
gnatls$(exeext): $(CONFIG_H) prefix.o force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
../gnatls$(exeext)
|
||||
|
||||
gnatmem$(exeext): $(CONFIG_H) prefix.o force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
../gnatmem$(exeext)
|
||||
|
||||
gnatprep$(exeext): $(CONFIG_H) prefix.o force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
../gnatprep$(exeext)
|
||||
|
||||
gnatpsta$(exeext): $(CONFIG_H) prefix.o force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
../gnatpsta$(exeext)
|
||||
|
||||
gnatpsys$(exeext): $(CONFIG_H) prefix.o force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
../gnatpsys$(exeext)
|
||||
|
||||
gnatxref$(exeext): $(CONFIG_H) prefix.o force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
../gnatxref$(exeext)
|
||||
|
||||
gnatfind$(exeext): $(CONFIG_H) prefix.o force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
../gnatfind$(exeext)
|
||||
|
||||
# Gnatlbr is extra tool only used on VMS
|
||||
|
||||
gnatlbr$(exeext): $(CONFIG_H) prefix.o force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
../gnatlbr$(exeext)
|
||||
|
||||
# use target-gcc
|
||||
# use target-gcc target-gnatmake target-gnatbind target-gnatlink
|
||||
gnattools: $(GCC_PARTS) force
|
||||
$(MAKE) $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
CC="../xgcc -B../" STAGE_PREFIX=../ \
|
||||
gnatbl$(exeext) gnatchop$(exeext) gnatcmd$(exeext) \
|
||||
gnatkr$(exeext) gnatlink$(exeext) \
|
||||
gnatls$(exeext) gnatmake$(exeext) \
|
||||
gnatprep$(exeext) gnatpsta$(exeext) gnatpsys$(exeext) \
|
||||
gnatxref$(exeext) gnatfind$(exeext) $(EXTRA_GNATTOOLS)
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
ADA_INCLUDES="-I- -I../rts"\
|
||||
CC="../../xgcc -B../../" STAGE_PREFIX=../../ gnattools1
|
||||
$(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools2
|
||||
$(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools3
|
||||
|
||||
# use host-gcc
|
||||
regnattools:
|
||||
$(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools1-re
|
||||
$(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools2
|
||||
$(MAKE) -C ada $(ADA_TOOLS_FLAGS_TO_PASS) gnattools3
|
||||
|
||||
# use host-gcc host-gnatmake host-gnatbind host-gnatlink
|
||||
# put the host RTS dir first in the PATH to hide the default runtime
|
||||
# files that are among the sources
|
||||
RTS_DIR:=$(dir $(subst \,/,$(shell $(CC) -print-libgcc-file-name)))
|
||||
cross-gnattools: force
|
||||
$(MAKE) $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS) \
|
||||
gnatbl$(exeext) gnatchop$(exeext) gnatcmd$(exeext) \
|
||||
gnatkr$(exeext) gnatlink$(exeext) \
|
||||
gnatls$(exeext) gnatmake$(exeext) \
|
||||
gnatprep$(exeext) gnatpsta$(exeext) gnatpsys$(exeext) \
|
||||
gnatxref$(exeext) gnatfind$(exeext) $(EXTRA_GNATTOOLS)
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) $(ADA_FLAGS_TO_PASS)\
|
||||
ADA_INCLUDES="-I$(RTS_DIR)adainclude -I$(RTS_DIR)adalib" \
|
||||
GNATMAKE="gnatmake" \
|
||||
GNATBIND="gnatbind" \
|
||||
GNATLINK="gnatlink" \
|
||||
LIBGNAT="" \
|
||||
gnattools1-re gnattools2
|
||||
|
||||
rts-none: force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) GNATMAKE=../gnatmake rts-none
|
||||
|
||||
install-rts-none: force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) install-rts RTS_NAME=none
|
||||
|
||||
rts-ravenscar: force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) GNATMAKE=../gnatmake rts-ravenscar
|
||||
|
||||
install-rts-ravenscar: force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) install-rts RTS_NAME=ravenscar
|
||||
|
||||
# use target-gcc
|
||||
gnatlib: force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) \
|
||||
CC="../xgcc -B../" ADAC="../xgcc -B../" STAGE_PREFIX=../ \
|
||||
GNATLIBFLAGS="$(GNATLIBFLAGS)" \
|
||||
GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \
|
||||
TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" \
|
||||
THREAD_KIND="$(THREAD_KIND)" \
|
||||
TRACE="$(TRACE)" \
|
||||
gnatlib
|
||||
|
||||
# use target-gcc
|
||||
gnatlib-shared: force
|
||||
$(MAKE) -C ada $(FLAGS_TO_PASS) \
|
||||
CC="../xgcc -B../" ADAC="../xgcc -B../" STAGE_PREFIX=../ \
|
||||
GNATLIBFLAGS="$(GNATLIBFLAGS)" \
|
||||
GNATLIBCFLAGS="$(GNATLIBCFLAGS)" \
|
||||
GNATLIBLDFLAGS="$(GNATLIBLDFLAGS)" \
|
||||
TARGET_LIBGCC2_CFLAGS="$(TARGET_LIBGCC2_CFLAGS)" \
|
||||
THREAD_KIND="$(THREAD_KIND)" \
|
||||
TRACE="$(TRACE)" \
|
||||
gnatlib-shared
|
||||
|
||||
# use only for native compiler
|
||||
@ -187,7 +156,6 @@ gnat-cross: force
|
||||
|
||||
# Build hooks:
|
||||
|
||||
ada.all.build:
|
||||
ada.all.cross:
|
||||
-if [ -f gnatbind$(exeext) ] ; \
|
||||
then \
|
||||
@ -201,9 +169,9 @@ ada.all.cross:
|
||||
then \
|
||||
$(MV) gnatchop$(exeext) gnatchop-cross$(exeext); \
|
||||
fi
|
||||
-if [ -f gnatcmd$(exeext) ] ; \
|
||||
-if [ -f gnat$(exeext) ] ; \
|
||||
then \
|
||||
$(MV) gnatcmd$(exeext) gnatcmd-cross$(exeext); \
|
||||
$(MV) gnat$(exeext) gnat-cross$(exeext); \
|
||||
fi
|
||||
-if [ -f gnatkr$(exeext) ] ; \
|
||||
then \
|
||||
@ -225,6 +193,10 @@ ada.all.cross:
|
||||
then \
|
||||
$(MV) gnatmem$(exeext) gnatmem-cross$(exeext); \
|
||||
fi
|
||||
-if [ -f gnatname$(exeext) ] ; \
|
||||
then \
|
||||
$(MV) gnatname$(exeext) gnatname-cross$(exeext); \
|
||||
fi
|
||||
-if [ -f gnatprep$(exeext) ] ; \
|
||||
then \
|
||||
$(MV) gnatprep$(exeext) gnatprep-cross$(exeext); \
|
||||
@ -233,10 +205,6 @@ ada.all.cross:
|
||||
then \
|
||||
$(MV) gnatpsta$(exeext) gnatpsta-cross$(exeext); \
|
||||
fi
|
||||
-if [ -f gnatpsys$(exeext) ] ; \
|
||||
then \
|
||||
$(MV) gnatpsys$(exeext) gnatpsys-cross$(exeext); \
|
||||
fi
|
||||
-if [ -f gnatxref$(exeext) ] ; \
|
||||
then \
|
||||
$(MV) gnatxref$(exeext) gnatxref-cross$(exeext); \
|
||||
@ -259,7 +227,7 @@ ada.install-normal:
|
||||
|
||||
# Install the binder program as $(target_alias)-gnatbind
|
||||
# and also as either gnatbind (if native) or $(tooldir)/bin/gnatbind
|
||||
# likewise for gnatf, gnatchop, and gnatlink, gnatkr, gnatmake, gnatcmd,
|
||||
# likewise for gnatf, gnatchop, and gnatlink, gnatkr, gnatmake, gnat,
|
||||
# gnatprep, gnatbl, gnatls, gnatxref, gnatfind
|
||||
ada.install-common:
|
||||
-if [ -f gnat1$(exeext) ] ; \
|
||||
@ -294,7 +262,7 @@ ada.install-common:
|
||||
fi
|
||||
-if [ -f gnat1$(exeext) ] ; \
|
||||
then \
|
||||
if [ -f gnatchop-cross$(exeext) ] ; \
|
||||
if [ -f gnatchop-cross$(shext) ] ; \
|
||||
then \
|
||||
$(RM) $(bindir)/$(target_alias)-gnatchop$(shext); \
|
||||
$(INSTALL_PROGRAM) $(srcdir)/ada/gnatchop$(shext) $(bindir)/$(target_alias)-gnatchop$(shext); \
|
||||
@ -324,17 +292,17 @@ ada.install-common:
|
||||
fi
|
||||
-if [ -f gnat1$(exeext) ] ; \
|
||||
then \
|
||||
if [ -f gnatcmd-cross$(exeext) ] ; \
|
||||
if [ -f gnat-cross$(exeext) ] ; \
|
||||
then \
|
||||
$(RM) $(bindir)/$(target_alias)-gnat$(exeext); \
|
||||
$(INSTALL_PROGRAM) gnatcmd-cross$(exeext) $(bindir)/$(target_alias)-gnat$(exeext); \
|
||||
$(INSTALL_PROGRAM) gnat-cross$(exeext) $(bindir)/$(target_alias)-gnat$(exeext); \
|
||||
if [ -d $(tooldir)/bin/. ] ; then \
|
||||
rm -f $(tooldir)/bin/gnat$(exeext); \
|
||||
$(INSTALL_PROGRAM) gnatcmd-cross$(exeext) $(tooldir)/bin/gnat$(exeext); \
|
||||
$(INSTALL_PROGRAM) gnat-cross$(exeext) $(tooldir)/bin/gnat$(exeext); \
|
||||
fi; \
|
||||
else \
|
||||
$(RM) $(bindir)/gnat$(exeext); \
|
||||
$(INSTALL_PROGRAM) gnatcmd$(exeext) $(bindir)/gnat$(exeext); \
|
||||
$(INSTALL_PROGRAM) gnat$(exeext) $(bindir)/gnat$(exeext); \
|
||||
fi ; \
|
||||
fi
|
||||
-if [ -f gnat1$(exeext) ] ; \
|
||||
@ -409,6 +377,17 @@ ada.install-common:
|
||||
fi ; \
|
||||
fi
|
||||
-if [ -f gnat1$(exeext) ] ; \
|
||||
then \
|
||||
if [ -f gnatname-cross$(exeext) ] ; \
|
||||
then \
|
||||
$(RM) $(bindir)/$(target_alias)-gnatname$(exeext); \
|
||||
$(INSTALL_PROGRAM) gnatname-cross$(exeext) $(bindir)/$(target_alias)-gnatname$(exeext); \
|
||||
else \
|
||||
$(RM) $(bindir)/gnatname$(exeext); \
|
||||
$(INSTALL_PROGRAM) gnatname$(exeext) $(bindir)/gnatname$(exeext); \
|
||||
fi ; \
|
||||
fi
|
||||
-if [ -f gnat1$(exeext) ] ; \
|
||||
then \
|
||||
if [ -f gnatprep-cross$(exeext) ] ; \
|
||||
then \
|
||||
@ -438,21 +417,6 @@ ada.install-common:
|
||||
$(INSTALL_PROGRAM) gnatpsta$(exeext) $(bindir)/gnatpsta$(exeext); \
|
||||
fi ; \
|
||||
fi
|
||||
-if [ -f gnat1$(exeext) ] ; \
|
||||
then \
|
||||
if [ -f gnatpsys-cross$(exeext) ] ; \
|
||||
then \
|
||||
$(RM) $(bindir)/$(target_alias)-gnatpsys$(exeext); \
|
||||
$(INSTALL_PROGRAM) gnatpsys-cross$(exeext) $(bindir)/$(target_alias)-gnatpsys$(exeext); \
|
||||
if [ -d $(tooldir)/bin/. ] ; then \
|
||||
rm -f $(tooldir)/bin/gnatpsys$(exeext); \
|
||||
$(INSTALL_PROGRAM) gnatpsys-cross$(exeext) $(tooldir)/bin/gnatpsys$(exeext); \
|
||||
fi; \
|
||||
else \
|
||||
$(RM) $(bindir)/gnatpsys$(exeext); \
|
||||
$(INSTALL_PROGRAM) gnatpsys$(exeext) $(bindir)/gnatpsys$(exeext); \
|
||||
fi ; \
|
||||
fi
|
||||
-if [ -f gnat1$(exeext) ] ; \
|
||||
then \
|
||||
if [ -f gnatxref-cross$(exeext) ] ; \
|
||||
@ -475,9 +439,6 @@ ada.install-common:
|
||||
$(INSTALL_PROGRAM) gnatfind$(exeext) $(bindir)/gnatfind$(exeext); \
|
||||
fi ; \
|
||||
fi
|
||||
#
|
||||
# Gnatlbr is only use on VMS
|
||||
#
|
||||
-if [ -f gnat1$(exeext) ] ; \
|
||||
then \
|
||||
if [ -f gnatchop$(exeext) ] ; \
|
||||
@ -485,6 +446,11 @@ ada.install-common:
|
||||
$(RM) $(bindir)/gnatchop$(exeext); \
|
||||
$(INSTALL_PROGRAM) gnatchop$(exeext) $(bindir)/gnatchop$(exeext); \
|
||||
fi ; \
|
||||
#
|
||||
# Gnatlbr is only used on VMS.
|
||||
#
|
||||
-if [ -f gnat1$(exeext) ] ; \
|
||||
then \
|
||||
if [ -f gnatlbr$(exeext) ] ; \
|
||||
then \
|
||||
$(RM) $(bindir)/gnatlbr$(exeext); \
|
||||
@ -517,44 +483,44 @@ ada.uninstall:
|
||||
-$(RM) $(bindir)/gnatbind$(exeext)
|
||||
-$(RM) $(bindir)/gnatbl$(exeext)
|
||||
-$(RM) $(bindir)/gnatchop$(exeext)
|
||||
-$(RM) $(bindir)/gnatcmd$(exeext)
|
||||
-$(RM) $(bindir)/gnat$(exeext)
|
||||
-$(RM) $(bindir)/gnatdll$(exeext)
|
||||
-$(RM) $(bindir)/gnatkr$(exeext)
|
||||
-$(RM) $(bindir)/gnatlink$(exeext)
|
||||
-$(RM) $(bindir)/gnatls$(exeext)
|
||||
-$(RM) $(bindir)/gnatmake$(exeext)
|
||||
-$(RM) $(bindir)/gnatmem$(exeext)
|
||||
-$(RM) $(bindir)/gnatname$(exeext)
|
||||
-$(RM) $(bindir)/gnatprep$(exeext)
|
||||
-$(RM) $(bindir)/gnatpsta$(exeext)
|
||||
-$(RM) $(bindir)/gnatpsys$(exeext)
|
||||
-$(RM) $(bindir)/$(target_alias)-gnatbind$(exeext)
|
||||
-$(RM) $(bindir)/$(target_alias)-gnatbl$(exeext)
|
||||
-$(RM) $(bindir)/$(target_alias)-gnatchop$(exeext)
|
||||
-$(RM) $(bindir)/$(target_alias)-gnatcmd$(exeext)
|
||||
-$(RM) $(bindir)/$(target_alias)-gnat$(exeext)
|
||||
-$(RM) $(bindir)/$(target_alias)-gnatkr(exeext)
|
||||
-$(RM) $(bindir)/$(target_alias)-gnatlink$(exeext)
|
||||
-$(RM) $(bindir)/$(target_alias)-gnatls$(exeext)
|
||||
-$(RM) $(bindir)/$(target_alias)-gnatmake$(exeext)
|
||||
-$(RM) $(bindir)/$(target_alias)-gnatmem$(exeext)
|
||||
-$(RM) $(bindir)/$(target_alias)-gnatname$(exeext)
|
||||
-$(RM) $(bindir)/$(target_alias)-gnatprep$(exeext)
|
||||
-$(RM) $(bindir)/$(target_alias)-gnatpsta$(exeext)
|
||||
-$(RM) $(bindir)/$(target_alias)-gnatpsys$(exeext)
|
||||
-$(RM) $(tooldir)/bin/gnatbind$(exeext)
|
||||
-$(RM) $(tooldir)/bin/gnatbl$(exeext)
|
||||
-$(RM) $(tooldir)/bin/gnatchop$(exeext)
|
||||
-$(RM) $(tooldir)/bin/gnatcmd$(exeext)
|
||||
-$(RM) $(tooldir)/bin/gnat$(exeext)
|
||||
-$(RM) $(tooldir)/bin/gnatdll$(exeext)
|
||||
-$(RM) $(tooldir)/bin/gnatkr$(exeext)
|
||||
-$(RM) $(tooldir)/bin/gnatlink$(exeext)
|
||||
-$(RM) $(tooldir)/bin/gnatls$(exeext)
|
||||
-$(RM) $(tooldir)/bin/gnatmake$(exeext)
|
||||
-$(RM) $(tooldir)/bin/gnatmem$(exeext)
|
||||
-$(RM) $(tooldir)/bin/gnatname$(exeext)
|
||||
-$(RM) $(tooldir)/bin/gnatprep$(exeext)
|
||||
-$(RM) $(tooldir)/bin/gnatpsta$(exeext)
|
||||
-$(RM) $(tooldir)/bin/gnatpsys$(exeext)
|
||||
# Gnatlbr and Gnatchop are only used on VMS
|
||||
-$(RM) $(bindir)/gnatlbr$(exeext) $(bindir)/gnatchop$(exeext)
|
||||
|
||||
|
||||
# Clean hooks:
|
||||
# A lot of the ancillary files are deleted by the main makefile.
|
||||
# We just have to delete files specific to us.
|
||||
@ -568,22 +534,23 @@ ada.distclean:
|
||||
-$(RM) ada/Makefile
|
||||
-$(RM) gnatbl$(exeext)
|
||||
-$(RM) gnatchop$(exeext)
|
||||
-$(RM) gnatcmd$(exeext)
|
||||
-$(RM) gnat$(exeext)
|
||||
-$(RM) gnatdll$(exeext)
|
||||
-$(RM) gnatkr$(exeext)
|
||||
-$(RM) gnatlink$(exeext)
|
||||
-$(RM) gnatls$(exeext)
|
||||
-$(RM) gnatmake$(exeext)
|
||||
-$(RM) gnatmem$(exeext)
|
||||
-$(RM) gnatname$(exeext)
|
||||
-$(RM) gnatprep$(exeext)
|
||||
-$(RM) gnatpsta$(exeext)
|
||||
-$(RM) gnatpsys$(exeext)
|
||||
-$(RM) gnatfind$(exeext)
|
||||
-$(RM) gnatxref$(exeext)
|
||||
# Gnatlbr and Gnatchop are only used on VMS
|
||||
-$(RM) gnatchop$(exeext) gnatlbr$(exeext)
|
||||
# Gnatlbr is only used on VMS
|
||||
-$(RM) gnatlbr$(exeext)
|
||||
-$(RM) ada/rts/*
|
||||
-$(RMDIR) ada/rts
|
||||
-$(RM) ada/tools/*
|
||||
-$(RMDIR) ada/tools
|
||||
ada.extraclean:
|
||||
ada.maintainer-clean:
|
||||
|
||||
4273
gcc/ada/Makefile.in
4273
gcc/ada/Makefile.in
File diff suppressed because it is too large
Load Diff
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.37 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Florida State University --
|
||||
-- --
|
||||
@ -41,6 +41,12 @@ with System.OS_Primitives;
|
||||
with System.Soft_Links;
|
||||
-- Used for Timed_Delay
|
||||
|
||||
with System.Traces;
|
||||
-- Used for Send_Trace_Info
|
||||
|
||||
with System.Parameters;
|
||||
-- used for Runtime_Traces
|
||||
|
||||
package body Ada.Calendar.Delays is
|
||||
|
||||
package OSP renames System.OS_Primitives;
|
||||
@ -48,6 +54,8 @@ package body Ada.Calendar.Delays is
|
||||
|
||||
use type SSL.Timed_Delay_Call;
|
||||
|
||||
use System.Traces;
|
||||
|
||||
-- Earlier, the following operations were implemented using
|
||||
-- System.Time_Operations. The idea was to avoid sucking in the tasking
|
||||
-- packages. This did not work. Logically, we can't have it both ways.
|
||||
@ -68,8 +76,16 @@ package body Ada.Calendar.Delays is
|
||||
|
||||
procedure Delay_For (D : Duration) is
|
||||
begin
|
||||
if System.Parameters.Runtime_Traces then
|
||||
Send_Trace_Info (W_Delay, D);
|
||||
end if;
|
||||
|
||||
SSL.Timed_Delay.all (Duration'Min (D, OSP.Max_Sensible_Delay),
|
||||
OSP.Relative);
|
||||
OSP.Relative);
|
||||
|
||||
if System.Parameters.Runtime_Traces then
|
||||
Send_Trace_Info (M_Delay, D);
|
||||
end if;
|
||||
end Delay_For;
|
||||
|
||||
-----------------
|
||||
@ -77,8 +93,18 @@ package body Ada.Calendar.Delays is
|
||||
-----------------
|
||||
|
||||
procedure Delay_Until (T : Time) is
|
||||
D : constant Duration := To_Duration (T);
|
||||
|
||||
begin
|
||||
SSL.Timed_Delay.all (To_Duration (T), OSP.Absolute_Calendar);
|
||||
if System.Parameters.Runtime_Traces then
|
||||
Send_Trace_Info (WU_Delay, D);
|
||||
end if;
|
||||
|
||||
SSL.Timed_Delay.all (D, OSP.Absolute_Calendar);
|
||||
|
||||
if System.Parameters.Runtime_Traces then
|
||||
Send_Trace_Info (M_Delay, D);
|
||||
end if;
|
||||
end Delay_Until;
|
||||
|
||||
--------------------
|
||||
|
||||
336
gcc/ada/a-chlat9.ads
Normal file
336
gcc/ada/a-chlat9.ads
Normal file
@ -0,0 +1,336 @@
|
||||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUNTIME COMPONENTS --
|
||||
-- --
|
||||
-- A D A . C H A R A C T E R S . L A T I N _ 9 --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 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 modifications made to Ada.Characters.Latin_1, noted --
|
||||
-- in the text, to derive the equivalent Latin-9 package. --
|
||||
-- --
|
||||
-- GNAT is free software; you can redistribute it and/or modify it under --
|
||||
-- terms of the GNU General Public License as published by the Free Soft- --
|
||||
-- ware Foundation; either version 2, or (at your option) any later ver- --
|
||||
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
||||
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
||||
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
||||
-- for more details. You should have received a copy of the GNU General --
|
||||
-- Public License distributed with GNAT; see file COPYING. If not, write --
|
||||
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
||||
-- MA 02111-1307, USA. --
|
||||
-- --
|
||||
-- As a special exception, if other files instantiate generics from this --
|
||||
-- unit, or you link this unit with other files to produce an executable, --
|
||||
-- this unit does not by itself cause the resulting executable to be --
|
||||
-- covered by the GNU General Public License. This exception does not --
|
||||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- GNAT was originally developed by the GNAT team at New York University. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package provides definitions for Latin-9 (ISO-8859-9) analogous to
|
||||
-- those defined in the standard package Ada.Characters.Latin_1 for Latin-1.
|
||||
|
||||
package Ada.Characters.Latin_9 is
|
||||
pragma Pure (Latin_9);
|
||||
|
||||
------------------------
|
||||
-- Control Characters --
|
||||
------------------------
|
||||
|
||||
NUL : constant Character := Character'Val (0);
|
||||
SOH : constant Character := Character'Val (1);
|
||||
STX : constant Character := Character'Val (2);
|
||||
ETX : constant Character := Character'Val (3);
|
||||
EOT : constant Character := Character'Val (4);
|
||||
ENQ : constant Character := Character'Val (5);
|
||||
ACK : constant Character := Character'Val (6);
|
||||
BEL : constant Character := Character'Val (7);
|
||||
BS : constant Character := Character'Val (8);
|
||||
HT : constant Character := Character'Val (9);
|
||||
LF : constant Character := Character'Val (10);
|
||||
VT : constant Character := Character'Val (11);
|
||||
FF : constant Character := Character'Val (12);
|
||||
CR : constant Character := Character'Val (13);
|
||||
SO : constant Character := Character'Val (14);
|
||||
SI : constant Character := Character'Val (15);
|
||||
|
||||
DLE : constant Character := Character'Val (16);
|
||||
DC1 : constant Character := Character'Val (17);
|
||||
DC2 : constant Character := Character'Val (18);
|
||||
DC3 : constant Character := Character'Val (19);
|
||||
DC4 : constant Character := Character'Val (20);
|
||||
NAK : constant Character := Character'Val (21);
|
||||
SYN : constant Character := Character'Val (22);
|
||||
ETB : constant Character := Character'Val (23);
|
||||
CAN : constant Character := Character'Val (24);
|
||||
EM : constant Character := Character'Val (25);
|
||||
SUB : constant Character := Character'Val (26);
|
||||
ESC : constant Character := Character'Val (27);
|
||||
FS : constant Character := Character'Val (28);
|
||||
GS : constant Character := Character'Val (29);
|
||||
RS : constant Character := Character'Val (30);
|
||||
US : constant Character := Character'Val (31);
|
||||
|
||||
--------------------------------
|
||||
-- ISO 646 Graphic Characters --
|
||||
--------------------------------
|
||||
|
||||
Space : constant Character := ' '; -- Character'Val(32)
|
||||
Exclamation : constant Character := '!'; -- Character'Val(33)
|
||||
Quotation : constant Character := '"'; -- Character'Val(34)
|
||||
Number_Sign : constant Character := '#'; -- Character'Val(35)
|
||||
Dollar_Sign : constant Character := '$'; -- Character'Val(36)
|
||||
Percent_Sign : constant Character := '%'; -- Character'Val(37)
|
||||
Ampersand : constant Character := '&'; -- Character'Val(38)
|
||||
Apostrophe : constant Character := '''; -- Character'Val(39)
|
||||
Left_Parenthesis : constant Character := '('; -- Character'Val(40)
|
||||
Right_Parenthesis : constant Character := ')'; -- Character'Val(41)
|
||||
Asterisk : constant Character := '*'; -- Character'Val(42)
|
||||
Plus_Sign : constant Character := '+'; -- Character'Val(43)
|
||||
Comma : constant Character := ','; -- Character'Val(44)
|
||||
Hyphen : constant Character := '-'; -- Character'Val(45)
|
||||
Minus_Sign : Character renames Hyphen;
|
||||
Full_Stop : constant Character := '.'; -- Character'Val(46)
|
||||
Solidus : constant Character := '/'; -- Character'Val(47)
|
||||
|
||||
-- Decimal digits '0' though '9' are at positions 48 through 57
|
||||
|
||||
Colon : constant Character := ':'; -- Character'Val(58)
|
||||
Semicolon : constant Character := ';'; -- Character'Val(59)
|
||||
Less_Than_Sign : constant Character := '<'; -- Character'Val(60)
|
||||
Equals_Sign : constant Character := '='; -- Character'Val(61)
|
||||
Greater_Than_Sign : constant Character := '>'; -- Character'Val(62)
|
||||
Question : constant Character := '?'; -- Character'Val(63)
|
||||
|
||||
Commercial_At : constant Character := '@'; -- Character'Val(64)
|
||||
|
||||
-- Letters 'A' through 'Z' are at positions 65 through 90
|
||||
|
||||
Left_Square_Bracket : constant Character := '['; -- Character'Val (91)
|
||||
Reverse_Solidus : constant Character := '\'; -- Character'Val (92)
|
||||
Right_Square_Bracket : constant Character := ']'; -- Character'Val (93)
|
||||
Circumflex : constant Character := '^'; -- Character'Val (94)
|
||||
Low_Line : constant Character := '_'; -- Character'Val (95)
|
||||
|
||||
Grave : constant Character := '`'; -- Character'Val (96)
|
||||
LC_A : constant Character := 'a'; -- Character'Val (97)
|
||||
LC_B : constant Character := 'b'; -- Character'Val (98)
|
||||
LC_C : constant Character := 'c'; -- Character'Val (99)
|
||||
LC_D : constant Character := 'd'; -- Character'Val (100)
|
||||
LC_E : constant Character := 'e'; -- Character'Val (101)
|
||||
LC_F : constant Character := 'f'; -- Character'Val (102)
|
||||
LC_G : constant Character := 'g'; -- Character'Val (103)
|
||||
LC_H : constant Character := 'h'; -- Character'Val (104)
|
||||
LC_I : constant Character := 'i'; -- Character'Val (105)
|
||||
LC_J : constant Character := 'j'; -- Character'Val (106)
|
||||
LC_K : constant Character := 'k'; -- Character'Val (107)
|
||||
LC_L : constant Character := 'l'; -- Character'Val (108)
|
||||
LC_M : constant Character := 'm'; -- Character'Val (109)
|
||||
LC_N : constant Character := 'n'; -- Character'Val (110)
|
||||
LC_O : constant Character := 'o'; -- Character'Val (111)
|
||||
LC_P : constant Character := 'p'; -- Character'Val (112)
|
||||
LC_Q : constant Character := 'q'; -- Character'Val (113)
|
||||
LC_R : constant Character := 'r'; -- Character'Val (114)
|
||||
LC_S : constant Character := 's'; -- Character'Val (115)
|
||||
LC_T : constant Character := 't'; -- Character'Val (116)
|
||||
LC_U : constant Character := 'u'; -- Character'Val (117)
|
||||
LC_V : constant Character := 'v'; -- Character'Val (118)
|
||||
LC_W : constant Character := 'w'; -- Character'Val (119)
|
||||
LC_X : constant Character := 'x'; -- Character'Val (120)
|
||||
LC_Y : constant Character := 'y'; -- Character'Val (121)
|
||||
LC_Z : constant Character := 'z'; -- Character'Val (122)
|
||||
Left_Curly_Bracket : constant Character := '{'; -- Character'Val (123)
|
||||
Vertical_Line : constant Character := '|'; -- Character'Val (124)
|
||||
Right_Curly_Bracket : constant Character := '}'; -- Character'Val (125)
|
||||
Tilde : constant Character := '~'; -- Character'Val (126)
|
||||
DEL : constant Character := Character'Val (127);
|
||||
|
||||
---------------------------------
|
||||
-- ISO 6429 Control Characters --
|
||||
---------------------------------
|
||||
|
||||
IS4 : Character renames FS;
|
||||
IS3 : Character renames GS;
|
||||
IS2 : Character renames RS;
|
||||
IS1 : Character renames US;
|
||||
|
||||
Reserved_128 : constant Character := Character'Val (128);
|
||||
Reserved_129 : constant Character := Character'Val (129);
|
||||
BPH : constant Character := Character'Val (130);
|
||||
NBH : constant Character := Character'Val (131);
|
||||
Reserved_132 : constant Character := Character'Val (132);
|
||||
NEL : constant Character := Character'Val (133);
|
||||
SSA : constant Character := Character'Val (134);
|
||||
ESA : constant Character := Character'Val (135);
|
||||
HTS : constant Character := Character'Val (136);
|
||||
HTJ : constant Character := Character'Val (137);
|
||||
VTS : constant Character := Character'Val (138);
|
||||
PLD : constant Character := Character'Val (139);
|
||||
PLU : constant Character := Character'Val (140);
|
||||
RI : constant Character := Character'Val (141);
|
||||
SS2 : constant Character := Character'Val (142);
|
||||
SS3 : constant Character := Character'Val (143);
|
||||
|
||||
DCS : constant Character := Character'Val (144);
|
||||
PU1 : constant Character := Character'Val (145);
|
||||
PU2 : constant Character := Character'Val (146);
|
||||
STS : constant Character := Character'Val (147);
|
||||
CCH : constant Character := Character'Val (148);
|
||||
MW : constant Character := Character'Val (149);
|
||||
SPA : constant Character := Character'Val (150);
|
||||
EPA : constant Character := Character'Val (151);
|
||||
|
||||
SOS : constant Character := Character'Val (152);
|
||||
Reserved_153 : constant Character := Character'Val (153);
|
||||
SCI : constant Character := Character'Val (154);
|
||||
CSI : constant Character := Character'Val (155);
|
||||
ST : constant Character := Character'Val (156);
|
||||
OSC : constant Character := Character'Val (157);
|
||||
PM : constant Character := Character'Val (158);
|
||||
APC : constant Character := Character'Val (159);
|
||||
|
||||
------------------------------
|
||||
-- Other Graphic Characters --
|
||||
------------------------------
|
||||
|
||||
-- Character positions 160 (16#A0#) .. 175 (16#AF#)
|
||||
|
||||
No_Break_Space : constant Character := Character'Val (160);
|
||||
NBSP : Character renames No_Break_Space;
|
||||
Inverted_Exclamation : constant Character := Character'Val (161);
|
||||
Cent_Sign : constant Character := Character'Val (162);
|
||||
Pound_Sign : constant Character := Character'Val (163);
|
||||
Euro_Sign : constant Character := Character'Val (164);
|
||||
Yen_Sign : constant Character := Character'Val (165);
|
||||
UC_S_Caron : constant Character := Character'Val (166);
|
||||
Section_Sign : constant Character := Character'Val (167);
|
||||
LC_S_Caron : constant Character := Character'Val (168);
|
||||
Copyright_Sign : constant Character := Character'Val (169);
|
||||
Feminine_Ordinal_Indicator : constant Character := Character'Val (170);
|
||||
Left_Angle_Quotation : constant Character := Character'Val (171);
|
||||
Not_Sign : constant Character := Character'Val (172);
|
||||
Soft_Hyphen : constant Character := Character'Val (173);
|
||||
Registered_Trade_Mark_Sign : constant Character := Character'Val (174);
|
||||
Macron : constant Character := Character'Val (175);
|
||||
|
||||
-- Character positions 176 (16#B0#) .. 191 (16#BF#)
|
||||
|
||||
Degree_Sign : constant Character := Character'Val (176);
|
||||
Ring_Above : Character renames Degree_Sign;
|
||||
Plus_Minus_Sign : constant Character := Character'Val (177);
|
||||
Superscript_Two : constant Character := Character'Val (178);
|
||||
Superscript_Three : constant Character := Character'Val (179);
|
||||
UC_Z_Caron : constant Character := Character'Val (180);
|
||||
Micro_Sign : constant Character := Character'Val (181);
|
||||
Pilcrow_Sign : constant Character := Character'Val (182);
|
||||
Paragraph_Sign : Character renames Pilcrow_Sign;
|
||||
Middle_Dot : constant Character := Character'Val (183);
|
||||
LC_Z_Caron : constant Character := Character'Val (184);
|
||||
Superscript_One : constant Character := Character'Val (185);
|
||||
Masculine_Ordinal_Indicator : constant Character := Character'Val (186);
|
||||
Right_Angle_Quotation : constant Character := Character'Val (187);
|
||||
UC_Ligature_OE : constant Character := Character'Val (188);
|
||||
LC_Ligature_OE : constant Character := Character'Val (189);
|
||||
UC_Y_Diaeresis : constant Character := Character'Val (190);
|
||||
Inverted_Question : constant Character := Character'Val (191);
|
||||
|
||||
-- Character positions 192 (16#C0#) .. 207 (16#CF#)
|
||||
|
||||
UC_A_Grave : constant Character := Character'Val (192);
|
||||
UC_A_Acute : constant Character := Character'Val (193);
|
||||
UC_A_Circumflex : constant Character := Character'Val (194);
|
||||
UC_A_Tilde : constant Character := Character'Val (195);
|
||||
UC_A_Diaeresis : constant Character := Character'Val (196);
|
||||
UC_A_Ring : constant Character := Character'Val (197);
|
||||
UC_AE_Diphthong : constant Character := Character'Val (198);
|
||||
UC_C_Cedilla : constant Character := Character'Val (199);
|
||||
UC_E_Grave : constant Character := Character'Val (200);
|
||||
UC_E_Acute : constant Character := Character'Val (201);
|
||||
UC_E_Circumflex : constant Character := Character'Val (202);
|
||||
UC_E_Diaeresis : constant Character := Character'Val (203);
|
||||
UC_I_Grave : constant Character := Character'Val (204);
|
||||
UC_I_Acute : constant Character := Character'Val (205);
|
||||
UC_I_Circumflex : constant Character := Character'Val (206);
|
||||
UC_I_Diaeresis : constant Character := Character'Val (207);
|
||||
|
||||
-- Character positions 208 (16#D0#) .. 223 (16#DF#)
|
||||
|
||||
UC_Icelandic_Eth : constant Character := Character'Val (208);
|
||||
UC_N_Tilde : constant Character := Character'Val (209);
|
||||
UC_O_Grave : constant Character := Character'Val (210);
|
||||
UC_O_Acute : constant Character := Character'Val (211);
|
||||
UC_O_Circumflex : constant Character := Character'Val (212);
|
||||
UC_O_Tilde : constant Character := Character'Val (213);
|
||||
UC_O_Diaeresis : constant Character := Character'Val (214);
|
||||
Multiplication_Sign : constant Character := Character'Val (215);
|
||||
UC_O_Oblique_Stroke : constant Character := Character'Val (216);
|
||||
UC_U_Grave : constant Character := Character'Val (217);
|
||||
UC_U_Acute : constant Character := Character'Val (218);
|
||||
UC_U_Circumflex : constant Character := Character'Val (219);
|
||||
UC_U_Diaeresis : constant Character := Character'Val (220);
|
||||
UC_Y_Acute : constant Character := Character'Val (221);
|
||||
UC_Icelandic_Thorn : constant Character := Character'Val (222);
|
||||
LC_German_Sharp_S : constant Character := Character'Val (223);
|
||||
|
||||
-- Character positions 224 (16#E0#) .. 239 (16#EF#)
|
||||
|
||||
LC_A_Grave : constant Character := Character'Val (224);
|
||||
LC_A_Acute : constant Character := Character'Val (225);
|
||||
LC_A_Circumflex : constant Character := Character'Val (226);
|
||||
LC_A_Tilde : constant Character := Character'Val (227);
|
||||
LC_A_Diaeresis : constant Character := Character'Val (228);
|
||||
LC_A_Ring : constant Character := Character'Val (229);
|
||||
LC_AE_Diphthong : constant Character := Character'Val (230);
|
||||
LC_C_Cedilla : constant Character := Character'Val (231);
|
||||
LC_E_Grave : constant Character := Character'Val (232);
|
||||
LC_E_Acute : constant Character := Character'Val (233);
|
||||
LC_E_Circumflex : constant Character := Character'Val (234);
|
||||
LC_E_Diaeresis : constant Character := Character'Val (235);
|
||||
LC_I_Grave : constant Character := Character'Val (236);
|
||||
LC_I_Acute : constant Character := Character'Val (237);
|
||||
LC_I_Circumflex : constant Character := Character'Val (238);
|
||||
LC_I_Diaeresis : constant Character := Character'Val (239);
|
||||
|
||||
-- Character positions 240 (16#F0#) .. 255 (16#FF)
|
||||
LC_Icelandic_Eth : constant Character := Character'Val (240);
|
||||
LC_N_Tilde : constant Character := Character'Val (241);
|
||||
LC_O_Grave : constant Character := Character'Val (242);
|
||||
LC_O_Acute : constant Character := Character'Val (243);
|
||||
LC_O_Circumflex : constant Character := Character'Val (244);
|
||||
LC_O_Tilde : constant Character := Character'Val (245);
|
||||
LC_O_Diaeresis : constant Character := Character'Val (246);
|
||||
Division_Sign : constant Character := Character'Val (247);
|
||||
LC_O_Oblique_Stroke : constant Character := Character'Val (248);
|
||||
LC_U_Grave : constant Character := Character'Val (249);
|
||||
LC_U_Acute : constant Character := Character'Val (250);
|
||||
LC_U_Circumflex : constant Character := Character'Val (251);
|
||||
LC_U_Diaeresis : constant Character := Character'Val (252);
|
||||
LC_Y_Acute : constant Character := Character'Val (253);
|
||||
LC_Icelandic_Thorn : constant Character := Character'Val (254);
|
||||
LC_Y_Diaeresis : constant Character := Character'Val (255);
|
||||
|
||||
------------------------------------------------
|
||||
-- Summary of Changes from Latin-1 => Latin-9 --
|
||||
------------------------------------------------
|
||||
|
||||
-- 164 Currency => Euro_Sign
|
||||
-- 166 Broken_Bar => UC_S_Caron
|
||||
-- 168 Diaeresis => LC_S_Caron
|
||||
-- 180 Acute => UC_Z_Caron
|
||||
-- 184 Cedilla => LC_Z_Caron
|
||||
-- 188 Fraction_One_Quarter => UC_Ligature_OE
|
||||
-- 189 Fraction_One_Half => LC_Ligature_OE
|
||||
-- 190 Fraction_Three_Quarters => UC_Y_Diaeresis
|
||||
|
||||
end Ada.Characters.Latin_9;
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision: 1.12 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
|
||||
-- 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 --
|
||||
@ -71,13 +71,48 @@ pragma Preelaborate (Command_Line);
|
||||
|
||||
procedure Set_Exit_Status (Code : Exit_Status);
|
||||
|
||||
private
|
||||
------------------------------------
|
||||
-- Note on Interface Requirements --
|
||||
------------------------------------
|
||||
|
||||
-- If the main program is in Ada, this package works as specified without
|
||||
-- any other work than the normal steps of WITH'ing the package and then
|
||||
-- calling the desired routines.
|
||||
|
||||
-- If the main program is not in Ada, then the information must be made
|
||||
-- available for this package to work correctly. In particular, it is
|
||||
-- required that the global variable "gnat_argc" contain the number of
|
||||
-- arguments, and that the global variable "gnat_argv" points to an
|
||||
-- array of null-terminated strings, the first entry being the command
|
||||
-- name, and the remaining entries being the command arguments.
|
||||
|
||||
-- These correspond to the normal argc/argv variables passed to a C
|
||||
-- main program, and the following is an example of a complete C main
|
||||
-- program that stores the required information:
|
||||
|
||||
-- main(int argc, char **argv, char **envp)
|
||||
-- {
|
||||
-- extern int gnat_argc;
|
||||
-- extern char **gnat_argv;
|
||||
-- extern char **gnat_envp;
|
||||
-- gnat_argc = argc;
|
||||
-- gnat_argv = argv;
|
||||
-- gnat_envp = envp;
|
||||
|
||||
-- adainit();
|
||||
-- adamain();
|
||||
-- adafinal();
|
||||
-- }
|
||||
|
||||
-- The assignment statements ensure that the necessary information is
|
||||
-- available for finding the command name and command line arguments.
|
||||
|
||||
private
|
||||
Success : constant Exit_Status := 0;
|
||||
Failure : constant Exit_Status := 1;
|
||||
|
||||
-- The following locations support the operation of the package
|
||||
-- Ada.Command_Line_Remove, whih provides facilities for logically
|
||||
-- Ada.Command_Line.Remove, whih provides facilities for logically
|
||||
-- removing arguments from the command line. If one of the remove
|
||||
-- procedures is called in this unit, then Remove_Args/Remove_Count
|
||||
-- are set to indicate which arguments are removed. If no such calls
|
||||
|
||||
338
gcc/ada/a-cwila9.ads
Normal file
338
gcc/ada/a-cwila9.ads
Normal file
@ -0,0 +1,338 @@
|
||||
------------------------------------------------------------------------------
|
||||
-- --
|
||||
-- GNAT RUNTIME COMPONENTS --
|
||||
-- --
|
||||
-- A D A . C H A R A C T E R S . W I D E _ L A T I N _ 9 --
|
||||
-- --
|
||||
-- S p e c --
|
||||
-- --
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- 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. --
|
||||
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This package provides definitions analogous to those in the GNAT
|
||||
-- package Ada.Characters.Latin_9 except that the type of the constants
|
||||
-- is Wide_Character instead of Character. The provision of this package
|
||||
-- is in accordance with the implementation permission in RM (A.3.3(27)).
|
||||
|
||||
package Ada.Characters.Wide_Latin_9 is
|
||||
pragma Pure (Wide_Latin_9);
|
||||
|
||||
------------------------
|
||||
-- Control Characters --
|
||||
------------------------
|
||||
|
||||
NUL : constant Wide_Character := Wide_Character'Val (0);
|
||||
SOH : constant Wide_Character := Wide_Character'Val (1);
|
||||
STX : constant Wide_Character := Wide_Character'Val (2);
|
||||
ETX : constant Wide_Character := Wide_Character'Val (3);
|
||||
EOT : constant Wide_Character := Wide_Character'Val (4);
|
||||
ENQ : constant Wide_Character := Wide_Character'Val (5);
|
||||
ACK : constant Wide_Character := Wide_Character'Val (6);
|
||||
BEL : constant Wide_Character := Wide_Character'Val (7);
|
||||
BS : constant Wide_Character := Wide_Character'Val (8);
|
||||
HT : constant Wide_Character := Wide_Character'Val (9);
|
||||
LF : constant Wide_Character := Wide_Character'Val (10);
|
||||
VT : constant Wide_Character := Wide_Character'Val (11);
|
||||
FF : constant Wide_Character := Wide_Character'Val (12);
|
||||
CR : constant Wide_Character := Wide_Character'Val (13);
|
||||
SO : constant Wide_Character := Wide_Character'Val (14);
|
||||
SI : constant Wide_Character := Wide_Character'Val (15);
|
||||
|
||||
DLE : constant Wide_Character := Wide_Character'Val (16);
|
||||
DC1 : constant Wide_Character := Wide_Character'Val (17);
|
||||
DC2 : constant Wide_Character := Wide_Character'Val (18);
|
||||
DC3 : constant Wide_Character := Wide_Character'Val (19);
|
||||
DC4 : constant Wide_Character := Wide_Character'Val (20);
|
||||
NAK : constant Wide_Character := Wide_Character'Val (21);
|
||||
SYN : constant Wide_Character := Wide_Character'Val (22);
|
||||
ETB : constant Wide_Character := Wide_Character'Val (23);
|
||||
CAN : constant Wide_Character := Wide_Character'Val (24);
|
||||
EM : constant Wide_Character := Wide_Character'Val (25);
|
||||
SUB : constant Wide_Character := Wide_Character'Val (26);
|
||||
ESC : constant Wide_Character := Wide_Character'Val (27);
|
||||
FS : constant Wide_Character := Wide_Character'Val (28);
|
||||
GS : constant Wide_Character := Wide_Character'Val (29);
|
||||
RS : constant Wide_Character := Wide_Character'Val (30);
|
||||
US : constant Wide_Character := Wide_Character'Val (31);
|
||||
|
||||
-------------------------------------
|
||||
-- ISO 646 Graphic Wide_Characters --
|
||||
-------------------------------------
|
||||
|
||||
Space : constant Wide_Character := ' '; -- WC'Val(32)
|
||||
Exclamation : constant Wide_Character := '!'; -- WC'Val(33)
|
||||
Quotation : constant Wide_Character := '"'; -- WC'Val(34)
|
||||
Number_Sign : constant Wide_Character := '#'; -- WC'Val(35)
|
||||
Dollar_Sign : constant Wide_Character := '$'; -- WC'Val(36)
|
||||
Percent_Sign : constant Wide_Character := '%'; -- WC'Val(37)
|
||||
Ampersand : constant Wide_Character := '&'; -- WC'Val(38)
|
||||
Apostrophe : constant Wide_Character := '''; -- WC'Val(39)
|
||||
Left_Parenthesis : constant Wide_Character := '('; -- WC'Val(40)
|
||||
Right_Parenthesis : constant Wide_Character := ')'; -- WC'Val(41)
|
||||
Asterisk : constant Wide_Character := '*'; -- WC'Val(42)
|
||||
Plus_Sign : constant Wide_Character := '+'; -- WC'Val(43)
|
||||
Comma : constant Wide_Character := ','; -- WC'Val(44)
|
||||
Hyphen : constant Wide_Character := '-'; -- WC'Val(45)
|
||||
Minus_Sign : Wide_Character renames Hyphen;
|
||||
Full_Stop : constant Wide_Character := '.'; -- WC'Val(46)
|
||||
Solidus : constant Wide_Character := '/'; -- WC'Val(47)
|
||||
|
||||
-- Decimal digits '0' though '9' are at positions 48 through 57
|
||||
|
||||
Colon : constant Wide_Character := ':'; -- WC'Val(58)
|
||||
Semicolon : constant Wide_Character := ';'; -- WC'Val(59)
|
||||
Less_Than_Sign : constant Wide_Character := '<'; -- WC'Val(60)
|
||||
Equals_Sign : constant Wide_Character := '='; -- WC'Val(61)
|
||||
Greater_Than_Sign : constant Wide_Character := '>'; -- WC'Val(62)
|
||||
Question : constant Wide_Character := '?'; -- WC'Val(63)
|
||||
|
||||
Commercial_At : constant Wide_Character := '@'; -- WC'Val(64)
|
||||
|
||||
-- Letters 'A' through 'Z' are at positions 65 through 90
|
||||
|
||||
Left_Square_Bracket : constant Wide_Character := '['; -- WC'Val (91)
|
||||
Reverse_Solidus : constant Wide_Character := '\'; -- WC'Val (92)
|
||||
Right_Square_Bracket : constant Wide_Character := ']'; -- WC'Val (93)
|
||||
Circumflex : constant Wide_Character := '^'; -- WC'Val (94)
|
||||
Low_Line : constant Wide_Character := '_'; -- WC'Val (95)
|
||||
|
||||
Grave : constant Wide_Character := '`'; -- WC'Val (96)
|
||||
LC_A : constant Wide_Character := 'a'; -- WC'Val (97)
|
||||
LC_B : constant Wide_Character := 'b'; -- WC'Val (98)
|
||||
LC_C : constant Wide_Character := 'c'; -- WC'Val (99)
|
||||
LC_D : constant Wide_Character := 'd'; -- WC'Val (100)
|
||||
LC_E : constant Wide_Character := 'e'; -- WC'Val (101)
|
||||
LC_F : constant Wide_Character := 'f'; -- WC'Val (102)
|
||||
LC_G : constant Wide_Character := 'g'; -- WC'Val (103)
|
||||
LC_H : constant Wide_Character := 'h'; -- WC'Val (104)
|
||||
LC_I : constant Wide_Character := 'i'; -- WC'Val (105)
|
||||
LC_J : constant Wide_Character := 'j'; -- WC'Val (106)
|
||||
LC_K : constant Wide_Character := 'k'; -- WC'Val (107)
|
||||
LC_L : constant Wide_Character := 'l'; -- WC'Val (108)
|
||||
LC_M : constant Wide_Character := 'm'; -- WC'Val (109)
|
||||
LC_N : constant Wide_Character := 'n'; -- WC'Val (110)
|
||||
LC_O : constant Wide_Character := 'o'; -- WC'Val (111)
|
||||
LC_P : constant Wide_Character := 'p'; -- WC'Val (112)
|
||||
LC_Q : constant Wide_Character := 'q'; -- WC'Val (113)
|
||||
LC_R : constant Wide_Character := 'r'; -- WC'Val (114)
|
||||
LC_S : constant Wide_Character := 's'; -- WC'Val (115)
|
||||
LC_T : constant Wide_Character := 't'; -- WC'Val (116)
|
||||
LC_U : constant Wide_Character := 'u'; -- WC'Val (117)
|
||||
LC_V : constant Wide_Character := 'v'; -- WC'Val (118)
|
||||
LC_W : constant Wide_Character := 'w'; -- WC'Val (119)
|
||||
LC_X : constant Wide_Character := 'x'; -- WC'Val (120)
|
||||
LC_Y : constant Wide_Character := 'y'; -- WC'Val (121)
|
||||
LC_Z : constant Wide_Character := 'z'; -- WC'Val (122)
|
||||
Left_Curly_Bracket : constant Wide_Character := '{'; -- WC'Val (123)
|
||||
Vertical_Line : constant Wide_Character := '|'; -- WC'Val (124)
|
||||
Right_Curly_Bracket : constant Wide_Character := '}'; -- WC'Val (125)
|
||||
Tilde : constant Wide_Character := '~'; -- WC'Val (126)
|
||||
DEL : constant Wide_Character := Wide_Character'Val (127);
|
||||
|
||||
--------------------------------------
|
||||
-- ISO 6429 Control Wide_Characters --
|
||||
--------------------------------------
|
||||
|
||||
IS4 : Wide_Character renames FS;
|
||||
IS3 : Wide_Character renames GS;
|
||||
IS2 : Wide_Character renames RS;
|
||||
IS1 : Wide_Character renames US;
|
||||
|
||||
Reserved_128 : constant Wide_Character := Wide_Character'Val (128);
|
||||
Reserved_129 : constant Wide_Character := Wide_Character'Val (129);
|
||||
BPH : constant Wide_Character := Wide_Character'Val (130);
|
||||
NBH : constant Wide_Character := Wide_Character'Val (131);
|
||||
Reserved_132 : constant Wide_Character := Wide_Character'Val (132);
|
||||
NEL : constant Wide_Character := Wide_Character'Val (133);
|
||||
SSA : constant Wide_Character := Wide_Character'Val (134);
|
||||
ESA : constant Wide_Character := Wide_Character'Val (135);
|
||||
HTS : constant Wide_Character := Wide_Character'Val (136);
|
||||
HTJ : constant Wide_Character := Wide_Character'Val (137);
|
||||
VTS : constant Wide_Character := Wide_Character'Val (138);
|
||||
PLD : constant Wide_Character := Wide_Character'Val (139);
|
||||
PLU : constant Wide_Character := Wide_Character'Val (140);
|
||||
RI : constant Wide_Character := Wide_Character'Val (141);
|
||||
SS2 : constant Wide_Character := Wide_Character'Val (142);
|
||||
SS3 : constant Wide_Character := Wide_Character'Val (143);
|
||||
|
||||
DCS : constant Wide_Character := Wide_Character'Val (144);
|
||||
PU1 : constant Wide_Character := Wide_Character'Val (145);
|
||||
PU2 : constant Wide_Character := Wide_Character'Val (146);
|
||||
STS : constant Wide_Character := Wide_Character'Val (147);
|
||||
CCH : constant Wide_Character := Wide_Character'Val (148);
|
||||
MW : constant Wide_Character := Wide_Character'Val (149);
|
||||
SPA : constant Wide_Character := Wide_Character'Val (150);
|
||||
EPA : constant Wide_Character := Wide_Character'Val (151);
|
||||
|
||||
SOS : constant Wide_Character := Wide_Character'Val (152);
|
||||
Reserved_153 : constant Wide_Character := Wide_Character'Val (153);
|
||||
SCI : constant Wide_Character := Wide_Character'Val (154);
|
||||
CSI : constant Wide_Character := Wide_Character'Val (155);
|
||||
ST : constant Wide_Character := Wide_Character'Val (156);
|
||||
OSC : constant Wide_Character := Wide_Character'Val (157);
|
||||
PM : constant Wide_Character := Wide_Character'Val (158);
|
||||
APC : constant Wide_Character := Wide_Character'Val (159);
|
||||
|
||||
-----------------------------------
|
||||
-- Other Graphic Wide_Characters --
|
||||
-----------------------------------
|
||||
|
||||
-- Wide_Character positions 160 (16#A0#) .. 175 (16#AF#)
|
||||
|
||||
No_Break_Space : constant Wide_Character := Wide_Character'Val (160);
|
||||
NBSP : Wide_Character renames No_Break_Space;
|
||||
Inverted_Exclamation : constant Wide_Character := Wide_Character'Val (161);
|
||||
Cent_Sign : constant Wide_Character := Wide_Character'Val (162);
|
||||
Pound_Sign : constant Wide_Character := Wide_Character'Val (163);
|
||||
Euro_Sign : constant Wide_Character := Wide_Character'Val (164);
|
||||
Yen_Sign : constant Wide_Character := Wide_Character'Val (165);
|
||||
UC_S_Caron : constant Wide_Character := Wide_Character'Val (166);
|
||||
Section_Sign : constant Wide_Character := Wide_Character'Val (167);
|
||||
LC_S_Caron : constant Wide_Character := Wide_Character'Val (168);
|
||||
Copyright_Sign : constant Wide_Character := Wide_Character'Val (169);
|
||||
Feminine_Ordinal_Indicator
|
||||
: constant Wide_Character := Wide_Character'Val (170);
|
||||
Left_Angle_Quotation : constant Wide_Character := Wide_Character'Val (171);
|
||||
Not_Sign : constant Wide_Character := Wide_Character'Val (172);
|
||||
Soft_Hyphen : constant Wide_Character := Wide_Character'Val (173);
|
||||
Registered_Trade_Mark_Sign
|
||||
: constant Wide_Character := Wide_Character'Val (174);
|
||||
Macron : constant Wide_Character := Wide_Character'Val (175);
|
||||
|
||||
-- Wide_Character positions 176 (16#B0#) .. 191 (16#BF#)
|
||||
|
||||
Degree_Sign : constant Wide_Character := Wide_Character'Val (176);
|
||||
Ring_Above : Wide_Character renames Degree_Sign;
|
||||
Plus_Minus_Sign : constant Wide_Character := Wide_Character'Val (177);
|
||||
Superscript_Two : constant Wide_Character := Wide_Character'Val (178);
|
||||
Superscript_Three : constant Wide_Character := Wide_Character'Val (179);
|
||||
UC_Z_Caron : constant Wide_Character := Wide_Character'Val (180);
|
||||
Micro_Sign : constant Wide_Character := Wide_Character'Val (181);
|
||||
Pilcrow_Sign : constant Wide_Character := Wide_Character'Val (182);
|
||||
Paragraph_Sign : Wide_Character renames Pilcrow_Sign;
|
||||
Middle_Dot : constant Wide_Character := Wide_Character'Val (183);
|
||||
LC_Z_Caron : constant Wide_Character := Wide_Character'Val (184);
|
||||
Superscript_One : constant Wide_Character := Wide_Character'Val (185);
|
||||
Masculine_Ordinal_Indicator
|
||||
: constant Wide_Character := Wide_Character'Val (186);
|
||||
Right_Angle_Quotation
|
||||
: constant Wide_Character := Wide_Character'Val (187);
|
||||
UC_Ligature_OE : constant Wide_Character := Wide_Character'Val (188);
|
||||
LC_Ligature_OE : constant Wide_Character := Wide_Character'Val (189);
|
||||
UC_Y_Diaeresis : constant Wide_Character := Wide_Character'Val (190);
|
||||
Inverted_Question : constant Wide_Character := Wide_Character'Val (191);
|
||||
|
||||
-- Wide_Character positions 192 (16#C0#) .. 207 (16#CF#)
|
||||
|
||||
UC_A_Grave : constant Wide_Character := Wide_Character'Val (192);
|
||||
UC_A_Acute : constant Wide_Character := Wide_Character'Val (193);
|
||||
UC_A_Circumflex : constant Wide_Character := Wide_Character'Val (194);
|
||||
UC_A_Tilde : constant Wide_Character := Wide_Character'Val (195);
|
||||
UC_A_Diaeresis : constant Wide_Character := Wide_Character'Val (196);
|
||||
UC_A_Ring : constant Wide_Character := Wide_Character'Val (197);
|
||||
UC_AE_Diphthong : constant Wide_Character := Wide_Character'Val (198);
|
||||
UC_C_Cedilla : constant Wide_Character := Wide_Character'Val (199);
|
||||
UC_E_Grave : constant Wide_Character := Wide_Character'Val (200);
|
||||
UC_E_Acute : constant Wide_Character := Wide_Character'Val (201);
|
||||
UC_E_Circumflex : constant Wide_Character := Wide_Character'Val (202);
|
||||
UC_E_Diaeresis : constant Wide_Character := Wide_Character'Val (203);
|
||||
UC_I_Grave : constant Wide_Character := Wide_Character'Val (204);
|
||||
UC_I_Acute : constant Wide_Character := Wide_Character'Val (205);
|
||||
UC_I_Circumflex : constant Wide_Character := Wide_Character'Val (206);
|
||||
UC_I_Diaeresis : constant Wide_Character := Wide_Character'Val (207);
|
||||
|
||||
-- Wide_Character positions 208 (16#D0#) .. 223 (16#DF#)
|
||||
|
||||
UC_Icelandic_Eth : constant Wide_Character := Wide_Character'Val (208);
|
||||
UC_N_Tilde : constant Wide_Character := Wide_Character'Val (209);
|
||||
UC_O_Grave : constant Wide_Character := Wide_Character'Val (210);
|
||||
UC_O_Acute : constant Wide_Character := Wide_Character'Val (211);
|
||||
UC_O_Circumflex : constant Wide_Character := Wide_Character'Val (212);
|
||||
UC_O_Tilde : constant Wide_Character := Wide_Character'Val (213);
|
||||
UC_O_Diaeresis : constant Wide_Character := Wide_Character'Val (214);
|
||||
Multiplication_Sign : constant Wide_Character := Wide_Character'Val (215);
|
||||
UC_O_Oblique_Stroke : constant Wide_Character := Wide_Character'Val (216);
|
||||
UC_U_Grave : constant Wide_Character := Wide_Character'Val (217);
|
||||
UC_U_Acute : constant Wide_Character := Wide_Character'Val (218);
|
||||
UC_U_Circumflex : constant Wide_Character := Wide_Character'Val (219);
|
||||
UC_U_Diaeresis : constant Wide_Character := Wide_Character'Val (220);
|
||||
UC_Y_Acute : constant Wide_Character := Wide_Character'Val (221);
|
||||
UC_Icelandic_Thorn : constant Wide_Character := Wide_Character'Val (222);
|
||||
LC_German_Sharp_S : constant Wide_Character := Wide_Character'Val (223);
|
||||
|
||||
-- Wide_Character positions 224 (16#E0#) .. 239 (16#EF#)
|
||||
|
||||
LC_A_Grave : constant Wide_Character := Wide_Character'Val (224);
|
||||
LC_A_Acute : constant Wide_Character := Wide_Character'Val (225);
|
||||
LC_A_Circumflex : constant Wide_Character := Wide_Character'Val (226);
|
||||
LC_A_Tilde : constant Wide_Character := Wide_Character'Val (227);
|
||||
LC_A_Diaeresis : constant Wide_Character := Wide_Character'Val (228);
|
||||
LC_A_Ring : constant Wide_Character := Wide_Character'Val (229);
|
||||
LC_AE_Diphthong : constant Wide_Character := Wide_Character'Val (230);
|
||||
LC_C_Cedilla : constant Wide_Character := Wide_Character'Val (231);
|
||||
LC_E_Grave : constant Wide_Character := Wide_Character'Val (232);
|
||||
LC_E_Acute : constant Wide_Character := Wide_Character'Val (233);
|
||||
LC_E_Circumflex : constant Wide_Character := Wide_Character'Val (234);
|
||||
LC_E_Diaeresis : constant Wide_Character := Wide_Character'Val (235);
|
||||
LC_I_Grave : constant Wide_Character := Wide_Character'Val (236);
|
||||
LC_I_Acute : constant Wide_Character := Wide_Character'Val (237);
|
||||
LC_I_Circumflex : constant Wide_Character := Wide_Character'Val (238);
|
||||
LC_I_Diaeresis : constant Wide_Character := Wide_Character'Val (239);
|
||||
|
||||
-- Wide_Character positions 240 (16#F0#) .. 255 (16#FF)
|
||||
|
||||
LC_Icelandic_Eth : constant Wide_Character := Wide_Character'Val (240);
|
||||
LC_N_Tilde : constant Wide_Character := Wide_Character'Val (241);
|
||||
LC_O_Grave : constant Wide_Character := Wide_Character'Val (242);
|
||||
LC_O_Acute : constant Wide_Character := Wide_Character'Val (243);
|
||||
LC_O_Circumflex : constant Wide_Character := Wide_Character'Val (244);
|
||||
LC_O_Tilde : constant Wide_Character := Wide_Character'Val (245);
|
||||
LC_O_Diaeresis : constant Wide_Character := Wide_Character'Val (246);
|
||||
Division_Sign : constant Wide_Character := Wide_Character'Val (247);
|
||||
LC_O_Oblique_Stroke : constant Wide_Character := Wide_Character'Val (248);
|
||||
LC_U_Grave : constant Wide_Character := Wide_Character'Val (249);
|
||||
LC_U_Acute : constant Wide_Character := Wide_Character'Val (250);
|
||||
LC_U_Circumflex : constant Wide_Character := Wide_Character'Val (251);
|
||||
LC_U_Diaeresis : constant Wide_Character := Wide_Character'Val (252);
|
||||
LC_Y_Acute : constant Wide_Character := Wide_Character'Val (253);
|
||||
LC_Icelandic_Thorn : constant Wide_Character := Wide_Character'Val (254);
|
||||
LC_Y_Diaeresis : constant Wide_Character := Wide_Character'Val (255);
|
||||
|
||||
------------------------------------------------
|
||||
-- Summary of Changes from Latin-1 => Latin-9 --
|
||||
------------------------------------------------
|
||||
|
||||
-- 164 Currency => Euro_Sign
|
||||
-- 166 Broken_Bar => UC_S_Caron
|
||||
-- 168 Diaeresis => LC_S_Caron
|
||||
-- 180 Acute => UC_Z_Caron
|
||||
-- 184 Cedilla => LC_Z_Caron
|
||||
-- 188 Fraction_One_Quarter => UC_Ligature_OE
|
||||
-- 189 Fraction_One_Half => LC_Ligature_OE
|
||||
-- 190 Fraction_Three_Quarters => UC_Y_Diaeresis
|
||||
|
||||
end Ada.Characters.Wide_Latin_9;
|
||||
@ -6,9 +6,9 @@
|
||||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- $Revision: 1.25 $
|
||||
-- $Revision$
|
||||
-- --
|
||||
-- Copyright (C) 1991-2001 Florida State University --
|
||||
-- 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- --
|
||||
@ -29,8 +29,7 @@
|
||||
-- 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). --
|
||||
-- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
|
||||
-- --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
@ -56,10 +55,16 @@ with Ada.Exceptions;
|
||||
with System.Tasking.Initialization;
|
||||
-- used for Defer/Undefer_Abort
|
||||
|
||||
with System.Parameters;
|
||||
-- used for Single_Lock
|
||||
|
||||
with Unchecked_Conversion;
|
||||
|
||||
package body Ada.Dynamic_Priorities is
|
||||
|
||||
package STPO renames System.Task_Primitives.Operations;
|
||||
|
||||
use System.Parameters;
|
||||
use System.Tasking;
|
||||
use Ada.Exceptions;
|
||||
|
||||
@ -107,7 +112,7 @@ package body Ada.Dynamic_Priorities is
|
||||
Ada.Task_Identification.Current_Task)
|
||||
is
|
||||
Target : constant Task_ID := Convert_Ids (T);
|
||||
Self_ID : constant Task_ID := System.Task_Primitives.Operations.Self;
|
||||
Self_ID : constant Task_ID := STPO.Self;
|
||||
Error_Message : constant String := "Trying to set the priority of a ";
|
||||
|
||||
begin
|
||||
@ -121,34 +126,49 @@ package body Ada.Dynamic_Priorities is
|
||||
Error_Message & "terminated task");
|
||||
end if;
|
||||
|
||||
System.Tasking.Initialization.Defer_Abort (Self_ID);
|
||||
System.Task_Primitives.Operations.Write_Lock (Target);
|
||||
Initialization.Defer_Abort (Self_ID);
|
||||
|
||||
if Single_Lock then
|
||||
STPO.Lock_RTS;
|
||||
end if;
|
||||
|
||||
STPO.Write_Lock (Target);
|
||||
|
||||
if Self_ID = Target then
|
||||
Target.Common.Base_Priority := Priority;
|
||||
System.Task_Primitives.Operations.Set_Priority (Target, Priority);
|
||||
System.Task_Primitives.Operations.Unlock (Target);
|
||||
System.Task_Primitives.Operations.Yield;
|
||||
STPO.Set_Priority (Target, Priority);
|
||||
|
||||
STPO.Unlock (Target);
|
||||
|
||||
if Single_Lock then
|
||||
STPO.Unlock_RTS;
|
||||
end if;
|
||||
|
||||
STPO.Yield;
|
||||
-- Yield is needed to enforce FIFO task dispatching.
|
||||
-- LL Set_Priority is made while holding the RTS lock so that
|
||||
-- it is inheriting high priority until it release all the RTS
|
||||
-- locks.
|
||||
-- If this is used in a system where Ceiling Locking is
|
||||
-- not enforced we may end up getting two Yield effects.
|
||||
|
||||
else
|
||||
Target.New_Base_Priority := Priority;
|
||||
Target.Pending_Priority_Change := True;
|
||||
Target.Pending_Action := True;
|
||||
|
||||
System.Task_Primitives.Operations.Wakeup
|
||||
(Target, Target.Common.State);
|
||||
STPO.Wakeup (Target, Target.Common.State);
|
||||
-- If the task is suspended, wake it up to perform the change.
|
||||
-- check for ceiling violations ???
|
||||
System.Task_Primitives.Operations.Unlock (Target);
|
||||
|
||||
STPO.Unlock (Target);
|
||||
|
||||
if Single_Lock then
|
||||
STPO.Unlock_RTS;
|
||||
end if;
|
||||
end if;
|
||||
System.Tasking.Initialization.Undefer_Abort (Self_ID);
|
||||
|
||||
Initialization.Undefer_Abort (Self_ID);
|
||||
end Set_Priority;
|
||||
|
||||
end Ada.Dynamic_Priorities;
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user