diff options
author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-05-14 10:02:00 +0000 |
---|---|---|
committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2004-05-14 10:02:00 +0000 |
commit | 3e55413dd9a577b7b270e04f09ccb3f13a90a3cb (patch) | |
tree | ad67eadab2c2032169ff2f33eb289b29a4e7e3a9 /gcc/ada/s-tratas-default.adb | |
parent | 7e0c7e2e8e2c055a2751d8dbd5cdd4bd70fe316e (diff) | |
download | gcc-3e55413dd9a577b7b270e04f09ccb3f13a90a3cb.tar.gz |
Renaming of target specific files for clarity
* Makefile.in: Rename GNAT target specific files.
* 31soccon.ads, 31soliop.ads 35soccon.ads, 3asoccon.ads,
3bsoccon.ads, 3gsoccon.ads, 3hsoccon.ads, 3psoccon.ads,
3ssoccon.ads, 3ssoliop.ads, 3veacodu.adb, 3vexpect.adb,
3vsoccon.ads, 3vsocthi.adb, 3vsocthi.ads, 3vtrasym.adb,
3wsoccon.ads, 3wsocthi.adb, 3wsocthi.ads, 3wsoliop.ads,
3zsoccon.ads, 3zsocthi.adb, 3zsocthi.ads, 41intnam.ads,
42intnam.ads, 45intnam.ads, 4aintnam.ads, 4cintnam.ads,
4gintnam.ads, 4hexcpol.adb, 4hintnam.ads, 4lintnam.ads,
4nintnam.ads, 4ointnam.ads, 4onumaux.ads, 4pintnam.ads,
4sintnam.ads, 4vcaldel.adb, 4vcalend.adb, 4vcalend.ads,
4vintnam.ads, 4wcalend.adb, 4wexcpol.adb, 4wintnam.ads,
4zintnam.ads, 4znumaux.ads, 4zsytaco.adb, 4zsytaco.ads,
51osinte.adb, 51osinte.ads, 51system.ads,
52osinte.adb, 52osinte.ads, 53osinte.ads, 54osinte.ads,
55osinte.adb, 55osinte.ads, 55system.ads, 56osinte.adb,
56osinte.ads, 56system.ads, 56taprop.adb, 56taspri.ads,
56tpopsp.adb, 57system.ads, 58system.ads,
5amastop.adb, 5aml-tgt.adb, 5aosinte.adb, 5aosinte.ads,
5asystem.ads, 5ataprop.adb, 5atasinf.ads, 5ataspri.ads,
5atpopsp.adb, 5avxwork.ads, 5bml-tgt.adb, 5bosinte.adb,
5bosinte.ads, 5bsystem.ads, 5cosinte.ads, 5csystem.ads,
5dsystem.ads, 5esystem.ads, 5fintman.adb, 5fosinte.adb,
5fosinte.ads, 5fsystem.ads, 5ftaprop.adb, 5ftasinf.ads,
5ginterr.adb, 5gintman.adb, 5gmastop.adb, 5gml-tgt.adb,
5gosinte.ads, 5gproinf.adb, 5gproinf.ads, 5gsystem.ads,
5gtaprop.adb, 5gtasinf.adb, 5gtasinf.ads, 5gtpgetc.adb,
5hml-tgt.adb, 5hosinte.adb, 5hosinte.ads, 5hparame.ads,
5hsystem.ads, 5htaprop.adb, 5htaspri.ads, 5htraceb.adb,
5iosinte.adb, 5iosinte.ads, 5itaprop.adb, 5itaspri.ads,
5ksystem.ads, 5kvxwork.ads, 5lml-tgt.adb, 5losinte.ads,
5lparame.adb, 5lsystem.ads, 5msystem.ads, 5mvxwork.ads,
5ninmaop.adb, 5nintman.adb, 5nosinte.ads, 5nsystem.ads,
5ntaprop.adb, 5ntaspri.ads, 5ointerr.adb, 5omastop.adb,
5oosinte.adb, 5oosinte.ads, 5oosprim.adb, 5oparame.adb,
5osystem.ads, 5otaprop.adb, 5otaspri.ads, 5posinte.ads,
5posprim.adb, 5psystem.ads, 5pvxwork.ads, 5sintman.adb,
5sml-tgt.adb, 5sosinte.adb, 5sosinte.ads, 5sosprim.adb,
5sparame.adb, 5ssystem.ads, 5staprop.adb, 5stasinf.adb,
5stasinf.ads, 5staspri.ads, 5stpopsp.adb, 5svxwork.ads,
5tosinte.ads, 5usystem.ads, 5vasthan.adb, 5vdirval.adb,
5vinmaop.adb, 5vinterr.adb, 5vintman.adb, 5vintman.ads,
5vmastop.adb, 5vml-tgt.adb, 5vosinte.adb, 5vosinte.ads,
5vosprim.adb, 5vosprim.ads, 5vparame.ads, 5vsymbol.adb,
5vsystem.ads, 5vtaprop.adb, 5vtaspri.ads, 5vtpopde.adb,
5vtpopde.ads, 5vtraent.adb, 5vtraent.ads, 5vvaflop.adb,
5wdirval.adb, 5wgloloc.adb, 5wintman.adb, 5wmemory.adb,
5wml-tgt.adb, 5wosinte.ads, 5wosprim.adb, 5wsystem.ads,
5wtaprop.adb, 5wtaspri.ads, 5xparame.ads, 5xsystem.ads,
5xvxwork.ads, 5yparame.ads, 5ysystem.ads, 5zinterr.adb,
5zintman.adb, 5zintman.ads, 5zml-tgt.adb, 5zosinte.adb,
5zosinte.ads, 5zosprim.adb, 5zparame.ads, 5zstchop.adb,
5zsystem.ads, 5ztaprop.adb, 5ztaspri.ads, 5ztfsetr.adb,
5ztpopsp.adb, 6vcpp.adb, 6vcstrea.adb, 6vinterf.ads,
7sinmaop.adb, 7sintman.adb, 7sosinte.adb, 7sosprim.adb,
7staprop.adb, 7staspri.ads, 7stfsetr.adb, 7stpopsp.adb,
7straceb.adb, 7straces.adb, 7strafor.adb, 7strafor.ads,
7stratas.adb, 86numaux.adb, 86numaux.ads: Replaced by files below.
* a-caldel-vms.adb, a-calend-mingw.adb, a-calend-vms.adb,
a-calend-vms.ads, a-dirval-mingw.adb, a-dirval-vms.adb,
a-excpol-abort.adb, a-excpol-interix.adb, a-intnam-aix.ads,
a-intnam-dummy.ads, a-intnam-freebsd.ads, a-intnam-hpux.ads,
a-intnam-interix.ads, a-intnam-irix.ads, a-intnam-linux.ads,
a-intnam-lynxos.ads, a-intnam-mingw.ads, a-intnam-os2.ads,
a-intnam-solaris.ads, a-intnam-tru64.ads, a-intnam-unixware.ads,
a-intnam-vms.ads, a-intnam-vxworks.ads, a-numaux-libc-x86.ads,
a-numaux-vxworks.ads, a-numaux-x86.adb, a-numaux-x86.ads,
a-sytaco-vxworks.adb, a-sytaco-vxworks.ads, g-eacodu-vms.adb,
g-expect-vms.adb, g-soccon-aix.ads, g-soccon-freebsd.ads,
g-soccon-hpux.ads, g-soccon-interix.ads, g-soccon-irix.ads,
g-soccon-mingw.ads, g-soccon-solaris.ads, g-soccon-tru64.ads,
g-soccon-unixware.ads, g-soccon-vms.adb, g-soccon-vxworks.ads,
g-socthi-mingw.adb, g-socthi-mingw.ads, g-socthi-vms.adb,
g-socthi-vms.ads, g-socthi-vxworks.adb, g-socthi-vxworks.ads,
g-soliop-mingw.ads, g-soliop-solaris.ads, g-soliop-unixware.ads,
g-trasym-vms.adb, i-cpp-vms.adb, i-cstrea-vms.adb,
interfac-vms.ads, mlib-tgt-aix.adb, mlib-tgt-hpux.adb,
mlib-tgt-irix.adb, mlib-tgt-linux.adb, mlib-tgt-mingw.adb,
mlib-tgt-solaris.adb, mlib-tgt-tru64.adb, mlib-tgt-vms.adb,
mlib-tgt-vxworks.adb, s-asthan-vms.adb, s-gloloc-mingw.adb,
s-inmaop-dummy.adb, s-inmaop-posix.adb, s-inmaop-vms.adb,
s-interr-dummy.adb, s-interr-sigaction.adb, s-interr-vms.adb,
s-interr-vxworks.adb, s-intman-dummy.adb, s-intman-irix.adb,
s-intman-irix-athread.adb, s-intman-mingw.adb, s-intman-posix.adb,
s-intman-solaris.adb, s-intman-vms.adb, s-intman-vms.ads,
s-intman-vxworks.adb, s-intman-vxworks.ads, s-mastop-irix.adb,
s-mastop-tru64.adb, s-mastop-vms.adb, s-mastop-x86.adb,
s-memory-mingw.adb, s-osinte-aix.adb, s-osinte-aix.ads,
s-osinte-aix-fsu.ads, s-osinte-dummy.ads, s-osinte-freebsd.adb,
s-osinte-freebsd.ads, s-osinte-fsu.adb, s-osinte-hpux.ads,
s-osinte-hpux-dce.adb, s-osinte-hpux-dce.ads, s-osinte-interix.ads,
s-osinte-irix.adb, s-osinte-irix.ads, s-osinte-irix-athread.ads,
s-osinte-linux.ads, s-osinte-linux-fsu.ads, s-osinte-linux-ia64.ads,
s-osinte-lynxos-3.adb, s-osinte-lynxos-3.ads, s-osinte-lynxos.adb,
s-osinte-lynxos.ads, s-osinte-mingw.ads, s-osinte-os2.adb,
s-osinte-os2.ads, s-osinte-posix.adb, s-osinte-solaris.adb,
s-osinte-solaris.ads, s-osinte-solaris-fsu.ads,
s-osinte-solaris-posix.ads, s-osinte-tru64.adb, s-osinte-tru64.ads,
s-osinte-unixware.adb, s-osinte-unixware.ads, s-osinte-vms.adb,
s-osinte-vms.ads, s-osinte-vxworks.adb,
s-osinte-vxworks.ads, s-osprim-mingw.adb,
s-osprim-os2.adb, s-osprim-posix.adb, s-osprim-solaris.adb,
s-osprim-unix.adb, s-osprim-vms.adb, s-osprim-vms.ads,
s-osprim-vxworks.adb, s-parame-ae653.ads, s-parame-hpux.ads,
s-parame-linux.adb, s-parame-os2.adb, s-parame-solaris.adb,
s-parame-vms.ads, s-parame-vms-restrict.ads, s-parame-vxworks.ads,
s-proinf-irix-athread.adb, s-proinf-irix-athread.ads,
s-stchop-vxworks.adb, s-taprop-dummy.adb,
s-taprop-hpux-dce.adb, s-taprop-irix.adb,
s-taprop-irix-athread.adb, s-taprop-linux.adb, s-taprop-lynxos.adb,
s-taprop-mingw.adb, s-taprop-os2.adb, s-taprop-posix.adb,
s-taprop-solaris.adb, s-taprop-tru64.adb, s-taprop-vms.adb,
s-taprop-vxworks.adb, s-tasinf-irix.ads, s-tasinf-irix-athread.adb,
s-tasinf-irix-athread.ads, s-tasinf-solaris.adb, s-tasinf-solaris.ads,
s-tasinf-tru64.ads, s-taspri-dummy.ads, s-taspri-hpux-dce.ads,
s-taspri-linux.ads, s-taspri-lynxos.ads, s-taspri-mingw.ads,
s-taspri-os2.ads, s-taspri-posix.ads, s-taspri-solaris.ads,
s-taspri-tru64.ads, s-taspri-vms.ads, s-taspri-vxworks.ads,
s-tfsetr-default.adb, s-tfsetr-vxworks.adb, s-tpopde-vms.adb,
s-tpopde-vms.ads, s-tpopsp-lynxos.adb, s-tpopsp-posix.adb,
s-tpopsp-posix-foreign.adb, s-tpopsp-solaris.adb, s-tpopsp-vxworks.adb,
s-traceb-hpux.adb, s-traceb-mastop.adb, s-traces-default.adb,
s-traent-vms.adb, s-traent-vms.ads, s-trafor-default.adb,
s-trafor-default.ads, s-tratas-default.adb, s-vaflop-vms.adb,
s-vxwork-alpha.ads, s-vxwork-m68k.ads, s-vxwork-mips.ads,
s-vxwork-ppc.ads, s-vxwork-sparcv9.ads, s-vxwork-xscale.ads,
symbols-vms.adb, system-aix.ads, system-freebsd-x86.ads,
system-hpux.ads, system-interix.ads, system-irix-n32.ads,
system-irix-o32.ads, system-linux-x86_64.ads,
system-linux-x86.ads, system-lynxos-ppc.ads, system-lynxos-x86.ads,
system-mingw.ads, system-os2.ads, system-solaris-sparc.ads,
system-solaris-sparcv9.ads, system-solaris-x86.ads, system-tru64.ads,
system-unixware.ads, system-vms.ads, system-vms-zcx.ads,
system-vxworks-alpha.ads, system-vxworks-m68k.ads,
system-vxworks-mips.ads, system-vxworks-ppc.ads,
system-vxworks-sparcv9.ads, system-vxworks-xscale.ads: Replace files
above.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@81834 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/s-tratas-default.adb')
-rw-r--r-- | gcc/ada/s-tratas-default.adb | 367 |
1 files changed, 367 insertions, 0 deletions
diff --git a/gcc/ada/s-tratas-default.adb b/gcc/ada/s-tratas-default.adb new file mode 100644 index 00000000000..0e18aed2d96 --- /dev/null +++ b/gcc/ada/s-tratas-default.adb @@ -0,0 +1,367 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E S . T A S K I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2002 Free Software Foundation, Inc. -- +-- -- +-- GNARL is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Tasking; use System.Tasking; +with System.Soft_Links; +with System.Parameters; +with System.Traces.Format; use System.Traces.Format; +with System.Traces; use System.Traces; + +package body System.Traces.Tasking is + + use System.Tasking; + use System.Traces; + use System.Traces.Format; + + package SSL renames System.Soft_Links; + + function Extract_Accepts (Task_Name : Task_ID) return String_Trace; + -- This function is used to extract data joined with + -- W_Select, WT_Select, W_Accept events + + --------------------- + -- Send_Trace_Info -- + --------------------- + + procedure Send_Trace_Info (Id : Trace_T; Task_Name2 : Task_ID) is + Task_S : constant String := SSL.Task_Name.all; + Task2_S : constant String := + Task_Name2.Common.Task_Image + (1 .. Task_Name2.Common.Task_Image_Len); + Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length); + + L0 : Integer := Task_S'Length; + L1 : Integer := Task2_S'Length; + + begin + if Parameters.Runtime_Traces then + case Id is + when M_RDV_Complete | PO_Done => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/C:"; + Trace_S (7 + L0 .. Trace_S'Last) := Task2_S; + Send_Trace (Id, Trace_S); + + when E_Missed => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/A:"; + Trace_S (7 + L0 .. Trace_S'Last) := Task2_S; + Send_Trace (Id, Trace_S); + + when E_Kill => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L1) := Task2_S; + Trace_S (4 + L1 .. Trace_S'Last) := (others => ' '); + Send_Trace (Id, Trace_S); + + when T_Create => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L1) := Task2_S; + Trace_S (4 + L1 .. Trace_S'Last) := (others => ' '); + Send_Trace (Id, Trace_S); + + when others => + null; + -- should raise an exception ??? + end case; + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name2 : Task_ID; + Entry_Number : Entry_Index) + is + Task_S : constant String := SSL.Task_Name.all; + Task2_S : constant String := + Task_Name2.Common.Task_Image + (1 .. Task_Name2.Common.Task_Image_Len); + Entry_S : String := Integer'Image (Integer (Entry_Number)); + Trace_S : String (1 .. 9 + Task_S'Length + + Task2_S'Length + Entry_S'Length); + + L0 : Integer := Task_S'Length; + L1 : Integer := Task_S'Length + Entry_S'Length; + L2 : Integer := Task_S'Length + Task2_S'Length; + + begin + if Parameters.Runtime_Traces then + case Id is + when M_Accept_Complete => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/E:"; + Trace_S (7 + L0 .. 6 + L1) := Entry_S; + Trace_S (7 + L1 .. 9 + L1) := "/C:"; + Trace_S (10 + L1 .. Trace_S'Last) := Task2_S; + Send_Trace (Id, Trace_S); + + when W_Call => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/A:"; + Trace_S (7 + L0 .. 6 + L2) := Task2_S; + Trace_S (7 + L2 .. 9 + L2) := "/C:"; + Trace_S (10 + L2 .. Trace_S'Last) := Entry_S; + Send_Trace (Id, Trace_S); + + when others => + null; + -- should raise an exception ??? + end case; + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : Task_ID; + Task_Name2 : Task_ID; + Entry_Number : Entry_Index) + is + Task_S : constant String := + Task_Name.Common.Task_Image + (1 .. Task_Name.Common.Task_Image_Len); + Task2_S : constant String := + Task_Name2.Common.Task_Image + (1 .. Task_Name2.Common.Task_Image_Len); + Entry_S : String := Integer'Image (Integer (Entry_Number)); + Trace_S : String (1 .. 9 + Task_S'Length + + Task2_S'Length + Entry_S'Length); + + L0 : Integer := Task_S'Length; + L1 : Integer := Task_S'Length + Entry_S'Length; + + begin + if Parameters.Runtime_Traces then + case Id is + when PO_Run => + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/E:"; + Trace_S (7 + L0 .. 6 + L1) := Entry_S; + Trace_S (7 + L1 .. 9 + L1) := "/C:"; + Trace_S (10 + L1 .. Trace_S'Last) := Task2_S; + Send_Trace (Id, Trace_S); + + when others => + null; + -- should raise an exception ??? + end case; + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info (Id : Trace_T; Entry_Number : Entry_Index) is + Task_S : String := SSL.Task_Name.all; + Entry_S : String := Integer'Image (Integer (Entry_Number)); + Trace_S : String (1 .. 6 + Task_S'Length + Entry_S'Length); + + L0 : Integer := Task_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/E:"; + Trace_S (7 + L0 .. Trace_S'Last) := Entry_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : Task_ID; + Task_Name2 : Task_ID) + is + Task_S : constant String := + Task_Name.Common.Task_Image + (1 .. Task_Name.Common.Task_Image_Len); + Task2_S : constant String := + Task_Name2.Common.Task_Image + (1 .. Task_Name2.Common.Task_Image_Len); + Trace_S : String (1 .. 6 + Task_S'Length + Task2_S'Length); + + L0 : Integer := Task2_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task2_S; + Trace_S (4 + L0 .. 6 + L0) := "/P:"; + Trace_S (7 + L0 .. Trace_S'Last) := Task_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Acceptor : Task_ID; + Entry_Number : Entry_Index; + Timeout : Duration) + is + Task_S : constant String := SSL.Task_Name.all; + Acceptor_S : constant String := + Acceptor.Common.Task_Image + (1 .. Acceptor.Common.Task_Image_Len); + Entry_S : String := Integer'Image (Integer (Entry_Number)); + Timeout_S : String := Duration'Image (Timeout); + Trace_S : String (1 .. 12 + Task_S'Length + Acceptor_S'Length + + Entry_S'Length + Timeout_S'Length); + + L0 : Integer := Task_S'Length; + L1 : Integer := Task_S'Length + Acceptor_S'Length; + L2 : Integer := Task_S'Length + Acceptor_S'Length + Entry_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/A:"; + Trace_S (7 + L0 .. 6 + L1) := Acceptor_S; + Trace_S (7 + L1 .. 9 + L1) := "/E:"; + Trace_S (10 + L1 .. 9 + L2) := Entry_S; + Trace_S (10 + L2 .. 12 + L2) := "/T:"; + Trace_S (13 + L2 .. Trace_S'Last) := Timeout_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Entry_Number : Entry_Index; + Timeout : Duration) + is + Task_S : String := SSL.Task_Name.all; + Entry_S : String := Integer'Image (Integer (Entry_Number)); + Timeout_S : String := Duration'Image (Timeout); + Trace_S : String (1 .. 9 + Task_S'Length + + Entry_S'Length + Timeout_S'Length); + + L0 : Integer := Task_S'Length; + L1 : Integer := Task_S'Length + Entry_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/E:"; + Trace_S (7 + L0 .. 6 + L1) := Entry_S; + Trace_S (7 + L1 .. 9 + L1) := "/T:"; + Trace_S (10 + L1 .. Trace_S'Last) := Timeout_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : Task_ID; + Number : Integer) + is + Task_S : String := SSL.Task_Name.all; + Number_S : String := Integer'Image (Number); + Accepts_S : String := Extract_Accepts (Task_Name); + Trace_S : String (1 .. 9 + Task_S'Length + + Number_S'Length + Accepts_S'Length); + + L0 : Integer := Task_S'Length; + L1 : Integer := Task_S'Length + Number_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/#:"; + Trace_S (7 + L0 .. 6 + L1) := Number_S; + Trace_S (7 + L1 .. 9 + L1) := "/E:"; + Trace_S (10 + L1 .. Trace_S'Last) := Accepts_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + procedure Send_Trace_Info + (Id : Trace_T; + Task_Name : Task_ID; + Number : Integer; + Timeout : Duration) + is + Task_S : String := SSL.Task_Name.all; + Timeout_S : String := Duration'Image (Timeout); + Number_S : String := Integer'Image (Number); + Accepts_S : String := Extract_Accepts (Task_Name); + Trace_S : String (1 .. 12 + Task_S'Length + Timeout_S'Length + + Number_S'Length + Accepts_S'Length); + + L0 : Integer := Task_S'Length; + L1 : Integer := Task_S'Length + Timeout_S'Length; + L2 : Integer := Task_S'Length + Timeout_S'Length + Number_S'Length; + + begin + if Parameters.Runtime_Traces then + Trace_S (1 .. 3) := "/N:"; + Trace_S (4 .. 3 + L0) := Task_S; + Trace_S (4 + L0 .. 6 + L0) := "/T:"; + Trace_S (7 + L0 .. 6 + L1) := Timeout_S; + Trace_S (7 + L1 .. 9 + L1) := "/#:"; + Trace_S (10 + L1 .. 9 + L2) := Number_S; + Trace_S (10 + L2 .. 12 + L2) := "/E:"; + Trace_S (13 + L2 .. Trace_S'Last) := Accepts_S; + Send_Trace (Id, Trace_S); + end if; + end Send_Trace_Info; + + --------------------- + -- Extract_Accepts -- + --------------------- + + -- This function returns a string in which all opened + -- Accepts or Selects are given, separated by semi-colons. + + function Extract_Accepts (Task_Name : Task_ID) return String_Trace is + Info_Annex : String_Trace := (ASCII.NUL, others => ' '); + + begin + for J in Task_Name.Open_Accepts'First .. + Task_Name.Open_Accepts'Last - 1 + loop + Info_Annex := Append (Info_Annex, Integer'Image + (Integer (Task_Name.Open_Accepts (J).S)) & ","); + end loop; + + Info_Annex := Append (Info_Annex, + Integer'Image (Integer + (Task_Name.Open_Accepts + (Task_Name.Open_Accepts'Last).S))); + return Info_Annex; + end Extract_Accepts; +end System.Traces.Tasking; |